git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Table/These.hs
344 lines 10 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 Data.Bifunctor ( Bifunctor, bimap )
30import Data.Kind ( Type )
31import Data.Maybe ( isJust )
32import Prelude hiding ( undefined )
34-- rel8
35import Rel8.Aggregate ( Aggregate )
36import Rel8.Expr ( Expr )
37import Rel8.Expr.Bool ( (&&.), not_ )
38import Rel8.Expr.Null ( isNonNull )
39import Rel8.Kind.Context ( Reifiable )
40import Rel8.Schema.Context.Nullify ( Nullifiable )
41import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
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 , FromExprs, fromResult, toResult
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.Nullify ( Nullify, guard )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Serialize ( ToExprs )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Type.Tag ( MaybeTag )
67-- semigroupoids
68import Data.Functor.Apply ( Apply, (<.>) )
69import Data.Functor.Bind ( Bind, (>>-) )
71-- these
72import Data.These ( These( This, That, These ) )
73import Data.These.Combinators ( justHere, justThere )
76-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
77-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
78-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
79-- eliminated/pattern matched using 'theseTable'.
80--
81-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
82-- adapted to work with Rel8.
83type TheseTable :: K.Context -> Type -> Type -> Type
84data TheseTable context a b = TheseTable
85 { here :: MaybeTable context a
86 , there :: MaybeTable context b
87 }
88 deriving stock Functor
91instance Nullifiable context => Bifunctor (TheseTable context) where
92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
95instance (context ~ Expr, Table Expr a, Semigroup a) =>
96 Apply (TheseTable context a)
97 where
98 fs <.> as = TheseTable
99 { here = here fs <> here as
100 , there = there fs <.> there as
101 }
104instance (context ~ Expr, Table Expr a, Semigroup a) =>
105 Applicative (TheseTable context a)
106 where
107 pure = thatTable
108 (<*>) = (<.>)
111instance (context ~ Expr, Table Expr a, Semigroup a) =>
112 Bind (TheseTable context a)
113 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 (context ~ Expr, Table Expr a, Semigroup a) =>
125 Monad (TheseTable context a)
126 where
127 (>>=) = (>>-)
130instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
131 Semigroup (TheseTable context a b)
132 where
133 a <> b = TheseTable
134 { here = here a <> here b
135 , there = there a <> there b
136 }
139instance
140 ( Table context a, Table context b
141 , Reifiable context, context ~ context'
142 )
143 => Table context' (TheseTable context a b)
144 where
145 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
146 type Context (TheseTable context a b) = Context a
147 type FromExprs (TheseTable context a b) =
148 These (FromExprs a) (FromExprs b)
150 toColumns TheseTable {here, there} = HTheseTable
151 { hhereTag = hlabel $ HIdentity $ tag here
152 , hhere =
153 hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
154 , hthereTag = hlabel $ HIdentity $ tag there
155 , hthere =
156 hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
157 }
159 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
160 { here = MaybeTable
161 { tag = unHIdentity $ hunlabel hhereTag
162 , just = fromColumns $ hunlabel hhere
163 }
164 , there = MaybeTable
165 { tag = unHIdentity $ hunlabel hthereTag
166 , just = fromColumns $ hunlabel hthere
167 }
168 }
170 toResult tables = HTheseTable
171 { hhereTag = hrelabel hhereTag
172 , hhere = hrelabel hhere
173 , hthereTag = hrelabel hthereTag
174 , hthere = hrelabel hthere
175 }
176 where
177 HMaybeTable
178 { htag = hhereTag
179 , hjust = hhere
180 } = toResult @_ @(MaybeTable context a) (justHere tables)
181 HMaybeTable
182 { htag = hthereTag
183 , hjust = hthere
184 } = toResult @_ @(MaybeTable context b) (justThere tables)
186 fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
187 case (here, there) of
188 (Just a, Nothing) -> This a
189 (Nothing, Just b) -> That b
190 (Just a, Just b) -> These a b
191 _ -> error "These.fromColumns: mismatch between tags and data"
192 where
193 here = fromResult @_ @(MaybeTable context a) mhere
194 there = fromResult @_ @(MaybeTable context b) mthere
195 mhere = HMaybeTable
196 { htag = hrelabel hhereTag
197 , hjust = hrelabel hhere
198 }
199 mthere = HMaybeTable
200 { htag = hrelabel hthereTag
201 , hjust = hrelabel hthere
202 }
205instance
206 ( Recontextualize from to a1 b1
207 , Recontextualize from to a2 b2
208 , Reifiable from, from ~ from'
209 , Reifiable to, to ~ to'
210 )
211 => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)
214instance (EqTable a, EqTable b, context ~ Expr) =>
215 EqTable (TheseTable context a b)
216 where
217 eqTable = HTheseTable
218 { hhereTag = hlabel (HType Dict)
219 , hhere = hlabel (eqTable @(Nullify context a))
220 , hthereTag = hlabel (HType Dict)
221 , hthere = hlabel (eqTable @(Nullify context b))
222 }
225instance (OrdTable a, OrdTable b, context ~ Expr) =>
226 OrdTable (TheseTable context a b)
227 where
228 ordTable = HTheseTable
229 { hhereTag = hlabel (HType Dict)
230 , hhere = hlabel (ordTable @(Nullify context a))
231 , hthereTag = hlabel (HType Dict)
232 , hthere = hlabel (ordTable @(Nullify context b))
233 }
236instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
237 ToExprs x (These a b)
240-- | Test if a 'TheseTable' was constructed with 'thisTable'.
241--
242-- Corresponds to 'Data.These.Combinators.isThis'.
243isThisTable :: TheseTable Expr a b -> Expr Bool
244isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
247-- | Test if a 'TheseTable' was constructed with 'thatTable'.
248--
249-- Corresponds to 'Data.These.Combinators.isThat'.
250isThatTable :: TheseTable Expr a b -> Expr Bool
251isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
254-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
255--
256-- Corresponds to 'Data.These.Combinators.isThese'.
257isThoseTable :: TheseTable Expr a b -> Expr Bool
258isThoseTable a = hasHereTable a &&. hasThereTable a
261-- | Test if the @a@ side of @TheseTable a b@ is present.
262--
263-- Corresponds to 'Data.These.Combinators.hasHere'.
264hasHereTable :: TheseTable Expr a b -> Expr Bool
265hasHereTable TheseTable {here} = isJustTable here
268-- | Test if the @b@ table of @TheseTable a b@ is present.
269--
270-- Corresponds to 'Data.These.Combinators.hasThere'.
271hasThereTable :: TheseTable Expr a b -> Expr Bool
272hasThereTable TheseTable {there} = isJustTable there
275-- | Attempt to project out the @a@ table of a @TheseTable a b@.
276--
277-- Corresponds to 'Data.These.Combinators.justHere'.
278justHereTable :: TheseTable context a b -> MaybeTable context a
279justHereTable = here
282-- | Attempt to project out the @b@ table of a @TheseTable a b@.
283--
284-- Corresponds to 'Data.These.Combinators.justThere'.
285justThereTable :: TheseTable context a b -> MaybeTable context b
286justThereTable = there
289-- | Construct a @TheseTable@. Corresponds to 'This'.
290thisTable :: Table Expr b => a -> TheseTable Expr a b
291thisTable a = TheseTable (justTable a) nothingTable
294-- | Construct a @TheseTable@. Corresponds to 'That'.
295thatTable :: Table Expr a => b -> TheseTable Expr a b
296thatTable b = TheseTable nothingTable (justTable b)
299-- | Construct a @TheseTable@. Corresponds to 'These'.
300thoseTable :: a -> b -> TheseTable Expr a b
301thoseTable a b = TheseTable (justTable a) (justTable b)
304-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
305theseTable :: Table Expr c
306 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
307theseTable f g h TheseTable {here, there} =
308 maybeTable
309 (maybeTable undefined f here)
310 (\b -> maybeTable (g b) (`h` b) here)
311 there
314-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
315-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
316aggregateTheseTable :: ()
317 => (exprs -> aggregates)
318 -> (exprs' -> aggregates')
319 -> TheseTable Expr exprs exprs'
320 -> TheseTable Aggregate aggregates aggregates'
321aggregateTheseTable f g (TheseTable here there) = TheseTable
322 { here = aggregateMaybeTable f here
323 , there = aggregateMaybeTable g there
324 }
327-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
328-- have a 'TheseTable' that you are storing in a table and need to construct a
329-- 'TableSchema'.
330nameTheseTable :: ()
331 => Name (Maybe MaybeTag)
332 -- ^ The name of the column to track the presence of the @a@ table.
333 -> Name (Maybe MaybeTag)
334 -- ^ The name of the column to track the presence of the @b@ table.
335 -> a
336 -- ^ Names of the columns in the @a@ table.
337 -> b
338 -- ^ Names of the columns in the @b@ table.
339 -> TheseTable Name a b
340nameTheseTable here there a b =
341 TheseTable
342 { here = nameMaybeTable here a
343 , there = nameMaybeTable there b
344 }