git.iko.soy/rel8
on da76712 help sign in
rel8/src/Rel8/Table/These.hs
357 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 , alignMaybeTable
24 , aggregateTheseTable
25 , nameTheseTable
26 )
27where
29-- base
30import Data.Bifunctor ( Bifunctor, bimap )
31import Data.Kind ( Type )
32import Data.Maybe ( isJust )
33import Prelude hiding ( null, undefined )
35-- rel8
36import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
39import Rel8.Expr.Null ( null, isNonNull )
40import Rel8.Kind.Context ( Reifiable )
41import Rel8.Schema.Context.Nullify ( Nullifiable )
42import Rel8.Schema.Dict ( Dict( Dict ) )
43import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
46import Rel8.Schema.HTable.These ( HTheseTable(..) )
47import qualified Rel8.Schema.Kind as K
48import Rel8.Schema.Name ( Name )
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
51 , FromExprs, fromResult, toResult
52 , Transpose
53 )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Maybe
56 ( MaybeTable(..)
57 , maybeTable, justTable, nothingTable
58 , isJustTable
59 , aggregateMaybeTable
60 , nameMaybeTable
61 )
62import Rel8.Table.Nullify ( Nullify, guard )
63import Rel8.Table.Ord ( OrdTable, ordTable )
64import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65import Rel8.Table.Serialize ( ToExprs )
66import Rel8.Table.Undefined ( undefined )
67import Rel8.Type.Tag ( MaybeTag )
69-- semigroupoids
70import Data.Functor.Apply ( Apply, (<.>) )
71import Data.Functor.Bind ( Bind, (>>-) )
73-- these
74import Data.These ( These( This, That, These ) )
75import Data.These.Combinators ( justHere, justThere )
78-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
79-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
80-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
81-- eliminated/pattern matched using 'theseTable'.
82--
83-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
84-- adapted to work with Rel8.
85type TheseTable :: K.Context -> Type -> Type -> Type
86data TheseTable context a b = TheseTable
87 { here :: MaybeTable context a
88 , there :: MaybeTable context b
89 }
90 deriving stock Functor
93instance Biprojectable (TheseTable context) where
94 biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
97instance Nullifiable context => Bifunctor (TheseTable context) where
98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
101instance Projectable (TheseTable context a) where
102 project f (TheseTable a b) = TheseTable a (project f b)
105instance (context ~ Expr, Table Expr a, Semigroup a) =>
106 Apply (TheseTable context a)
107 where
108 fs <.> as = TheseTable
109 { here = here fs <> here as
110 , there = there fs <.> there as
111 }
114instance (context ~ Expr, Table Expr a, Semigroup a) =>
115 Applicative (TheseTable context a)
116 where
117 pure = thatTable
118 (<*>) = (<.>)
121instance (context ~ Expr, Table Expr a, Semigroup a) =>
122 Bind (TheseTable context a)
123 where
124 TheseTable here1 ma >>- f = case ma >>- f' of
125 mtb -> TheseTable
126 { here = maybeTable here1 ((here1 <>) . fst) mtb
127 , there = snd <$> mtb
128 }
129 where
130 f' a = case f a of
131 TheseTable here2 mb -> (here2,) <$> mb
134instance (context ~ Expr, Table Expr a, Semigroup a) =>
135 Monad (TheseTable context a)
136 where
137 (>>=) = (>>-)
140instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
141 Semigroup (TheseTable context a b)
142 where
143 a <> b = TheseTable
144 { here = here a <> here b
145 , there = there a <> there b
146 }
149instance
150 ( Table context a, Table context b
151 , Reifiable context, context ~ context'
152 )
153 => Table context' (TheseTable context a b)
154 where
155 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
156 type Context (TheseTable context a b) = Context a
157 type FromExprs (TheseTable context a b) =
158 These (FromExprs a) (FromExprs b)
159 type Transpose to (TheseTable context a b) =
160 TheseTable to (Transpose to a) (Transpose to b)
162 toColumns TheseTable {here, there} = HTheseTable
163 { hhereTag = hlabel $ HIdentity $ tag here
164 , hhere =
165 hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
166 , hthereTag = hlabel $ HIdentity $ tag there
167 , hthere =
168 hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
169 }
171 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
172 { here = MaybeTable
173 { tag = unHIdentity $ hunlabel hhereTag
174 , just = fromColumns $ hunlabel hhere
175 }
176 , there = MaybeTable
177 { tag = unHIdentity $ hunlabel hthereTag
178 , just = fromColumns $ hunlabel hthere
179 }
180 }
182 toResult tables = HTheseTable
183 { hhereTag = hrelabel hhereTag
184 , hhere = hrelabel hhere
185 , hthereTag = hrelabel hthereTag
186 , hthere = hrelabel hthere
187 }
188 where
189 HMaybeTable
190 { htag = hhereTag
191 , hjust = hhere
192 } = toResult @_ @(MaybeTable context a) (justHere tables)
193 HMaybeTable
194 { htag = hthereTag
195 , hjust = hthere
196 } = toResult @_ @(MaybeTable context b) (justThere tables)
198 fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
199 case (here, there) of
200 (Just a, Nothing) -> This a
201 (Nothing, Just b) -> That b
202 (Just a, Just b) -> These a b
203 _ -> error "These.fromColumns: mismatch between tags and data"
204 where
205 here = fromResult @_ @(MaybeTable context a) mhere
206 there = fromResult @_ @(MaybeTable context b) mthere
207 mhere = HMaybeTable
208 { htag = hrelabel hhereTag
209 , hjust = hrelabel hhere
210 }
211 mthere = HMaybeTable
212 { htag = hrelabel hthereTag
213 , hjust = hrelabel hthere
214 }
217instance (EqTable a, EqTable b, context ~ Expr) =>
218 EqTable (TheseTable context a b)
219 where
220 eqTable = HTheseTable
221 { hhereTag = hlabel (HIdentity Dict)
222 , hhere = hlabel (eqTable @(Nullify context a))
223 , hthereTag = hlabel (HIdentity Dict)
224 , hthere = hlabel (eqTable @(Nullify context b))
225 }
228instance (OrdTable a, OrdTable b, context ~ Expr) =>
229 OrdTable (TheseTable context a b)
230 where
231 ordTable = HTheseTable
232 { hhereTag = hlabel (HIdentity Dict)
233 , hhere = hlabel (ordTable @(Nullify context a))
234 , hthereTag = hlabel (HIdentity Dict)
235 , hthere = hlabel (ordTable @(Nullify context b))
236 }
239instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
240 ToExprs x (These a b)
243-- | Test if a 'TheseTable' was constructed with 'thisTable'.
244--
245-- Corresponds to 'Data.These.Combinators.isThis'.
246isThisTable :: TheseTable Expr a b -> Expr Bool
247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
250-- | Test if a 'TheseTable' was constructed with 'thatTable'.
251--
252-- Corresponds to 'Data.These.Combinators.isThat'.
253isThatTable :: TheseTable Expr a b -> Expr Bool
254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
257-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
258--
259-- Corresponds to 'Data.These.Combinators.isThese'.
260isThoseTable :: TheseTable Expr a b -> Expr Bool
261isThoseTable a = hasHereTable a &&. hasThereTable a
264-- | Test if the @a@ side of @TheseTable a b@ is present.
265--
266-- Corresponds to 'Data.These.Combinators.hasHere'.
267hasHereTable :: TheseTable Expr a b -> Expr Bool
268hasHereTable TheseTable {here} = isJustTable here
271-- | Test if the @b@ table of @TheseTable a b@ is present.
272--
273-- Corresponds to 'Data.These.Combinators.hasThere'.
274hasThereTable :: TheseTable Expr a b -> Expr Bool
275hasThereTable TheseTable {there} = isJustTable there
278-- | Attempt to project out the @a@ table of a @TheseTable a b@.
279--
280-- Corresponds to 'Data.These.Combinators.justHere'.
281justHereTable :: TheseTable context a b -> MaybeTable context a
282justHereTable = here
285-- | Attempt to project out the @b@ table of a @TheseTable a b@.
286--
287-- Corresponds to 'Data.These.Combinators.justThere'.
288justThereTable :: TheseTable context a b -> MaybeTable context b
289justThereTable = there
292-- | Construct a @TheseTable@ from two 'MaybeTable's.
293alignMaybeTable :: ()
294 => MaybeTable Expr a
295 -> MaybeTable Expr b
296 -> MaybeTable Expr (TheseTable Expr a b)
297alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
298 where
299 tag = boolExpr null mempty (isJustTable a ||. isJustTable b)
302-- | Construct a @TheseTable@. Corresponds to 'This'.
303thisTable :: Table Expr b => a -> TheseTable Expr a b
304thisTable a = TheseTable (justTable a) nothingTable
307-- | Construct a @TheseTable@. Corresponds to 'That'.
308thatTable :: Table Expr a => b -> TheseTable Expr a b
309thatTable b = TheseTable nothingTable (justTable b)
312-- | Construct a @TheseTable@. Corresponds to 'These'.
313thoseTable :: a -> b -> TheseTable Expr a b
314thoseTable a b = TheseTable (justTable a) (justTable b)
317-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
318theseTable :: Table Expr c
319 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
320theseTable f g h TheseTable {here, there} =
321 maybeTable
322 (maybeTable undefined f here)
323 (\b -> maybeTable (g b) (`h` b) here)
324 there
327-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
328-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
329aggregateTheseTable :: ()
330 => (exprs -> aggregates)
331 -> (exprs' -> aggregates')
332 -> TheseTable Expr exprs exprs'
333 -> TheseTable Aggregate aggregates aggregates'
334aggregateTheseTable f g (TheseTable here there) = TheseTable
335 { here = aggregateMaybeTable f here
336 , there = aggregateMaybeTable g there
337 }
340-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
341-- have a 'TheseTable' that you are storing in a table and need to construct a
342-- 'TableSchema'.
343nameTheseTable :: ()
344 => Name (Maybe MaybeTag)
345 -- ^ The name of the column to track the presence of the @a@ table.
346 -> Name (Maybe MaybeTag)
347 -- ^ The name of the column to track the presence of the @b@ table.
348 -> a
349 -- ^ Names of the columns in the @a@ table.
350 -> b
351 -- ^ Names of the columns in the @b@ table.
352 -> TheseTable Name a b
353nameTheseTable here there a b =
354 TheseTable
355 { here = nameMaybeTable here a
356 , there = nameMaybeTable there b
357 }