git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Table/These.hs
337 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 , 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.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)
149 type Transpose to (TheseTable context a b) =
150 TheseTable to (Transpose to a) (Transpose to b)
152 toColumns TheseTable {here, there} = HTheseTable
153 { hhereTag = hlabel $ HIdentity $ tag here
154 , hhere =
155 hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
156 , hthereTag = hlabel $ HIdentity $ tag there
157 , hthere =
158 hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
159 }
161 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
162 { here = MaybeTable
163 { tag = unHIdentity $ hunlabel hhereTag
164 , just = fromColumns $ hunlabel hhere
165 }
166 , there = MaybeTable
167 { tag = unHIdentity $ hunlabel hthereTag
168 , just = fromColumns $ hunlabel hthere
169 }
170 }
172 toResult tables = HTheseTable
173 { hhereTag = hrelabel hhereTag
174 , hhere = hrelabel hhere
175 , hthereTag = hrelabel hthereTag
176 , hthere = hrelabel hthere
177 }
178 where
179 HMaybeTable
180 { htag = hhereTag
181 , hjust = hhere
182 } = toResult @_ @(MaybeTable context a) (justHere tables)
183 HMaybeTable
184 { htag = hthereTag
185 , hjust = hthere
186 } = toResult @_ @(MaybeTable context b) (justThere tables)
188 fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
189 case (here, there) of
190 (Just a, Nothing) -> This a
191 (Nothing, Just b) -> That b
192 (Just a, Just b) -> These a b
193 _ -> error "These.fromColumns: mismatch between tags and data"
194 where
195 here = fromResult @_ @(MaybeTable context a) mhere
196 there = fromResult @_ @(MaybeTable context b) mthere
197 mhere = HMaybeTable
198 { htag = hrelabel hhereTag
199 , hjust = hrelabel hhere
200 }
201 mthere = HMaybeTable
202 { htag = hrelabel hthereTag
203 , hjust = hrelabel hthere
204 }
207instance (EqTable a, EqTable b, context ~ Expr) =>
208 EqTable (TheseTable context a b)
209 where
210 eqTable = HTheseTable
211 { hhereTag = hlabel (HIdentity Dict)
212 , hhere = hlabel (eqTable @(Nullify context a))
213 , hthereTag = hlabel (HIdentity Dict)
214 , hthere = hlabel (eqTable @(Nullify context b))
215 }
218instance (OrdTable a, OrdTable b, context ~ Expr) =>
219 OrdTable (TheseTable context a b)
220 where
221 ordTable = HTheseTable
222 { hhereTag = hlabel (HIdentity Dict)
223 , hhere = hlabel (ordTable @(Nullify context a))
224 , hthereTag = hlabel (HIdentity Dict)
225 , hthere = hlabel (ordTable @(Nullify context b))
226 }
229instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
230 ToExprs x (These a b)
233-- | Test if a 'TheseTable' was constructed with 'thisTable'.
234--
235-- Corresponds to 'Data.These.Combinators.isThis'.
236isThisTable :: TheseTable Expr a b -> Expr Bool
237isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
240-- | Test if a 'TheseTable' was constructed with 'thatTable'.
241--
242-- Corresponds to 'Data.These.Combinators.isThat'.
243isThatTable :: TheseTable Expr a b -> Expr Bool
244isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
247-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
248--
249-- Corresponds to 'Data.These.Combinators.isThese'.
250isThoseTable :: TheseTable Expr a b -> Expr Bool
251isThoseTable a = hasHereTable a &&. hasThereTable a
254-- | Test if the @a@ side of @TheseTable a b@ is present.
255--
256-- Corresponds to 'Data.These.Combinators.hasHere'.
257hasHereTable :: TheseTable Expr a b -> Expr Bool
258hasHereTable TheseTable {here} = isJustTable here
261-- | Test if the @b@ table of @TheseTable a b@ is present.
262--
263-- Corresponds to 'Data.These.Combinators.hasThere'.
264hasThereTable :: TheseTable Expr a b -> Expr Bool
265hasThereTable TheseTable {there} = isJustTable there
268-- | Attempt to project out the @a@ table of a @TheseTable a b@.
269--
270-- Corresponds to 'Data.These.Combinators.justHere'.
271justHereTable :: TheseTable context a b -> MaybeTable context a
272justHereTable = here
275-- | Attempt to project out the @b@ table of a @TheseTable a b@.
276--
277-- Corresponds to 'Data.These.Combinators.justThere'.
278justThereTable :: TheseTable context a b -> MaybeTable context b
279justThereTable = there
282-- | Construct a @TheseTable@. Corresponds to 'This'.
283thisTable :: Table Expr b => a -> TheseTable Expr a b
284thisTable a = TheseTable (justTable a) nothingTable
287-- | Construct a @TheseTable@. Corresponds to 'That'.
288thatTable :: Table Expr a => b -> TheseTable Expr a b
289thatTable b = TheseTable nothingTable (justTable b)
292-- | Construct a @TheseTable@. Corresponds to 'These'.
293thoseTable :: a -> b -> TheseTable Expr a b
294thoseTable a b = TheseTable (justTable a) (justTable b)
297-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
298theseTable :: Table Expr c
299 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
300theseTable f g h TheseTable {here, there} =
301 maybeTable
302 (maybeTable undefined f here)
303 (\b -> maybeTable (g b) (`h` b) here)
304 there
307-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
308-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
309aggregateTheseTable :: ()
310 => (exprs -> aggregates)
311 -> (exprs' -> aggregates')
312 -> TheseTable Expr exprs exprs'
313 -> TheseTable Aggregate aggregates aggregates'
314aggregateTheseTable f g (TheseTable here there) = TheseTable
315 { here = aggregateMaybeTable f here
316 , there = aggregateMaybeTable g there
317 }
320-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
321-- have a 'TheseTable' that you are storing in a table and need to construct a
322-- 'TableSchema'.
323nameTheseTable :: ()
324 => Name (Maybe MaybeTag)
325 -- ^ The name of the column to track the presence of the @a@ table.
326 -> Name (Maybe MaybeTag)
327 -- ^ The name of the column to track the presence of the @b@ table.
328 -> a
329 -- ^ Names of the columns in the @a@ table.
330 -> b
331 -- ^ Names of the columns in the @b@ table.
332 -> TheseTable Name a b
333nameTheseTable here there a b =
334 TheseTable
335 { here = nameMaybeTable here a
336 , there = nameMaybeTable there b
337 }