git.iko.soy/rel8
on 707a36a help sign in
rel8/src/Rel8/Table/Either.hs
238 lines 7.4 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.Applicative ( liftA2 )
27import Data.Bifunctor ( Bifunctor, bimap )
28import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
30import Prelude hiding ( undefined )
32-- rel8
33import Rel8.Aggregate ( Col( A ), Aggregate )
34import Rel8.Expr ( Col( E ), Expr )
35import Rel8.Expr.Aggregate ( groupByExpr )
36import Rel8.Expr.Serialize ( litExpr )
37import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
38import Rel8.Schema.Dict ( Dict( Dict ) )
39import Rel8.Schema.HTable.Either ( HEitherTable(..) )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
42import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
43import qualified Rel8.Schema.Kind as K
44import Rel8.Schema.Name ( Col( N ), Name )
45import Rel8.Schema.Spec ( Spec( Spec ) )
46import Rel8.Table
47 ( Table, Columns, Context, fromColumns, toColumns
48 , reify, unreify
49 )
50import Rel8.Table.Bool ( bool )
51import Rel8.Table.Eq ( EqTable, eqTable )
52import Rel8.Table.Ord ( OrdTable, ordTable )
53import Rel8.Table.Recontextualize ( Recontextualize )
54import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
55import Rel8.Table.Undefined ( undefined )
56import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
58-- semigroupoids
59import Data.Functor.Apply ( Apply, (<.>) )
60import Data.Functor.Bind ( Bind, (>>-) )
63-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
64-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
65-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
66--
67-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
68-- adapted to work with Rel8.
69type EitherTable :: K.Context -> Type -> Type -> Type
70data EitherTable context a b = EitherTable
71 { tag :: Col context ('Spec EitherTag)
72 , left :: a
73 , right :: b
74 }
75 deriving stock Functor
78instance Bifunctor (EitherTable context) where
79 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
82instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
83 EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
84 EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f a)
87instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
88 pure = rightTable
89 (<*>) = (<.>)
92instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
93 EitherTable (E tag) l1 a >>- f = case f a of
94 EitherTable (E tag') l2 b ->
95 EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
98instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
99 (>>=) = (>>-)
102instance (context ~ Expr, Table Expr a, Table Expr b) =>
103 Semigroup (EitherTable context a b)
104 where
105 a <> b = bool a b (isRightTable a)
108instance
109 ( Table context a, Table context b
110 , Nullifiable context, context ~ context'
111 )
112 => Table context' (EitherTable context a b)
113 where
114 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
115 type Context (EitherTable context a b) = Context a
117 toColumns EitherTable {tag, left, right} = HEitherTable
118 { htag = hlabel (HType tag)
119 , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left
120 , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right
121 }
123 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
124 { tag = unHIdentity (hunlabel htag)
125 , left =
126 fromColumns $
127 runIdentity $
128 hunnullify (\spec -> pure . unnullifier spec) $
129 hunlabel
130 hleft
131 , right =
132 fromColumns $
133 runIdentity $
134 hunnullify (\spec -> pure . unnullifier spec) $
135 hunlabel
136 hright
137 }
139 reify = liftA2 bimap reify reify
140 unreify = liftA2 bimap unreify unreify
143instance
144 ( Nullifiable from, from ~ from'
145 , Nullifiable to, to ~ to'
146 , Recontextualize from to a1 b1
147 , Recontextualize from to a2 b2
148 )
149 => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)
152instance (EqTable a, EqTable b, context ~ Expr) =>
153 EqTable (EitherTable context a b)
154 where
155 eqTable = HEitherTable
156 { htag = hlabel (HType Dict)
157 , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
158 , hright = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
159 }
162instance (OrdTable a, OrdTable b, context ~ Expr) =>
163 OrdTable (EitherTable context a b)
164 where
165 ordTable = HEitherTable
166 { htag = hlabel (HType Dict)
167 , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
168 , hright = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
169 }
172type instance FromExprs (EitherTable _context a b) =
173 Either (FromExprs a) (FromExprs b)
176instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
177 ToExprs x (Either a b)
178 where
179 fromResult =
180 bimap (fromResult @exprs1) (fromResult @exprs2) .
181 fromColumns
182 toResult =
183 toColumns .
184 bimap (toResult @exprs1) (toResult @exprs2)
187-- | Test if an 'EitherTable' is a 'leftTable'.
188isLeftTable :: EitherTable Expr a b -> Expr Bool
189isLeftTable EitherTable {tag = E tag} = isLeft tag
192-- | Test if an 'EitherTable' is a 'rightTable'.
193isRightTable :: EitherTable Expr a b -> Expr Bool
194isRightTable EitherTable {tag = E tag} = isRight tag
197-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
198-- 'leftTable' and 'rightTable'.
199eitherTable :: Table Expr c
200 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
201eitherTable f g EitherTable {tag = E tag, left, right} =
202 bool (f left) (g right) (isRight tag)
205-- | Construct a left 'EitherTable'. Like 'Left'.
206leftTable :: Table Expr b => a -> EitherTable Expr a b
207leftTable a = EitherTable (E (litExpr IsLeft)) a undefined
210-- | Construct a right 'EitherTable'. Like 'Right'.
211rightTable :: Table Expr a => b -> EitherTable Expr a b
212rightTable = EitherTable (E (litExpr IsRight)) undefined
215-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
216-- @leftTable@s and @rightTable@s are grouped separately.
217aggregateEitherTable :: ()
218 => (exprs -> aggregates)
219 -> (exprs' -> aggregates')
220 -> EitherTable Expr exprs exprs'
221 -> EitherTable Aggregate aggregates aggregates'
222aggregateEitherTable f g (EitherTable (E tag) a b) =
223 EitherTable (A (groupByExpr tag)) (f a) (g b)
226-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
227-- have a 'EitherTable' that you are storing in a table and need to construct a
228-- 'TableSchema'.
229nameEitherTable
230 :: Name EitherTag
231 -- ^ The name of the column to track whether a row is a 'leftTable' or
232 -- 'rightTable'.
233 -> a
234 -- ^ Names of the columns in the @a@ table.
235 -> b
236 -- ^ Names of the columns in the @b@ table.
237 -> EitherTable Name a b
238nameEitherTable = EitherTable . N