git.iko.soy/rel8
on 4e1b3b7 help sign in
rel8/src/Rel8/Table/These.hs
335 lines 9.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 #-}
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.Nullify
40 ( Nullifiable, ConstrainTag
41 , HNullifiable, HConstrainTag
42 , hencodeTag, hdecodeTag
43 , hnullifier, hunnullifier
44 )
45import Rel8.Schema.HTable ( HTable )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47import Rel8.Schema.HTable.Identity ( HIdentity(..) )
48import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
49import Rel8.Schema.HTable.These ( HTheseTable(..) )
50import Rel8.Schema.Name ( Name )
51import Rel8.Table
52 ( Table, Columns, Context, fromColumns, toColumns
53 , reify, unreify
54 )
55import Rel8.Table.Eq ( EqTable, eqTable )
56import Rel8.Table.Maybe
57 ( MaybeTable(..)
58 , maybeTable, justTable, nothingTable
59 , isJustTable
60 , nameMaybeTable
61 )
62import Rel8.Table.Ord ( OrdTable, ordTable )
63import Rel8.Table.Recontextualize ( Recontextualize )
64import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
65import Rel8.Table.Tag ( Tag(..) )
66import Rel8.Table.Undefined ( undefined )
67import Rel8.Type.Tag ( MaybeTag )
69-- semigroupoids
70import Data.Functor.Apply ( Apply, (<.>) )
71import Data.Functor.Bind ( Bind, (>>-) )
73-- these
74import Data.These ( These )
77-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
78-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
79-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
80-- eliminated/pattern matched using 'theseTable'.
81--
82-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
83-- adapted to work with Rel8.
84type TheseTable :: Type -> Type -> Type
85data TheseTable a b = TheseTable
86 { here :: MaybeTable a
87 , there :: MaybeTable b
88 }
89 deriving stock Functor
92instance Bifunctor TheseTable where
93 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
96instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
97 fs <.> as = TheseTable
98 { here = here fs <> here as
99 , there = there fs <.> there as
100 }
103instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
104 where
105 pure = thatTable
106 (<*>) = (<.>)
109instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
110 TheseTable here1 ma >>- f = case ma >>- f' of
111 mtb -> TheseTable
112 { here = maybeTable here1 ((here1 <>) . fst) mtb
113 , there = snd <$> mtb
114 }
115 where
116 f' a = case f a of
117 TheseTable here2 mb -> (here2,) <$> mb
120instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
121 (>>=) = (>>-)
124instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
125 Semigroup (TheseTable a b)
126 where
127 a <> b = TheseTable
128 { here = here a <> here b
129 , there = there a <> there b
130 }
133instance
134 ( Table context a, Table context b
135 , Nullifiable context, ConstrainTag context MaybeTag
136 ) => Table context (TheseTable a b)
137 where
138 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
139 type Context (TheseTable a b) = Context a
141 toColumns = toColumns2 toColumns toColumns
142 fromColumns = fromColumns2 fromColumns fromColumns
143 reify = liftA2 bimap reify reify
144 unreify = liftA2 bimap unreify unreify
147instance
148 ( Nullifiable from, ConstrainTag from MaybeTag
149 , Nullifiable to, ConstrainTag to MaybeTag
150 , Recontextualize from to a1 b1
151 , Recontextualize from to a2 b2
152 ) =>
153 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
156instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
157 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
160instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
161 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
164type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
167instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
168 ToExprs x (These a b)
169 where
170 fromResult =
171 bimap (fromResult @exprs1) (fromResult @exprs2) .
172 fromColumns
173 toResult =
174 toColumns .
175 bimap (toResult @exprs1) (toResult @exprs2)
178toHereTag :: Tag "isJust" a -> Tag "hasHere" a
179toHereTag Tag {..} = Tag {..}
182toThereTag :: Tag "isJust" a -> Tag "hasThere" a
183toThereTag Tag {..} = Tag {..}
186-- | Test if a 'TheseTable' was constructed with 'thisTable'.
187--
188-- Corresponds to 'Data.These.Combinators.isThis'.
189isThisTable :: TheseTable a b -> Expr Bool
190isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
193-- | Test if a 'TheseTable' was constructed with 'thatTable'.
194--
195-- Corresponds to 'Data.These.Combinators.isThat'.
196isThatTable :: TheseTable a b -> Expr Bool
197isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
200-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
201--
202-- Corresponds to 'Data.These.Combinators.isThese'.
203isThoseTable :: TheseTable a b -> Expr Bool
204isThoseTable a = hasHereTable a &&. hasThereTable a
207-- | Test if the @a@ side of @TheseTable a b@ is present.
208--
209-- Corresponds to 'Data.These.Combinators.hasHere'.
210hasHereTable :: TheseTable a b -> Expr Bool
211hasHereTable TheseTable {here} = isJustTable here
214-- | Test if the @b@ table of @TheseTable a b@ is present.
215--
216-- Corresponds to 'Data.These.Combinators.hasThere'.
217hasThereTable :: TheseTable a b -> Expr Bool
218hasThereTable TheseTable {there} = isJustTable there
221-- | Attempt to project out the @a@ table of a @TheseTable a b@.
222--
223-- Corresponds to 'Data.These.Combinators.justHere'.
224justHereTable :: TheseTable a b -> MaybeTable a
225justHereTable = here
228-- | Attempt to project out the @b@ table of a @TheseTable a b@.
229--
230-- Corresponds to 'Data.These.Combinators.justThere'.
231justThereTable :: TheseTable a b -> MaybeTable b
232justThereTable = there
235-- | Construct a @TheseTable@. Corresponds to 'This'.
236thisTable :: Table Expr b => a -> TheseTable a b
237thisTable a = TheseTable (justTable a) nothingTable
240-- | Construct a @TheseTable@. Corresponds to 'That'.
241thatTable :: Table Expr a => b -> TheseTable a b
242thatTable b = TheseTable nothingTable (justTable b)
245-- | Construct a @TheseTable@. Corresponds to 'These'.
246thoseTable :: a -> b -> TheseTable a b
247thoseTable a b = TheseTable (justTable a) (justTable b)
250-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
251theseTable :: Table Expr c
252 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
253theseTable f g h TheseTable {here, there} =
254 maybeTable
255 (maybeTable undefined f here)
256 (\b -> maybeTable (g b) (`h` b) here)
257 there
260-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
261-- have a 'TheseTable' that you are storing in a table and need to construct a
262-- 'TableSchema'.
263nameTheseTable :: ()
264 => Name (Maybe MaybeTag)
265 -- ^ The name of the column to track the presence of the @a@ table.
266 -> Name (Maybe MaybeTag)
267 -- ^ The name of the column to track the presence of the @b@ table.
268 -> a
269 -- ^ Names of the columns in the @a@ table.
270 -> b
271 -- ^ Names of the columns in the @b@ table.
272 -> TheseTable a b
273nameTheseTable here there a b =
274 TheseTable
275 { here = nameMaybeTable here a
276 , there = nameMaybeTable there b
277 }
280toColumns2 ::
281 ( HTable t
282 , HTable u
283 , HConstrainTag context MaybeTag
284 , HNullifiable context
285 )
286 => (a -> t context)
287 -> (b -> u context)
288 -> TheseTable a b
289 -> HTheseTable t u context
290toColumns2 f g TheseTable {here, there} = HTheseTable
291 { hhereTag = hlabel $ HType $ hencodeTag (toHereTag (tag here))
292 , hhere =
293 hlabel $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
294 , hthereTag = hlabel $ HType $ hencodeTag (toThereTag (tag there))
295 , hthere =
296 hlabel $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
297 }
300fromColumns2 ::
301 ( HTable t
302 , HTable u
303 , HConstrainTag context MaybeTag
304 , HNullifiable context
305 )
306 => (t context -> a)
307 -> (u context -> b)
308 -> HTheseTable t u context
309 -> TheseTable a b
310fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
311 { here =
312 let
313 tag = hdecodeTag $ unHIdentity $ hunlabel hhereTag
314 in
315 MaybeTable
316 { tag
317 , just = f $
318 runIdentity $
319 hunnullify (\a -> pure . hunnullifier a) $
320 hunlabel
321 hhere
322 }
323 , there =
324 let
325 tag = hdecodeTag $ unHIdentity $ hunlabel hthereTag
326 in
327 MaybeTable
328 { tag
329 , just = g $
330 runIdentity $
331 hunnullify (\a -> pure . hunnullifier a) $
332 hunlabel
333 hthere
334 }
335 }