git.iko.soy/rel8
on 707a36a help sign in
rel8/src/Rel8/Table/These.hs
332 lines 9.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 ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TupleSections #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
15{-# options_ghc -fno-warn-orphans #-}
17module Rel8.Table.These
18 ( TheseTable(..)
19 , theseTable, thisTable, thatTable, thoseTable
20 , isThisTable, isThatTable, isThoseTable
21 , hasHereTable, hasThereTable
22 , justHereTable, justThereTable
23 , aggregateTheseTable
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.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.Expr.Bool ( (&&.), not_ )
39import Rel8.Expr.Null ( isNonNull )
40import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
41import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
45import Rel8.Schema.HTable.These ( HTheseTable(..) )
46import qualified Rel8.Schema.Kind as K
47import Rel8.Schema.Name ( Name )
48import Rel8.Table
49 ( Table, Columns, Context, fromColumns, toColumns
50 , reify, unreify
51 )
52import Rel8.Table.Eq ( EqTable, eqTable )
53import Rel8.Table.Maybe
54 ( MaybeTable(..)
55 , maybeTable, justTable, nothingTable
56 , isJustTable
57 , aggregateMaybeTable
58 , nameMaybeTable
59 )
60import Rel8.Table.Ord ( OrdTable, ordTable )
61import Rel8.Table.Recontextualize ( Recontextualize )
62import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
63import Rel8.Table.Undefined ( undefined )
64import Rel8.Type.Tag ( MaybeTag )
66-- semigroupoids
67import Data.Functor.Apply ( Apply, (<.>) )
68import Data.Functor.Bind ( Bind, (>>-) )
70-- these
71import Data.These ( These )
74-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
75-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
76-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
77-- eliminated/pattern matched using 'theseTable'.
78--
79-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
80-- adapted to work with Rel8.
81type TheseTable :: K.Context -> Type -> Type -> Type
82data TheseTable context a b = TheseTable
83 { here :: MaybeTable context a
84 , there :: MaybeTable context b
85 }
86 deriving stock Functor
89instance Bifunctor (TheseTable context) where
90 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
93instance (context ~ Expr, Table Expr a, Semigroup a) =>
94 Apply (TheseTable context a)
95 where
96 fs <.> as = TheseTable
97 { here = here fs <> here as
98 , there = there fs <.> there as
99 }
102instance (context ~ Expr, Table Expr a, Semigroup a) =>
103 Applicative (TheseTable context a)
104 where
105 pure = thatTable
106 (<*>) = (<.>)
109instance (context ~ Expr, Table Expr a, Semigroup a) =>
110 Bind (TheseTable context a)
111 where
112 TheseTable here1 ma >>- f = case ma >>- f' of
113 mtb -> TheseTable
114 { here = maybeTable here1 ((here1 <>) . fst) mtb
115 , there = snd <$> mtb
116 }
117 where
118 f' a = case f a of
119 TheseTable here2 mb -> (here2,) <$> mb
122instance (context ~ Expr, Table Expr a, Semigroup a) =>
123 Monad (TheseTable context a)
124 where
125 (>>=) = (>>-)
128instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
129 Semigroup (TheseTable context 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 , Nullifiable context, context ~ context'
140 )
141 => Table context' (TheseTable context a b)
142 where
143 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
144 type Context (TheseTable context a b) = Context a
146 toColumns TheseTable {here, there} = HTheseTable
147 { hhereTag = hlabel (HIdentity (tag here))
148 , hhere =
149 hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $
150 just here
151 , hthereTag = hlabel (HIdentity (tag there))
152 , hthere =
153 hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $
154 just there
155 }
157 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
158 { here = MaybeTable
159 { tag = unHIdentity $ hunlabel hhereTag
160 , just =
161 fromColumns $
162 runIdentity $
163 hunnullify (\a -> pure . unnullifier a) $
164 hunlabel
165 hhere
166 }
167 , there = MaybeTable
168 { tag = unHIdentity $ hunlabel hthereTag
169 , just =
170 fromColumns $
171 runIdentity $
172 hunnullify (\a -> pure . unnullifier a) $
173 hunlabel
174 hthere
175 }
176 }
178 reify = liftA2 bimap reify reify
179 unreify = liftA2 bimap unreify unreify
182instance
183 ( Nullifiable from, from ~ from'
184 , Nullifiable to, to ~ to'
185 , Recontextualize from to a1 b1
186 , Recontextualize from to a2 b2
187 )
188 => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)
191instance (EqTable a, EqTable b, context ~ Expr) =>
192 EqTable (TheseTable context a b)
193 where
194 eqTable = HTheseTable
195 { hhereTag = hlabel (HType Dict)
196 , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
197 , hthereTag = hlabel (HType Dict)
198 , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
199 }
202instance (OrdTable a, OrdTable b, context ~ Expr) =>
203 OrdTable (TheseTable context a b)
204 where
205 ordTable = HTheseTable
206 { hhereTag = hlabel (HType Dict)
207 , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
208 , hthereTag = hlabel (HType Dict)
209 , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
210 }
213type instance FromExprs (TheseTable _context a b) =
214 These (FromExprs a) (FromExprs b)
217instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
218 ToExprs x (These a b)
219 where
220 fromResult =
221 bimap (fromResult @exprs1) (fromResult @exprs2) .
222 fromColumns
223 toResult =
224 toColumns .
225 bimap (toResult @exprs1) (toResult @exprs2)
228-- | Test if a 'TheseTable' was constructed with 'thisTable'.
229--
230-- Corresponds to 'Data.These.Combinators.isThis'.
231isThisTable :: TheseTable Expr a b -> Expr Bool
232isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
235-- | Test if a 'TheseTable' was constructed with 'thatTable'.
236--
237-- Corresponds to 'Data.These.Combinators.isThat'.
238isThatTable :: TheseTable Expr a b -> Expr Bool
239isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
242-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
243--
244-- Corresponds to 'Data.These.Combinators.isThese'.
245isThoseTable :: TheseTable Expr a b -> Expr Bool
246isThoseTable a = hasHereTable a &&. hasThereTable a
249-- | Test if the @a@ side of @TheseTable a b@ is present.
250--
251-- Corresponds to 'Data.These.Combinators.hasHere'.
252hasHereTable :: TheseTable Expr a b -> Expr Bool
253hasHereTable TheseTable {here} = isJustTable here
256-- | Test if the @b@ table of @TheseTable a b@ is present.
257--
258-- Corresponds to 'Data.These.Combinators.hasThere'.
259hasThereTable :: TheseTable Expr a b -> Expr Bool
260hasThereTable TheseTable {there} = isJustTable there
263-- | Attempt to project out the @a@ table of a @TheseTable a b@.
264--
265-- Corresponds to 'Data.These.Combinators.justHere'.
266justHereTable :: TheseTable context a b -> MaybeTable context a
267justHereTable = here
270-- | Attempt to project out the @b@ table of a @TheseTable a b@.
271--
272-- Corresponds to 'Data.These.Combinators.justThere'.
273justThereTable :: TheseTable context a b -> MaybeTable context b
274justThereTable = there
277-- | Construct a @TheseTable@. Corresponds to 'This'.
278thisTable :: Table Expr b => a -> TheseTable Expr a b
279thisTable a = TheseTable (justTable a) nothingTable
282-- | Construct a @TheseTable@. Corresponds to 'That'.
283thatTable :: Table Expr a => b -> TheseTable Expr a b
284thatTable b = TheseTable nothingTable (justTable b)
287-- | Construct a @TheseTable@. Corresponds to 'These'.
288thoseTable :: a -> b -> TheseTable Expr a b
289thoseTable a b = TheseTable (justTable a) (justTable b)
292-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
293theseTable :: Table Expr c
294 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
295theseTable f g h TheseTable {here, there} =
296 maybeTable
297 (maybeTable undefined f here)
298 (\b -> maybeTable (g b) (`h` b) here)
299 there
302-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
303-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
304aggregateTheseTable :: ()
305 => (exprs -> aggregates)
306 -> (exprs' -> aggregates')
307 -> TheseTable Expr exprs exprs'
308 -> TheseTable Aggregate aggregates aggregates'
309aggregateTheseTable f g (TheseTable here there) = TheseTable
310 { here = aggregateMaybeTable f here
311 , there = aggregateMaybeTable g there
312 }
315-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
316-- have a 'TheseTable' that you are storing in a table and need to construct a
317-- 'TableSchema'.
318nameTheseTable :: ()
319 => Name (Maybe MaybeTag)
320 -- ^ The name of the column to track the presence of the @a@ table.
321 -> Name (Maybe MaybeTag)
322 -- ^ The name of the column to track the presence of the @b@ table.
323 -> a
324 -- ^ Names of the columns in the @a@ table.
325 -> b
326 -- ^ Names of the columns in the @b@ table.
327 -> TheseTable Name a b
328nameTheseTable here there a b =
329 TheseTable
330 { here = nameMaybeTable here a
331 , there = nameMaybeTable there b
332 }