git.iko.soy/rel8
on 4b50256 help sign in
rel8/src/Rel8/Table/These.hs
302 lines 7.8 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 , 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.Name ( Name )
55import Rel8.Table
56 ( Table, Columns, Context, fromColumns, toColumns
57 , reify, unreify
58 )
59import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Maybe
61 ( MaybeTable(..)
62 , maybeTable, justTable, nothingTable
63 , isJustTable
64 , nameMaybeTable
65 )
66import Rel8.Table.Ord ( OrdTable, ordTable )
67import Rel8.Table.Recontextualize ( Recontextualize )
68import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
69import Rel8.Table.Tag ( Tag(..) )
70import Rel8.Table.Undefined ( undefined )
71import Rel8.Type.Tag ( MaybeTag )
73-- semigroupoids
74import Data.Functor.Apply ( Apply, (<.>) )
75import Data.Functor.Bind ( Bind, (>>-) )
77-- these
78import Data.These ( These )
81type TheseTable :: Type -> Type -> Type
82data TheseTable a b = TheseTable
83 { here :: MaybeTable a
84 , there :: MaybeTable b
85 }
86 deriving stock Functor
89instance Bifunctor TheseTable where
90 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
93instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
94 fs <.> as = TheseTable
95 { here = here fs <> here as
96 , there = there fs <.> there as
97 }
100instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
101 where
102 pure = thatTable
103 (<*>) = (<.>)
106instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
107 TheseTable here1 ma >>- f = case ma >>- f' of
108 mtb -> TheseTable
109 { here = maybeTable here1 ((here1 <>) . fst) mtb
110 , there = snd <$> mtb
111 }
112 where
113 f' a = case f a of
114 TheseTable here2 mb -> (here2,) <$> mb
117instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
118 (>>=) = (>>-)
121instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
122 Semigroup (TheseTable a b)
123 where
124 a <> b = TheseTable
125 { here = here a <> here b
126 , there = there a <> there b
127 }
130instance
131 ( Table context a, Table context b
132 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
133 ) => Table context (TheseTable a b)
134 where
135 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
136 type Context (TheseTable a b) = Context a
138 toColumns = toColumns2 toColumns toColumns
139 fromColumns = fromColumns2 fromColumns fromColumns
140 reify = liftA2 bimap reify reify
141 unreify = liftA2 bimap unreify unreify
144instance
145 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
146 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
147 , Recontextualize from to a1 b1
148 , Recontextualize from to a2 b2
149 ) =>
150 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
153instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
154 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
157instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
158 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
161type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
164instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
165 ToExprs x (These a b)
166 where
167 fromResult =
168 bimap (fromResult @exprs1) (fromResult @exprs2) .
169 fromColumns
170 toResult =
171 toColumns .
172 bimap (toResult @exprs1) (toResult @exprs2)
175toHereTag :: Tag "isJust" a -> Tag "hasHere" a
176toHereTag Tag {..} = Tag {..}
179toThereTag :: Tag "isJust" a -> Tag "hasThere" a
180toThereTag Tag {..} = Tag {..}
183isThisTable :: TheseTable a b -> Expr Bool
184isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
187isThatTable :: TheseTable a b -> Expr Bool
188isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
191isThoseTable :: TheseTable a b -> Expr Bool
192isThoseTable a = hasHereTable a &&. hasThereTable a
195hasHereTable :: TheseTable a b -> Expr Bool
196hasHereTable TheseTable {here} = isJustTable here
199hasThereTable :: TheseTable a b -> Expr Bool
200hasThereTable TheseTable {there} = isJustTable there
203justHereTable :: TheseTable a b -> MaybeTable a
204justHereTable = here
207justThereTable :: TheseTable a b -> MaybeTable b
208justThereTable = there
211thisTable :: Table Expr b => a -> TheseTable a b
212thisTable a = TheseTable (justTable a) nothingTable
215thatTable :: Table Expr a => b -> TheseTable a b
216thatTable b = TheseTable nothingTable (justTable b)
219thoseTable :: a -> b -> TheseTable a b
220thoseTable a b = TheseTable (justTable a) (justTable b)
223theseTable :: Table Expr c
224 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
225theseTable f g h TheseTable {here, there} =
226 maybeTable
227 (maybeTable undefined f here)
228 (\b -> maybeTable (g b) (`h` b) here)
229 there
232nameTheseTable :: ()
233 => Name (Maybe MaybeTag)
234 -> Name (Maybe MaybeTag)
235 -> a
236 -> b
237 -> TheseTable a b
238nameTheseTable here there a b =
239 TheseTable
240 { here = nameMaybeTable here a
241 , there = nameMaybeTable there b
242 }
245toColumns2 ::
246 ( HTable t
247 , HTable u
248 , HConstrainTag context MaybeTag
249 , HLabelable context
250 , HNullifiable context
251 )
252 => (a -> t context)
253 -> (b -> u context)
254 -> TheseTable a b
255 -> HTheseTable t u context
256toColumns2 f g TheseTable {here, there} = HTheseTable
257 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
258 , hhere =
259 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
260 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
261 , hthere =
262 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
263 }
266fromColumns2 ::
267 ( HTable t
268 , HTable u
269 , HConstrainTag context MaybeTag
270 , HLabelable context
271 , HNullifiable context
272 )
273 => (t context -> a)
274 -> (u context -> b)
275 -> HTheseTable t u context
276 -> TheseTable a b
277fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
278 { here =
279 let
280 tag = hdecodeTag $ unHIdentity hhereTag
281 in
282 MaybeTable
283 { tag
284 , just = f $
285 runIdentity $
286 hunnullify (\a -> pure . hunnullifier a) $
287 hunlabel hunlabeler
288 hhere
289 }
290 , there =
291 let
292 tag = hdecodeTag $ unHIdentity hthereTag
293 in
294 MaybeTable
295 { tag
296 , just = g $
297 runIdentity $
298 hunnullify (\a -> pure . hunnullifier a) $
299 hunlabel hunlabeler
300 hthere
301 }
302 }