git.iko.soy/rel8
on 6e42c1e help sign in
rel8/src/Rel8/Table/These.hs
292 lines 7.7 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 #-}
16module Rel8.Table.These
17 ( TheseTable(..)
18 , theseTable, thisTable, thatTable, thoseTable
19 , isThisTable, isThatTable, isThoseTable
20 , hasHereTable, hasThereTable
21 , justHereTable, justThereTable
22 , aggregateTheseTable, nameTheseTable
23 )
24where
26-- base
27import Control.Applicative ( liftA2 )
28import Data.Bifunctor ( Bifunctor, bimap )
29import Data.Functor.Identity ( runIdentity )
30import Data.Kind ( Type )
31import Prelude hiding ( undefined )
33-- rel8
34import Rel8.Aggregate ( Aggregate )
35import Rel8.Expr ( Expr )
36import Rel8.Expr.Bool ( (&&.), not_ )
37import Rel8.Expr.Null ( isNonNull )
38import Rel8.Schema.Context.Label
39 ( Labelable
40 , HLabelable, hlabeler, hunlabeler
41 )
42import Rel8.Schema.Context.Nullify
43 ( Nullifiable, ConstrainTag
44 , HNullifiable, HConstrainTag
45 , hencodeTag, hdecodeTag
46 , hnullifier, hunnullifier
47 )
48import Rel8.Schema.HTable ( HTable )
49import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
50import Rel8.Schema.HTable.Identity ( HIdentity(..) )
51import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
52import Rel8.Schema.HTable.These ( HTheseTable(..) )
53import Rel8.Schema.Name ( Name )
54import Rel8.Table
55 ( Table, Columns, Context, fromColumns, toColumns
56 , reify, unreify
57 )
58import Rel8.Table.Eq ( EqTable, eqTable )
59import Rel8.Table.Maybe
60 ( MaybeTable(..)
61 , maybeTable, justTable, nothingTable
62 , isJustTable
63 , aggregateMaybeTable, nameMaybeTable
64 )
65import Rel8.Table.Ord ( OrdTable, ordTable )
66import Rel8.Table.Recontextualize ( Recontextualize )
67import Rel8.Table.Tag ( Tag(..) )
68import Rel8.Table.Undefined ( undefined )
69import Rel8.Type.Tag ( MaybeTag )
71-- semigroupoids
72import Data.Functor.Apply ( Apply, (<.>), liftF2 )
73import Data.Functor.Bind ( Bind, (>>-) )
76type TheseTable :: Type -> Type -> Type
77data TheseTable a b = TheseTable
78 { here :: MaybeTable a
79 , there :: MaybeTable b
80 }
81 deriving stock Functor
84instance Bifunctor TheseTable where
85 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
88instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
89 fs <.> as = TheseTable
90 { here = here fs <> here as
91 , there = there fs <.> there as
92 }
95instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
96 where
97 pure = thatTable
98 (<*>) = (<.>)
101instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
102 TheseTable here1 ma >>- f = case ma >>- f' of
103 mtb -> TheseTable
104 { here = maybeTable here1 ((here1 <>) . fst) mtb
105 , there = snd <$> mtb
106 }
107 where
108 f' a = case f a of
109 TheseTable here2 mb -> (here2,) <$> mb
112instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
113 (>>=) = (>>-)
116instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
117 Semigroup (TheseTable a b)
118 where
119 a <> b = TheseTable
120 { here = here a <> here b
121 , there = there a <> there b
122 }
125instance
126 ( Table context a, Table context b
127 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
128 ) => Table context (TheseTable a b)
129 where
130 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
131 type Context (TheseTable a b) = Context a
133 toColumns = toColumns2 toColumns toColumns
134 fromColumns = fromColumns2 fromColumns fromColumns
135 reify = liftA2 bimap reify reify
136 unreify = liftA2 bimap unreify unreify
139instance
140 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
141 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
142 , Recontextualize from to a1 b1
143 , Recontextualize from to a2 b2
144 ) =>
145 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
148instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
149 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
152instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
153 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
156toHereTag :: Tag "isJust" a -> Tag "hasHere" a
157toHereTag Tag {..} = Tag {..}
160toThereTag :: Tag "isJust" a -> Tag "hasThere" a
161toThereTag Tag {..} = Tag {..}
164isThisTable :: TheseTable a b -> Expr Bool
165isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
168isThatTable :: TheseTable a b -> Expr Bool
169isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
172isThoseTable :: TheseTable a b -> Expr Bool
173isThoseTable a = hasHereTable a &&. hasThereTable a
176hasHereTable :: TheseTable a b -> Expr Bool
177hasHereTable TheseTable {here} = isJustTable here
180hasThereTable :: TheseTable a b -> Expr Bool
181hasThereTable TheseTable {there} = isJustTable there
184justHereTable :: TheseTable a b -> MaybeTable a
185justHereTable = here
188justThereTable :: TheseTable a b -> MaybeTable b
189justThereTable = there
192thisTable :: Table Expr b => a -> TheseTable a b
193thisTable a = TheseTable (justTable a) nothingTable
196thatTable :: Table Expr a => b -> TheseTable a b
197thatTable b = TheseTable nothingTable (justTable b)
200thoseTable :: a -> b -> TheseTable a b
201thoseTable a b = TheseTable (justTable a) (justTable b)
204theseTable :: Table Expr c
205 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
206theseTable f g h TheseTable {here, there} =
207 maybeTable
208 (maybeTable undefined f here)
209 (\b -> maybeTable (g b) (`h` b) here)
210 there
213aggregateTheseTable :: ()
214 => (a -> Aggregate c)
215 -> (b -> Aggregate d)
216 -> TheseTable a b
217 -> Aggregate (TheseTable c d)
218aggregateTheseTable f g TheseTable {here, there} =
219 liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
222nameTheseTable :: ()
223 => Name (Maybe MaybeTag)
224 -> Name (Maybe MaybeTag)
225 -> a
226 -> b
227 -> TheseTable a b
228nameTheseTable here there a b =
229 TheseTable
230 { here = nameMaybeTable here a
231 , there = nameMaybeTable there b
232 }
235toColumns2 ::
236 ( HTable t
237 , HTable u
238 , HConstrainTag context MaybeTag
239 , HLabelable context
240 , HNullifiable context
241 )
242 => (a -> t context)
243 -> (b -> u context)
244 -> TheseTable a b
245 -> HTheseTable t u context
246toColumns2 f g TheseTable {here, there} = HTheseTable
247 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
248 , hhere =
249 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
250 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
251 , hthere =
252 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
253 }
256fromColumns2 ::
257 ( HTable t
258 , HTable u
259 , HConstrainTag context MaybeTag
260 , HLabelable context
261 , HNullifiable context
262 )
263 => (t context -> a)
264 -> (u context -> b)
265 -> HTheseTable t u context
266 -> TheseTable a b
267fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
268 { here =
269 let
270 tag = hdecodeTag $ unHIdentity hhereTag
271 in
272 MaybeTable
273 { tag
274 , just = f $
275 runIdentity $
276 hunnullify (\a -> pure . hunnullifier a) $
277 hunlabel hunlabeler
278 hhere
279 }
280 , there =
281 let
282 tag = hdecodeTag $ unHIdentity hthereTag
283 in
284 MaybeTable
285 { tag
286 , just = g $
287 runIdentity $
288 hunnullify (\a -> pure . hunnullifier a) $
289 hunlabel hunlabeler
290 hthere
291 }
292 }