git.iko.soy/rel8
on 137ebed help sign in
rel8/src/Rel8/Table/These.hs
341 lines 9.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 #-}
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 )
81-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
82-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
83-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
84-- eliminated/pattern matched using 'theseTable'.
85--
86-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
87-- adapted to work with Rel8.
88type TheseTable :: Type -> Type -> Type
89data TheseTable a b = TheseTable
90 { here :: MaybeTable a
91 , there :: MaybeTable b
92 }
93 deriving stock Functor
96instance Bifunctor TheseTable where
97 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
100instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
101 fs <.> as = TheseTable
102 { here = here fs <> here as
103 , there = there fs <.> there as
104 }
107instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
108 where
109 pure = thatTable
110 (<*>) = (<.>)
113instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
114 TheseTable here1 ma >>- f = case ma >>- f' of
115 mtb -> TheseTable
116 { here = maybeTable here1 ((here1 <>) . fst) mtb
117 , there = snd <$> mtb
118 }
119 where
120 f' a = case f a of
121 TheseTable here2 mb -> (here2,) <$> mb
124instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
125 (>>=) = (>>-)
128instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
129 Semigroup (TheseTable a b)
130 where
131 a <> b = TheseTable
132 { here = here a <> here b
133 , there = there a <> there b
134 }
137instance
138 ( Table context a, Table context b
139 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
140 ) => Table context (TheseTable a b)
141 where
142 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
143 type Context (TheseTable a b) = Context a
145 toColumns = toColumns2 toColumns toColumns
146 fromColumns = fromColumns2 fromColumns fromColumns
147 reify = liftA2 bimap reify reify
148 unreify = liftA2 bimap unreify unreify
151instance
152 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
153 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
154 , Recontextualize from to a1 b1
155 , Recontextualize from to a2 b2
156 ) =>
157 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
160instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
161 eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
164instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
165 ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
168type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
171instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
172 ToExprs x (These a b)
173 where
174 fromResult =
175 bimap (fromResult @exprs1) (fromResult @exprs2) .
176 fromColumns
177 toResult =
178 toColumns .
179 bimap (toResult @exprs1) (toResult @exprs2)
182toHereTag :: Tag "isJust" a -> Tag "hasHere" a
183toHereTag Tag {..} = Tag {..}
186toThereTag :: Tag "isJust" a -> Tag "hasThere" a
187toThereTag Tag {..} = Tag {..}
190-- | Test if a 'TheseTable' was constructed with 'thisTable'.
191--
192-- Corresponds to 'Data.These.Combinators.isThis'.
193isThisTable :: TheseTable a b -> Expr Bool
194isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
197-- | Test if a 'TheseTable' was constructed with 'thatTable'.
198--
199-- Corresponds to 'Data.These.Combinators.isThat'.
200isThatTable :: TheseTable a b -> Expr Bool
201isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
204-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
205--
206-- Corresponds to 'Data.These.Combinators.isThese'.
207isThoseTable :: TheseTable a b -> Expr Bool
208isThoseTable a = hasHereTable a &&. hasThereTable a
211-- | Test if the @a@ side of @TheseTable a b@ is present.
212--
213-- Corresponds to 'Data.These.Combinators.hasHere'.
214hasHereTable :: TheseTable a b -> Expr Bool
215hasHereTable TheseTable {here} = isJustTable here
218-- | Test if the @b@ table of @TheseTable a b@ is present.
219--
220-- Corresponds to 'Data.These.Combinators.hasThere'.
221hasThereTable :: TheseTable a b -> Expr Bool
222hasThereTable TheseTable {there} = isJustTable there
225-- | Attempt to project out the @a@ table of a @TheseTable a b@.
226--
227-- Corresponds to 'Data.These.Combinators.justHere'.
228justHereTable :: TheseTable a b -> MaybeTable a
229justHereTable = here
232-- | Attempt to project out the @b@ table of a @TheseTable a b@.
233--
234-- Corresponds to 'Data.These.Combinators.justThere'.
235justThereTable :: TheseTable a b -> MaybeTable b
236justThereTable = there
239-- | Construct a @TheseTable@. Corresponds to 'This'.
240thisTable :: Table Expr b => a -> TheseTable a b
241thisTable a = TheseTable (justTable a) nothingTable
244-- | Construct a @TheseTable@. Corresponds to 'That'.
245thatTable :: Table Expr a => b -> TheseTable a b
246thatTable b = TheseTable nothingTable (justTable b)
249-- | Construct a @TheseTable@. Corresponds to 'These'.
250thoseTable :: a -> b -> TheseTable a b
251thoseTable a b = TheseTable (justTable a) (justTable b)
254-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
255theseTable :: Table Expr c
256 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
257theseTable f g h TheseTable {here, there} =
258 maybeTable
259 (maybeTable undefined f here)
260 (\b -> maybeTable (g b) (`h` b) here)
261 there
264-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
265-- have a 'TheseTable' that you are storing in a table and need to construct a
266-- 'TableSchema'.
267nameTheseTable :: ()
268 => Name (Maybe MaybeTag)
269 -- ^ The name of the column to track the presence of the @a@ table.
270 -> Name (Maybe MaybeTag)
271 -- ^ The name of the column to track the presence of the @b@ table.
272 -> a
273 -- ^ Names of the columns in the @a@ table.
274 -> b
275 -- ^ Names of the columns in the @b@ table.
276 -> TheseTable a b
277nameTheseTable here there a b =
278 TheseTable
279 { here = nameMaybeTable here a
280 , there = nameMaybeTable there b
281 }
284toColumns2 ::
285 ( HTable t
286 , HTable u
287 , HConstrainTag context MaybeTag
288 , HLabelable context
289 , HNullifiable context
290 )
291 => (a -> t context)
292 -> (b -> u context)
293 -> TheseTable a b
294 -> HTheseTable t u context
295toColumns2 f g TheseTable {here, there} = HTheseTable
296 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
297 , hhere =
298 hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
299 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
300 , hthere =
301 hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
302 }
305fromColumns2 ::
306 ( HTable t
307 , HTable u
308 , HConstrainTag context MaybeTag
309 , HLabelable context
310 , HNullifiable context
311 )
312 => (t context -> a)
313 -> (u context -> b)
314 -> HTheseTable t u context
315 -> TheseTable a b
316fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
317 { here =
318 let
319 tag = hdecodeTag $ unHIdentity hhereTag
320 in
321 MaybeTable
322 { tag
323 , just = f $
324 runIdentity $
325 hunnullify (\a -> pure . hunnullifier a) $
326 hunlabel hunlabeler
327 hhere
328 }
329 , there =
330 let
331 tag = hdecodeTag $ unHIdentity hthereTag
332 in
333 MaybeTable
334 { tag
335 , just = g $
336 runIdentity $
337 hunnullify (\a -> pure . hunnullifier a) $
338 hunlabel hunlabeler
339 hthere
340 }
341 }