git.iko.soy/rel8
on be54907 help sign in
rel8/src/Rel8/Table/These.hs
335 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 Control.Category ( id )
30import Data.Bifunctor ( Bifunctor, bimap )
31import Data.Kind ( Type )
32import Data.Maybe ( isJust )
33import Data.Type.Equality ( apply )
34import Prelude hiding ( id, undefined )
36-- rel8
37import Rel8.Aggregate ( Aggregate )
38import Rel8.Expr ( Expr )
39import Rel8.Expr.Bool ( (&&.), not_ )
40import Rel8.Expr.Null ( isNonNull )
41import Rel8.Kind.Context ( Reifiable )
42import Rel8.Schema.Context.Abstract ( Abstract )
43import Rel8.Schema.Context.Nullify ( Nullifiable )
44import Rel8.Schema.Dict ( Dict( Dict ) )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46import Rel8.Schema.HTable.Identity ( HIdentity(..) )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
48import qualified Rel8.Schema.Kind as K
49import Rel8.Schema.Name ( Name )
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , coherence, congruence, reify, unreify
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.Recontextualize ( Recontextualize )
65import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
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 )
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 Nullifiable context => Bifunctor (TheseTable context) where
93 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
96instance (context ~ Expr, Table Expr a, Semigroup a) =>
97 Apply (TheseTable context a)
98 where
99 fs <.> as = TheseTable
100 { here = here fs <> here as
101 , there = there fs <.> there as
102 }
105instance (context ~ Expr, Table Expr a, Semigroup a) =>
106 Applicative (TheseTable context a)
107 where
108 pure = thatTable
109 (<*>) = (<.>)
112instance (context ~ Expr, Table Expr a, Semigroup a) =>
113 Bind (TheseTable context a)
114 where
115 TheseTable here1 ma >>- f = case ma >>- f' of
116 mtb -> TheseTable
117 { here = maybeTable here1 ((here1 <>) . fst) mtb
118 , there = snd <$> mtb
119 }
120 where
121 f' a = case f a of
122 TheseTable here2 mb -> (here2,) <$> mb
125instance (context ~ Expr, Table Expr a, Semigroup a) =>
126 Monad (TheseTable context a)
127 where
128 (>>=) = (>>-)
131instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
132 Semigroup (TheseTable context a b)
133 where
134 a <> b = TheseTable
135 { here = here a <> here b
136 , there = there a <> there b
137 }
140instance
141 ( Table context a, Table context b
142 , Reifiable context, Abstract context, context ~ context'
143 )
144 => Table context' (TheseTable context a b)
145 where
146 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
147 type Context (TheseTable context a b) = Context a
149 toColumns TheseTable {here, there} = HTheseTable
150 { hhereTag = hlabel $ HIdentity $ tag here
151 , hhere =
152 hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
153 , hthereTag = hlabel $ HIdentity $ tag there
154 , hthere =
155 hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
156 }
158 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
159 { here = MaybeTable
160 { tag = unHIdentity $ hunlabel hhereTag
161 , just = fromColumns $ hunlabel hhere
162 }
163 , there = MaybeTable
164 { tag = unHIdentity $ hunlabel hthereTag
165 , just = fromColumns $ hunlabel hthere
166 }
167 }
169 reify proof TheseTable {here, there} = TheseTable
170 { here = reify proof here
171 , there = reify proof there
172 }
173 unreify proof TheseTable {here, there} = TheseTable
174 { here = unreify proof here
175 , there = unreify proof there
176 }
178 coherence = coherence @context @a
179 congruence proof abstract =
180 id `apply`
181 congruence @context @a proof abstract `apply`
182 congruence @context @b proof abstract
185instance
186 ( Reifiable from, Abstract from, from ~ from'
187 , Reifiable to, Abstract to, to ~ to'
188 , Recontextualize from to a1 b1
189 , Recontextualize from to a2 b2
190 )
191 => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)
194instance (EqTable a, EqTable b, context ~ Expr) =>
195 EqTable (TheseTable context a b)
196 where
197 eqTable = HTheseTable
198 { hhereTag = hlabel (HType Dict)
199 , hhere = hlabel (eqTable @(Nullify context a))
200 , hthereTag = hlabel (HType Dict)
201 , hthere = hlabel (eqTable @(Nullify context b))
202 }
205instance (OrdTable a, OrdTable b, context ~ Expr) =>
206 OrdTable (TheseTable context a b)
207 where
208 ordTable = HTheseTable
209 { hhereTag = hlabel (HType Dict)
210 , hhere = hlabel (ordTable @(Nullify context a))
211 , hthereTag = hlabel (HType Dict)
212 , hthere = hlabel (ordTable @(Nullify context b))
213 }
216type instance FromExprs (TheseTable _context a b) =
217 These (FromExprs a) (FromExprs b)
220instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
221 ToExprs x (These a b)
222 where
223 fromResult =
224 bimap (fromResult @exprs1) (fromResult @exprs2) .
225 fromColumns
226 toResult =
227 toColumns .
228 bimap (toResult @exprs1) (toResult @exprs2)
231-- | Test if a 'TheseTable' was constructed with 'thisTable'.
232--
233-- Corresponds to 'Data.These.Combinators.isThis'.
234isThisTable :: TheseTable Expr a b -> Expr Bool
235isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
238-- | Test if a 'TheseTable' was constructed with 'thatTable'.
239--
240-- Corresponds to 'Data.These.Combinators.isThat'.
241isThatTable :: TheseTable Expr a b -> Expr Bool
242isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
245-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
246--
247-- Corresponds to 'Data.These.Combinators.isThese'.
248isThoseTable :: TheseTable Expr a b -> Expr Bool
249isThoseTable a = hasHereTable a &&. hasThereTable a
252-- | Test if the @a@ side of @TheseTable a b@ is present.
253--
254-- Corresponds to 'Data.These.Combinators.hasHere'.
255hasHereTable :: TheseTable Expr a b -> Expr Bool
256hasHereTable TheseTable {here} = isJustTable here
259-- | Test if the @b@ table of @TheseTable a b@ is present.
260--
261-- Corresponds to 'Data.These.Combinators.hasThere'.
262hasThereTable :: TheseTable Expr a b -> Expr Bool
263hasThereTable TheseTable {there} = isJustTable there
266-- | Attempt to project out the @a@ table of a @TheseTable a b@.
267--
268-- Corresponds to 'Data.These.Combinators.justHere'.
269justHereTable :: TheseTable context a b -> MaybeTable context a
270justHereTable = here
273-- | Attempt to project out the @b@ table of a @TheseTable a b@.
274--
275-- Corresponds to 'Data.These.Combinators.justThere'.
276justThereTable :: TheseTable context a b -> MaybeTable context b
277justThereTable = there
280-- | Construct a @TheseTable@. Corresponds to 'This'.
281thisTable :: Table Expr b => a -> TheseTable Expr a b
282thisTable a = TheseTable (justTable a) nothingTable
285-- | Construct a @TheseTable@. Corresponds to 'That'.
286thatTable :: Table Expr a => b -> TheseTable Expr a b
287thatTable b = TheseTable nothingTable (justTable b)
290-- | Construct a @TheseTable@. Corresponds to 'These'.
291thoseTable :: a -> b -> TheseTable Expr a b
292thoseTable a b = TheseTable (justTable a) (justTable b)
295-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
296theseTable :: Table Expr c
297 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
298theseTable f g h TheseTable {here, there} =
299 maybeTable
300 (maybeTable undefined f here)
301 (\b -> maybeTable (g b) (`h` b) here)
302 there
305-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
306-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
307aggregateTheseTable :: ()
308 => (exprs -> aggregates)
309 -> (exprs' -> aggregates')
310 -> TheseTable Expr exprs exprs'
311 -> TheseTable Aggregate aggregates aggregates'
312aggregateTheseTable f g (TheseTable here there) = TheseTable
313 { here = aggregateMaybeTable f here
314 , there = aggregateMaybeTable g there
315 }
318-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
319-- have a 'TheseTable' that you are storing in a table and need to construct a
320-- 'TableSchema'.
321nameTheseTable :: ()
322 => Name (Maybe MaybeTag)
323 -- ^ The name of the column to track the presence of the @a@ table.
324 -> Name (Maybe MaybeTag)
325 -- ^ The name of the column to track the presence of the @b@ table.
326 -> a
327 -- ^ Names of the columns in the @a@ table.
328 -> b
329 -- ^ Names of the columns in the @b@ table.
330 -> TheseTable Name a b
331nameTheseTable here there a b =
332 TheseTable
333 { here = nameMaybeTable here a
334 , there = nameMaybeTable there b
335 }