git.iko.soy/rel8
on 8a680c9 help sign in
rel8/src/Rel8/Table/These.hs
312 lines 8.2 kB history raw
1{-# language DataKinds #-}
2{-# language DeriveFunctor #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language RecordWildCards #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TupleSections #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
16{-# options_ghc -fno-warn-orphans #-}
18module Rel8.Table.These
19 ( TheseTable(..)
20 , theseTable, thisTable, thatTable, thoseTable
21 , isThisTable, isThatTable, isThoseTable
22 , hasHereTable, hasThereTable
23 , justHereTable, justThereTable
24 , aggregateTheseTable, nameTheseTable
25 )
26where
28-- base
29import Control.Applicative ( liftA2 )
30import Data.Bifunctor ( Bifunctor, bimap )
31import Data.Functor.Identity ( runIdentity )
32import Data.Kind ( Type )
33import Prelude hiding ( undefined )
35-- rel8
36import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.Expr.Bool ( (&&.), not_ )
39import Rel8.Expr.Null ( isNonNull )
40import Rel8.Schema.Context.Label
41 ( Labelable
42 , HLabelable, hlabeler, hunlabeler
43 )
44import Rel8.Schema.Context.Nullify
45 ( Nullifiable, ConstrainTag
46 , HNullifiable, HConstrainTag
47 , hencodeTag, hdecodeTag
48 , hnullifier, hunnullifier
49 )
50import Rel8.Schema.HTable ( HTable )
51import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
52import Rel8.Schema.HTable.Identity ( HIdentity(..) )
53import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
54import Rel8.Schema.HTable.These ( HTheseTable(..) )
55import Rel8.Schema.Name ( Name )
56import Rel8.Table
57 ( Table, Columns, Context, fromColumns, toColumns
58 , reify, unreify
59 )
60import Rel8.Table.Eq ( EqTable, eqTable )
61import Rel8.Table.Maybe
62 ( MaybeTable(..)
63 , maybeTable, justTable, nothingTable
64 , isJustTable
65 , aggregateMaybeTable, nameMaybeTable
66 )
67import Rel8.Table.Ord ( OrdTable, ordTable )
68import Rel8.Table.Recontextualize ( Recontextualize )
69import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
70import Rel8.Table.Tag ( Tag(..) )
71import Rel8.Table.Undefined ( undefined )
72import Rel8.Type.Tag ( MaybeTag )
74-- semigroupoids
75import Data.Functor.Apply ( Apply, (<.>), liftF2 )
76import Data.Functor.Bind ( Bind, (>>-) )
78-- these
79import Data.These ( These )
82type TheseTable :: Type -> Type -> Type
83data TheseTable a b = TheseTable
84 { here :: MaybeTable a
85 , there :: MaybeTable b
86 }
87 deriving stock Functor
90instance Bifunctor TheseTable where
91 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
94instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
95 fs <.> as = TheseTable
96 { here = here fs <> here as
97 , there = there fs <.> there as
98 }
101instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
102 where
103 pure = thatTable
104 (<*>) = (<.>)
107instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
108 TheseTable here1 ma >>- f = case ma >>- f' of
109 mtb -> TheseTable
110 { here = maybeTable here1 ((here1 <>) . fst) mtb
111 , there = snd <$> mtb
112 }
113 where
114 f' a = case f a of
115 TheseTable here2 mb -> (here2,) <$> mb
118instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
119 (>>=) = (>>-)
122instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
123 Semigroup (TheseTable a b)
124 where
125 a <> b = TheseTable
126 { here = here a <> here b
127 , there = there a <> there b
128 }
131instance
132 ( Table context a, Table context b
133 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
134 ) => Table context (TheseTable a b)
135 where
136 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
137 type Context (TheseTable a b) = Context a
139 toColumns = toColumns2 toColumns toColumns
140 fromColumns = fromColumns2 fromColumns fromColumns
141 reify = liftA2 bimap reify reify
142 unreify = liftA2 bimap unreify unreify
145instance
146 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
147 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
148 , Recontextualize from to a1 b1
149 , Recontextualize from to a2 b2
150 ) =>
151 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
154instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
155 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
158instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
159 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
162type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
165instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
166 ToExprs x (These a b)
167 where
168 fromResult =
169 bimap (fromResult @exprs1) (fromResult @exprs2) .
170 fromColumns
171 toResult =
172 toColumns .
173 bimap (toResult @exprs1) (toResult @exprs2)
176toHereTag :: Tag "isJust" a -> Tag "hasHere" a
177toHereTag Tag {..} = Tag {..}
180toThereTag :: Tag "isJust" a -> Tag "hasThere" a
181toThereTag Tag {..} = Tag {..}
184isThisTable :: TheseTable a b -> Expr Bool
185isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
188isThatTable :: TheseTable a b -> Expr Bool
189isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
192isThoseTable :: TheseTable a b -> Expr Bool
193isThoseTable a = hasHereTable a &&. hasThereTable a
196hasHereTable :: TheseTable a b -> Expr Bool
197hasHereTable TheseTable {here} = isJustTable here
200hasThereTable :: TheseTable a b -> Expr Bool
201hasThereTable TheseTable {there} = isJustTable there
204justHereTable :: TheseTable a b -> MaybeTable a
205justHereTable = here
208justThereTable :: TheseTable a b -> MaybeTable b
209justThereTable = there
212thisTable :: Table Expr b => a -> TheseTable a b
213thisTable a = TheseTable (justTable a) nothingTable
216thatTable :: Table Expr a => b -> TheseTable a b
217thatTable b = TheseTable nothingTable (justTable b)
220thoseTable :: a -> b -> TheseTable a b
221thoseTable a b = TheseTable (justTable a) (justTable b)
224theseTable :: Table Expr c
225 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
226theseTable f g h TheseTable {here, there} =
227 maybeTable
228 (maybeTable undefined f here)
229 (\b -> maybeTable (g b) (`h` b) here)
230 there
233aggregateTheseTable :: ()
234 => (a -> Aggregate c)
235 -> (b -> Aggregate d)
236 -> TheseTable a b
237 -> Aggregate (TheseTable c d)
238aggregateTheseTable f g TheseTable {here, there} =
239 liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
242nameTheseTable :: ()
243 => Name (Maybe MaybeTag)
244 -> Name (Maybe MaybeTag)
245 -> a
246 -> b
247 -> TheseTable a b
248nameTheseTable here there a b =
249 TheseTable
250 { here = nameMaybeTable here a
251 , there = nameMaybeTable there b
252 }
255toColumns2 ::
256 ( HTable t
257 , HTable u
258 , HConstrainTag context MaybeTag
259 , HLabelable context
260 , HNullifiable context
261 )
262 => (a -> t context)
263 -> (b -> u context)
264 -> TheseTable a b
265 -> HTheseTable t u context
266toColumns2 f g TheseTable {here, there} = HTheseTable
267 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
268 , hhere =
269 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
270 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
271 , hthere =
272 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
273 }
276fromColumns2 ::
277 ( HTable t
278 , HTable u
279 , HConstrainTag context MaybeTag
280 , HLabelable context
281 , HNullifiable context
282 )
283 => (t context -> a)
284 -> (u context -> b)
285 -> HTheseTable t u context
286 -> TheseTable a b
287fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
288 { here =
289 let
290 tag = hdecodeTag $ unHIdentity hhereTag
291 in
292 MaybeTable
293 { tag
294 , just = f $
295 runIdentity $
296 hunnullify (\a -> pure . hunnullifier a) $
297 hunlabel hunlabeler
298 hhere
299 }
300 , there =
301 let
302 tag = hdecodeTag $ unHIdentity hthereTag
303 in
304 MaybeTable
305 { tag
306 , just = g $
307 runIdentity $
308 hunnullify (\a -> pure . hunnullifier a) $
309 hunlabel hunlabeler
310 hthere
311 }
312 }