git.iko.soy/rel8
on 5d2b9e4 help sign in
rel8/src/Rel8/Table/These.hs
346 lines 11 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 , Transpose
52 )
53import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Maybe
55 ( MaybeTable(..)
56 , maybeTable, justTable, nothingTable
57 , isJustTable
58 , aggregateMaybeTable
59 , nameMaybeTable
60 )
61import Rel8.Table.Nullify ( Nullify, guard )
62import Rel8.Table.Ord ( OrdTable, ordTable )
63import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
64import Rel8.Table.Serialize ( ToExprs )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type.Tag ( MaybeTag )
68-- semigroupoids
69import Data.Functor.Apply ( Apply, (<.>) )
70import Data.Functor.Bind ( Bind, (>>-) )
72-- these
73import Data.These ( These( This, That, These ) )
74import Data.These.Combinators ( justHere, justThere )
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 :: K.Context -> Type -> Type -> Type
85data TheseTable context a b = TheseTable
86 { here :: MaybeTable context a
87 , there :: MaybeTable context b
88 }
89 deriving stock Functor
92instance Biprojectable (TheseTable context) where
93 biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
96instance Nullifiable context => Bifunctor (TheseTable context) where
97 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
100instance Projectable (TheseTable context a) where
101 project f (TheseTable a b) = TheseTable a (project f b)
104instance (context ~ Expr, Table Expr a, Semigroup a) =>
105 Apply (TheseTable context a)
106 where
107 fs <.> as = TheseTable
108 { here = here fs <> here as
109 , there = there fs <.> there as
110 }
113instance (context ~ Expr, Table Expr a, Semigroup a) =>
114 Applicative (TheseTable context a)
115 where
116 pure = thatTable
117 (<*>) = (<.>)
120instance (context ~ Expr, Table Expr a, Semigroup a) =>
121 Bind (TheseTable context a)
122 where
123 TheseTable here1 ma >>- f = case ma >>- f' of
124 mtb -> TheseTable
125 { here = maybeTable here1 ((here1 <>) . fst) mtb
126 , there = snd <$> mtb
127 }
128 where
129 f' a = case f a of
130 TheseTable here2 mb -> (here2,) <$> mb
133instance (context ~ Expr, Table Expr a, Semigroup a) =>
134 Monad (TheseTable context a)
135 where
136 (>>=) = (>>-)
139instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
140 Semigroup (TheseTable context a b)
141 where
142 a <> b = TheseTable
143 { here = here a <> here b
144 , there = there a <> there b
145 }
148instance
149 ( Table context a, Table context b
150 , Reifiable context, context ~ context'
151 )
152 => Table context' (TheseTable context a b)
153 where
154 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
155 type Context (TheseTable context a b) = Context a
156 type FromExprs (TheseTable context a b) =
157 These (FromExprs a) (FromExprs b)
158 type Transpose to (TheseTable context a b) =
159 TheseTable to (Transpose to a) (Transpose to b)
161 toColumns TheseTable {here, there} = HTheseTable
162 { hhereTag = hlabel $ HIdentity $ tag here
163 , hhere =
164 hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
165 , hthereTag = hlabel $ HIdentity $ tag there
166 , hthere =
167 hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
168 }
170 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
171 { here = MaybeTable
172 { tag = unHIdentity $ hunlabel hhereTag
173 , just = fromColumns $ hunlabel hhere
174 }
175 , there = MaybeTable
176 { tag = unHIdentity $ hunlabel hthereTag
177 , just = fromColumns $ hunlabel hthere
178 }
179 }
181 toResult tables = HTheseTable
182 { hhereTag = hrelabel hhereTag
183 , hhere = hrelabel hhere
184 , hthereTag = hrelabel hthereTag
185 , hthere = hrelabel hthere
186 }
187 where
188 HMaybeTable
189 { htag = hhereTag
190 , hjust = hhere
191 } = toResult @_ @(MaybeTable context a) (justHere tables)
192 HMaybeTable
193 { htag = hthereTag
194 , hjust = hthere
195 } = toResult @_ @(MaybeTable context b) (justThere tables)
197 fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
198 case (here, there) of
199 (Just a, Nothing) -> This a
200 (Nothing, Just b) -> That b
201 (Just a, Just b) -> These a b
202 _ -> error "These.fromColumns: mismatch between tags and data"
203 where
204 here = fromResult @_ @(MaybeTable context a) mhere
205 there = fromResult @_ @(MaybeTable context b) mthere
206 mhere = HMaybeTable
207 { htag = hrelabel hhereTag
208 , hjust = hrelabel hhere
209 }
210 mthere = HMaybeTable
211 { htag = hrelabel hthereTag
212 , hjust = hrelabel hthere
213 }
216instance (EqTable a, EqTable b, context ~ Expr) =>
217 EqTable (TheseTable context a b)
218 where
219 eqTable = HTheseTable
220 { hhereTag = hlabel (HIdentity Dict)
221 , hhere = hlabel (eqTable @(Nullify context a))
222 , hthereTag = hlabel (HIdentity Dict)
223 , hthere = hlabel (eqTable @(Nullify context b))
224 }
227instance (OrdTable a, OrdTable b, context ~ Expr) =>
228 OrdTable (TheseTable context a b)
229 where
230 ordTable = HTheseTable
231 { hhereTag = hlabel (HIdentity Dict)
232 , hhere = hlabel (ordTable @(Nullify context a))
233 , hthereTag = hlabel (HIdentity Dict)
234 , hthere = hlabel (ordTable @(Nullify context b))
235 }
238instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
239 ToExprs x (These a b)
242-- | Test if a 'TheseTable' was constructed with 'thisTable'.
243--
244-- Corresponds to 'Data.These.Combinators.isThis'.
245isThisTable :: TheseTable Expr a b -> Expr Bool
246isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
249-- | Test if a 'TheseTable' was constructed with 'thatTable'.
250--
251-- Corresponds to 'Data.These.Combinators.isThat'.
252isThatTable :: TheseTable Expr a b -> Expr Bool
253isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
256-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
257--
258-- Corresponds to 'Data.These.Combinators.isThese'.
259isThoseTable :: TheseTable Expr a b -> Expr Bool
260isThoseTable a = hasHereTable a &&. hasThereTable a
263-- | Test if the @a@ side of @TheseTable a b@ is present.
264--
265-- Corresponds to 'Data.These.Combinators.hasHere'.
266hasHereTable :: TheseTable Expr a b -> Expr Bool
267hasHereTable TheseTable {here} = isJustTable here
270-- | Test if the @b@ table of @TheseTable a b@ is present.
271--
272-- Corresponds to 'Data.These.Combinators.hasThere'.
273hasThereTable :: TheseTable Expr a b -> Expr Bool
274hasThereTable TheseTable {there} = isJustTable there
277-- | Attempt to project out the @a@ table of a @TheseTable a b@.
278--
279-- Corresponds to 'Data.These.Combinators.justHere'.
280justHereTable :: TheseTable context a b -> MaybeTable context a
281justHereTable = here
284-- | Attempt to project out the @b@ table of a @TheseTable a b@.
285--
286-- Corresponds to 'Data.These.Combinators.justThere'.
287justThereTable :: TheseTable context a b -> MaybeTable context b
288justThereTable = there
291-- | Construct a @TheseTable@. Corresponds to 'This'.
292thisTable :: Table Expr b => a -> TheseTable Expr a b
293thisTable a = TheseTable (justTable a) nothingTable
296-- | Construct a @TheseTable@. Corresponds to 'That'.
297thatTable :: Table Expr a => b -> TheseTable Expr a b
298thatTable b = TheseTable nothingTable (justTable b)
301-- | Construct a @TheseTable@. Corresponds to 'These'.
302thoseTable :: a -> b -> TheseTable Expr a b
303thoseTable a b = TheseTable (justTable a) (justTable b)
306-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
307theseTable :: Table Expr c
308 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
309theseTable f g h TheseTable {here, there} =
310 maybeTable
311 (maybeTable undefined f here)
312 (\b -> maybeTable (g b) (`h` b) here)
313 there
316-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
317-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
318aggregateTheseTable :: ()
319 => (exprs -> aggregates)
320 -> (exprs' -> aggregates')
321 -> TheseTable Expr exprs exprs'
322 -> TheseTable Aggregate aggregates aggregates'
323aggregateTheseTable f g (TheseTable here there) = TheseTable
324 { here = aggregateMaybeTable f here
325 , there = aggregateMaybeTable g there
326 }
329-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
330-- have a 'TheseTable' that you are storing in a table and need to construct a
331-- 'TableSchema'.
332nameTheseTable :: ()
333 => Name (Maybe MaybeTag)
334 -- ^ The name of the column to track the presence of the @a@ table.
335 -> Name (Maybe MaybeTag)
336 -- ^ The name of the column to track the presence of the @b@ table.
337 -> a
338 -- ^ Names of the columns in the @a@ table.
339 -> b
340 -- ^ Names of the columns in the @b@ table.
341 -> TheseTable Name a b
342nameTheseTable here there a b =
343 TheseTable
344 { here = nameMaybeTable here a
345 , there = nameMaybeTable there b
346 }