git.iko.soy/rel8
on be54907 help sign in
rel8/src/Rel8/Table/Either.hs
251 lines 8.0 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 TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
14{-# options_ghc -fno-warn-orphans #-}
16module Rel8.Table.Either
17 ( EitherTable(..)
18 , eitherTable, leftTable, rightTable
19 , isLeftTable, isRightTable
20 , aggregateEitherTable
21 , nameEitherTable
22 )
23where
25-- base
26import Control.Category ( id )
27import Data.Bifunctor ( Bifunctor, bimap )
28import Data.Kind ( Type )
29import Data.Type.Equality ( apply )
30import Prelude hiding ( id, undefined )
32-- comonad
33import Control.Comonad ( extract )
35-- rel8
36import Rel8.Aggregate ( Col( A ), Aggregate )
37import Rel8.Expr ( Col( E ), Expr )
38import Rel8.Expr.Aggregate ( groupByExpr )
39import Rel8.Expr.Serialize ( litExpr )
40import Rel8.Kind.Context ( Reifiable )
41import Rel8.Schema.Context.Abstract ( Abstract )
42import Rel8.Schema.Context.Nullify ( Nullifiable )
43import Rel8.Schema.Dict ( Dict( Dict ) )
44import Rel8.Schema.HTable.Either ( HEitherTable(..) )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47import qualified Rel8.Schema.Kind as K
48import Rel8.Schema.Name ( Col( N ), Name )
49import Rel8.Schema.Spec ( Spec( Spec ) )
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , reify, unreify, coherence, congruence
53 )
54import Rel8.Table.Bool ( bool )
55import Rel8.Table.Eq ( EqTable, eqTable )
56import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
57import Rel8.Table.Ord ( OrdTable, ordTable )
58import Rel8.Table.Recontextualize ( Recontextualize )
59import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
60import Rel8.Table.Undefined ( undefined )
61import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
63-- semigroupoids
64import Data.Functor.Apply ( Apply, (<.>) )
65import Data.Functor.Bind ( Bind, (>>-) )
68-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
69-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
70-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
71--
72-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
73-- adapted to work with Rel8.
74type EitherTable :: K.Context -> Type -> Type -> Type
75data EitherTable context a b = EitherTable
76 { tag :: Col context ('Spec EitherTag)
77 , left :: Nullify context a
78 , right :: Nullify context b
79 }
80 deriving stock Functor
83instance Nullifiable context => Bifunctor (EitherTable context) where
84 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
87instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
88 EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
89 EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)
92instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
93 pure = rightTable
94 (<*>) = (<.>)
97instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
98 EitherTable (E tag) l1 a >>- f = case f (extract a) of
99 EitherTable (E tag') l2 b ->
100 EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
103instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
104 (>>=) = (>>-)
107instance (context ~ Expr, Table Expr a, Table Expr b) =>
108 Semigroup (EitherTable context a b)
109 where
110 a <> b = bool a b (isRightTable a)
113instance
114 ( Table context a, Table context b
115 , Reifiable context, Abstract context, context ~ context'
116 )
117 => Table context' (EitherTable context a b)
118 where
119 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
120 type Context (EitherTable context a b) = Context a
122 toColumns EitherTable {tag, left, right} = HEitherTable
123 { htag = hlabel $ HType tag
124 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
125 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
126 }
128 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
129 { tag = unHIdentity $ hunlabel htag
130 , left = fromColumns $ hunlabel hleft
131 , right = fromColumns $ hunlabel hright
132 }
134 reify proof EitherTable {tag, left, right} = EitherTable
135 { tag
136 , left = reify proof left
137 , right = reify proof right
138 }
140 unreify proof EitherTable {tag, left, right} = EitherTable
141 { tag
142 , left = unreify proof left
143 , right = unreify proof right
144 }
146 coherence = coherence @context @a
147 congruence proof abstract =
148 id `apply`
149 congruence @context @a proof abstract `apply`
150 congruence @context @b proof abstract
153instance
154 ( Reifiable from, Abstract from, from ~ from'
155 , Reifiable to, Abstract to, to ~ to'
156 , Recontextualize from to a1 b1
157 , Recontextualize from to a2 b2
158 )
159 => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)
162instance (EqTable a, EqTable b, context ~ Expr) =>
163 EqTable (EitherTable context a b)
164 where
165 eqTable = HEitherTable
166 { htag = hlabel (HType Dict)
167 , hleft = hlabel (eqTable @(Nullify context a))
168 , hright = hlabel (eqTable @(Nullify context b))
169 }
172instance (OrdTable a, OrdTable b, context ~ Expr) =>
173 OrdTable (EitherTable context a b)
174 where
175 ordTable = HEitherTable
176 { htag = hlabel (HType Dict)
177 , hleft = hlabel (ordTable @(Nullify context a))
178 , hright = hlabel (ordTable @(Nullify context b))
179 }
182type instance FromExprs (EitherTable _context a b) =
183 Either (FromExprs a) (FromExprs b)
186instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
187 ToExprs x (Either a b)
188 where
189 fromResult =
190 bimap (fromResult @exprs1) (fromResult @exprs2) .
191 fromColumns
192 toResult =
193 toColumns .
194 bimap (toResult @exprs1) (toResult @exprs2)
197-- | Test if an 'EitherTable' is a 'leftTable'.
198isLeftTable :: EitherTable Expr a b -> Expr Bool
199isLeftTable EitherTable {tag = E tag} = isLeft tag
202-- | Test if an 'EitherTable' is a 'rightTable'.
203isRightTable :: EitherTable Expr a b -> Expr Bool
204isRightTable EitherTable {tag = E tag} = isRight tag
207-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
208-- 'leftTable' and 'rightTable'.
209eitherTable :: Table Expr c
210 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
211eitherTable f g EitherTable {tag = E tag, left, right} =
212 bool (f (extract left)) (g (extract right)) (isRight tag)
215-- | Construct a left 'EitherTable'. Like 'Left'.
216leftTable :: Table Expr b => a -> EitherTable Expr a b
217leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined
220-- | Construct a right 'EitherTable'. Like 'Right'.
221rightTable :: Table Expr a => b -> EitherTable Expr a b
222rightTable = EitherTable (E (litExpr IsRight)) undefined . pure
225-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
226-- @leftTable@s and @rightTable@s are grouped separately.
227aggregateEitherTable :: ()
228 => (exprs -> aggregates)
229 -> (exprs' -> aggregates')
230 -> EitherTable Expr exprs exprs'
231 -> EitherTable Aggregate aggregates aggregates'
232aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable
233 { tag = A (groupByExpr tag)
234 , left = aggregateNullify f a
235 , right = aggregateNullify g b
236 }
239-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
240-- have a 'EitherTable' that you are storing in a table and need to construct a
241-- 'TableSchema'.
242nameEitherTable
243 :: Name EitherTag
244 -- ^ The name of the column to track whether a row is a 'leftTable' or
245 -- 'rightTable'.
246 -> a
247 -- ^ Names of the columns in the @a@ table.
248 -> b
249 -- ^ Names of the columns in the @b@ table.
250 -> EitherTable Name a b
251nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)