git.iko.soy/rel8
on 11a2229 help sign in
rel8/src/Rel8/Table/These.hs
286 lines 7.5 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 Data.Bifunctor ( Bifunctor, bimap )
28import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
30import Prelude hiding ( undefined )
32-- rel8
33import Rel8.Aggregate ( Aggregate )
34import Rel8.Expr ( Expr )
35import Rel8.Expr.Bool ( (&&.), not_ )
36import Rel8.Expr.Null ( isNonNull )
37import Rel8.Schema.Context.Label
38 ( Labelable
39 , HLabelable, hlabeler, hunlabeler
40 )
41import Rel8.Schema.Context.Nullify
42 ( Nullifiable, ConstrainTag
43 , HNullifiable, HConstrainTag
44 , hencodeTag, hdecodeTag
45 , hnullifier, hunnullifier
46 )
47import Rel8.Schema.HTable ( HTable )
48import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
49import Rel8.Schema.HTable.Identity ( HIdentity(..) )
50import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
51import Rel8.Schema.HTable.These ( HTheseTable(..) )
52import Rel8.Schema.Name ( Name )
53import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Maybe
56 ( MaybeTable(..)
57 , maybeTable, justTable, nothingTable
58 , isJustTable
59 , aggregateMaybeTable, nameMaybeTable
60 )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Tag ( Tag(..) )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Type.Tag ( MaybeTag )
67-- semigroupoids
68import Data.Functor.Apply ( Apply, (<.>), liftF2 )
69import Data.Functor.Bind ( Bind, (>>-) )
72type TheseTable :: Type -> Type -> Type
73data TheseTable a b = TheseTable
74 { here :: MaybeTable a
75 , there :: MaybeTable b
76 }
77 deriving stock Functor
80instance Bifunctor TheseTable where
81 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
84instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
85 fs <.> as = TheseTable
86 { here = here fs <> here as
87 , there = there fs <.> there as
88 }
91instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
92 where
93 pure = thatTable
94 (<*>) = (<.>)
97instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
98 TheseTable here1 ma >>- f = case ma >>- f' of
99 mtb -> TheseTable
100 { here = maybeTable here1 ((here1 <>) . fst) mtb
101 , there = snd <$> mtb
102 }
103 where
104 f' a = case f a of
105 TheseTable here2 mb -> (here2,) <$> mb
108instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
109 (>>=) = (>>-)
112instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
113 Semigroup (TheseTable a b)
114 where
115 a <> b = TheseTable
116 { here = here a <> here b
117 , there = there a <> there b
118 }
121instance
122 ( Table context a, Table context b
123 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
124 ) => Table context (TheseTable a b)
125 where
126 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
127 type Context (TheseTable a b) = Context a
129 toColumns = toColumns2 toColumns toColumns
130 fromColumns = fromColumns2 fromColumns fromColumns
133instance
134 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
135 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
136 , Recontextualize from to a1 b1
137 , Recontextualize from to a2 b2
138 ) =>
139 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
142instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
143 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
146instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
147 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
150toHereTag :: Tag "isJust" a -> Tag "hasHere" a
151toHereTag Tag {..} = Tag {..}
154toThereTag :: Tag "isJust" a -> Tag "hasThere" a
155toThereTag Tag {..} = Tag {..}
158isThisTable :: TheseTable a b -> Expr Bool
159isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
162isThatTable :: TheseTable a b -> Expr Bool
163isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
166isThoseTable :: TheseTable a b -> Expr Bool
167isThoseTable a = hasHereTable a &&. hasThereTable a
170hasHereTable :: TheseTable a b -> Expr Bool
171hasHereTable TheseTable {here} = isJustTable here
174hasThereTable :: TheseTable a b -> Expr Bool
175hasThereTable TheseTable {there} = isJustTable there
178justHereTable :: TheseTable a b -> MaybeTable a
179justHereTable = here
182justThereTable :: TheseTable a b -> MaybeTable b
183justThereTable = there
186thisTable :: Table Expr b => a -> TheseTable a b
187thisTable a = TheseTable (justTable a) nothingTable
190thatTable :: Table Expr a => b -> TheseTable a b
191thatTable b = TheseTable nothingTable (justTable b)
194thoseTable :: a -> b -> TheseTable a b
195thoseTable a b = TheseTable (justTable a) (justTable b)
198theseTable :: Table Expr c
199 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
200theseTable f g h TheseTable {here, there} =
201 maybeTable
202 (maybeTable undefined f here)
203 (\b -> maybeTable (g b) (`h` b) here)
204 there
207aggregateTheseTable :: ()
208 => (a -> Aggregate c)
209 -> (b -> Aggregate d)
210 -> TheseTable a b
211 -> Aggregate (TheseTable c d)
212aggregateTheseTable f g TheseTable {here, there} =
213 liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
216nameTheseTable :: ()
217 => Name (Maybe MaybeTag)
218 -> Name (Maybe MaybeTag)
219 -> a
220 -> b
221 -> TheseTable a b
222nameTheseTable here there a b =
223 TheseTable
224 { here = nameMaybeTable here a
225 , there = nameMaybeTable there b
226 }
229toColumns2 ::
230 ( HTable t
231 , HTable u
232 , HConstrainTag context MaybeTag
233 , HLabelable context
234 , HNullifiable context
235 )
236 => (a -> t context)
237 -> (b -> u context)
238 -> TheseTable a b
239 -> HTheseTable t u context
240toColumns2 f g TheseTable {here, there} = HTheseTable
241 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
242 , hhere =
243 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
244 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
245 , hthere =
246 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
247 }
250fromColumns2 ::
251 ( HTable t
252 , HTable u
253 , HConstrainTag context MaybeTag
254 , HLabelable context
255 , HNullifiable context
256 )
257 => (t context -> a)
258 -> (u context -> b)
259 -> HTheseTable t u context
260 -> TheseTable a b
261fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
262 { here =
263 let
264 tag = hdecodeTag $ unHIdentity hhereTag
265 in
266 MaybeTable
267 { tag
268 , just = f $
269 runIdentity $
270 hunnullify (\a -> pure . hunnullifier a) $
271 hunlabel hunlabeler
272 hhere
273 }
274 , there =
275 let
276 tag = hdecodeTag $ unHIdentity hthereTag
277 in
278 MaybeTable
279 { tag
280 , just = g $
281 runIdentity $
282 hunnullify (\a -> pure . hunnullifier a) $
283 hunlabel hunlabeler
284 hthere
285 }
286 }