git.iko.soy/rel8
on 62f323a help sign in
rel8/src/Rel8/Table/These.hs
310 lines 8.1 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 , insertTheseTable, 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.Expr ( Expr )
37import Rel8.Expr.Bool ( (&&.), not_ )
38import Rel8.Expr.Null ( isNonNull )
39import Rel8.Schema.Context.Label
40 ( Labelable
41 , HLabelable, hlabeler, hunlabeler
42 )
43import Rel8.Schema.Context.Nullify
44 ( Nullifiable, ConstrainTag
45 , HNullifiable, HConstrainTag
46 , hencodeTag, hdecodeTag
47 , hnullifier, hunnullifier
48 )
49import Rel8.Schema.HTable ( HTable )
50import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
51import Rel8.Schema.HTable.Identity ( HIdentity(..) )
52import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
53import Rel8.Schema.HTable.These ( HTheseTable(..) )
54import Rel8.Schema.Insert ( Insert )
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 , insertMaybeTable, 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, (<.>) )
76import Data.Functor.Bind ( Bind, (>>-) )
78-- these
79import Data.These ( These )
80import Data.These.Combinators ( justHere, justThere )
83type TheseTable :: Type -> Type -> Type
84data TheseTable a b = TheseTable
85 { here :: MaybeTable a
86 , there :: MaybeTable b
87 }
88 deriving stock Functor
91instance Bifunctor TheseTable where
92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
95instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
96 fs <.> as = TheseTable
97 { here = here fs <> here as
98 , there = there fs <.> there as
99 }
102instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
103 where
104 pure = thatTable
105 (<*>) = (<.>)
108instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
109 TheseTable here1 ma >>- f = case ma >>- f' of
110 mtb -> TheseTable
111 { here = maybeTable here1 ((here1 <>) . fst) mtb
112 , there = snd <$> mtb
113 }
114 where
115 f' a = case f a of
116 TheseTable here2 mb -> (here2,) <$> mb
119instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
120 (>>=) = (>>-)
123instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
124 Semigroup (TheseTable a b)
125 where
126 a <> b = TheseTable
127 { here = here a <> here b
128 , there = there a <> there b
129 }
132instance
133 ( Table context a, Table context b
134 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
135 ) => Table context (TheseTable a b)
136 where
137 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
138 type Context (TheseTable a b) = Context a
140 toColumns = toColumns2 toColumns toColumns
141 fromColumns = fromColumns2 fromColumns fromColumns
142 reify = liftA2 bimap reify reify
143 unreify = liftA2 bimap unreify unreify
146instance
147 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
148 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
149 , Recontextualize from to a1 b1
150 , Recontextualize from to a2 b2
151 ) =>
152 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
155instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
156 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
159instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
160 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
163type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
166instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
167 ToExprs x (These a b)
168 where
169 fromResult =
170 bimap (fromResult @exprs1) (fromResult @exprs2) .
171 fromColumns
172 toResult =
173 toColumns .
174 bimap (toResult @exprs1) (toResult @exprs2)
177toHereTag :: Tag "isJust" a -> Tag "hasHere" a
178toHereTag Tag {..} = Tag {..}
181toThereTag :: Tag "isJust" a -> Tag "hasThere" a
182toThereTag Tag {..} = Tag {..}
185isThisTable :: TheseTable a b -> Expr Bool
186isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
189isThatTable :: TheseTable a b -> Expr Bool
190isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
193isThoseTable :: TheseTable a b -> Expr Bool
194isThoseTable a = hasHereTable a &&. hasThereTable a
197hasHereTable :: TheseTable a b -> Expr Bool
198hasHereTable TheseTable {here} = isJustTable here
201hasThereTable :: TheseTable a b -> Expr Bool
202hasThereTable TheseTable {there} = isJustTable there
205justHereTable :: TheseTable a b -> MaybeTable a
206justHereTable = here
209justThereTable :: TheseTable a b -> MaybeTable b
210justThereTable = there
213thisTable :: Table Expr b => a -> TheseTable a b
214thisTable a = TheseTable (justTable a) nothingTable
217thatTable :: Table Expr a => b -> TheseTable a b
218thatTable b = TheseTable nothingTable (justTable b)
221thoseTable :: a -> b -> TheseTable a b
222thoseTable a b = TheseTable (justTable a) (justTable b)
225theseTable :: Table Expr c
226 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
227theseTable f g h TheseTable {here, there} =
228 maybeTable
229 (maybeTable undefined f here)
230 (\b -> maybeTable (g b) (`h` b) here)
231 there
234insertTheseTable :: (Table Insert a, Table Insert b)
235 => These a b -> TheseTable a b
236insertTheseTable =
237 TheseTable <$> insertMaybeTable . justHere <*> insertMaybeTable . justThere
240nameTheseTable :: ()
241 => Name (Maybe MaybeTag)
242 -> Name (Maybe MaybeTag)
243 -> a
244 -> b
245 -> TheseTable a b
246nameTheseTable here there a b =
247 TheseTable
248 { here = nameMaybeTable here a
249 , there = nameMaybeTable there b
250 }
253toColumns2 ::
254 ( HTable t
255 , HTable u
256 , HConstrainTag context MaybeTag
257 , HLabelable context
258 , HNullifiable context
259 )
260 => (a -> t context)
261 -> (b -> u context)
262 -> TheseTable a b
263 -> HTheseTable t u context
264toColumns2 f g TheseTable {here, there} = HTheseTable
265 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
266 , hhere =
267 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
268 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
269 , hthere =
270 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
271 }
274fromColumns2 ::
275 ( HTable t
276 , HTable u
277 , HConstrainTag context MaybeTag
278 , HLabelable context
279 , HNullifiable context
280 )
281 => (t context -> a)
282 -> (u context -> b)
283 -> HTheseTable t u context
284 -> TheseTable a b
285fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
286 { here =
287 let
288 tag = hdecodeTag $ unHIdentity hhereTag
289 in
290 MaybeTable
291 { tag
292 , just = f $
293 runIdentity $
294 hunnullify (\a -> pure . hunnullifier a) $
295 hunlabel hunlabeler
296 hhere
297 }
298 , there =
299 let
300 tag = hdecodeTag $ unHIdentity hthereTag
301 in
302 MaybeTable
303 { tag
304 , just = g $
305 runIdentity $
306 hunnullify (\a -> pure . hunnullifier a) $
307 hunlabel hunlabeler
308 hthere
309 }
310 }