git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Table/Either.hs
233 lines 7.7 kB history raw
1{-# language DataKinds #-}
2{-# language DeriveFunctor #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language LambdaCase #-}
7{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
15{-# options_ghc -fno-warn-orphans #-}
17module Rel8.Table.Either
18 ( EitherTable(..)
19 , eitherTable, leftTable, rightTable
20 , isLeftTable, isRightTable
21 , aggregateEitherTable
22 , nameEitherTable
23 )
24where
26-- base
27import Data.Bifunctor ( Bifunctor, bimap )
28import Data.Functor.Identity ( Identity( Identity ) )
29import Data.Kind ( Type )
30import Prelude hiding ( undefined )
32-- comonad
33import Control.Comonad ( extract )
35-- rel8
36import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.Expr.Aggregate ( groupByExpr )
39import Rel8.Expr.Serialize ( litExpr )
40import Rel8.Kind.Context ( Reifiable )
41import Rel8.Schema.Context.Nullify ( Nullifiable )
42import Rel8.Schema.Dict ( Dict( Dict ) )
43import Rel8.Schema.HTable.Either ( HEitherTable(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
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.Bool ( bool )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
56import Rel8.Table.Ord ( OrdTable, ordTable )
57import Rel8.Table.Serialize ( ToExprs )
58import Rel8.Table.Undefined ( undefined )
59import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
61-- semigroupoids
62import Data.Functor.Apply ( Apply, (<.>) )
63import Data.Functor.Bind ( Bind, (>>-) )
66-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
67-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
68-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
69--
70-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
71-- adapted to work with Rel8.
72type EitherTable :: K.Context -> Type -> Type -> Type
73data EitherTable context a b = EitherTable
74 { tag :: context EitherTag
75 , left :: Nullify context a
76 , right :: Nullify context b
77 }
78 deriving stock Functor
81instance Nullifiable context => Bifunctor (EitherTable context) where
82 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
85instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
86 EitherTable tag l1 f <.> EitherTable tag' l2 a =
87 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
90instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
91 pure = rightTable
92 (<*>) = (<.>)
95instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
96 EitherTable tag l1 a >>- f = case f (extract a) of
97 EitherTable tag' l2 b ->
98 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
101instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
102 (>>=) = (>>-)
105instance (context ~ Expr, Table Expr a, Table Expr b) =>
106 Semigroup (EitherTable context a b)
107 where
108 a <> b = bool a b (isRightTable a)
111instance
112 ( Table context a, Table context b
113 , Reifiable context, context ~ context'
114 )
115 => Table context' (EitherTable context a b)
116 where
117 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
118 type Context (EitherTable context a b) = Context a
119 type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
120 type Transpose to (EitherTable context a b) =
121 EitherTable to (Transpose to a) (Transpose to b)
123 toColumns EitherTable {tag, left, right} = HEitherTable
124 { htag = hlabel $ HIdentity tag
125 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
126 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
127 }
129 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
130 { tag = unHIdentity $ hunlabel htag
131 , left = fromColumns $ hunlabel hleft
132 , right = fromColumns $ hunlabel hright
133 }
135 toResult = \case
136 Left table -> HEitherTable
137 { htag = hlabel (HIdentity (Identity IsLeft))
138 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
139 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
140 }
141 Right table -> HEitherTable
142 { htag = hlabel (HIdentity (Identity IsRight))
143 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
144 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
145 }
147 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
148 HIdentity (Identity tag) -> case tag of
149 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
150 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
151 where
152 err = error "Either.fromColumns: mismatch between tag and data"
155instance (EqTable a, EqTable b, context ~ Expr) =>
156 EqTable (EitherTable context a b)
157 where
158 eqTable = HEitherTable
159 { htag = hlabel (HIdentity Dict)
160 , hleft = hlabel (eqTable @(Nullify context a))
161 , hright = hlabel (eqTable @(Nullify context b))
162 }
165instance (OrdTable a, OrdTable b, context ~ Expr) =>
166 OrdTable (EitherTable context a b)
167 where
168 ordTable = HEitherTable
169 { htag = hlabel (HIdentity Dict)
170 , hleft = hlabel (ordTable @(Nullify context a))
171 , hright = hlabel (ordTable @(Nullify context b))
172 }
175instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
176 ToExprs x (Either a b)
179-- | Test if an 'EitherTable' is a 'leftTable'.
180isLeftTable :: EitherTable Expr a b -> Expr Bool
181isLeftTable EitherTable {tag} = isLeft tag
184-- | Test if an 'EitherTable' is a 'rightTable'.
185isRightTable :: EitherTable Expr a b -> Expr Bool
186isRightTable EitherTable {tag} = isRight tag
189-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
190-- 'leftTable' and 'rightTable'.
191eitherTable :: Table Expr c
192 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
193eitherTable f g EitherTable {tag, left, right} =
194 bool (f (extract left)) (g (extract right)) (isRight tag)
197-- | Construct a left 'EitherTable'. Like 'Left'.
198leftTable :: Table Expr b => a -> EitherTable Expr a b
199leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
202-- | Construct a right 'EitherTable'. Like 'Right'.
203rightTable :: Table Expr a => b -> EitherTable Expr a b
204rightTable = EitherTable (litExpr IsRight) undefined . pure
207-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
208-- @leftTable@s and @rightTable@s are grouped separately.
209aggregateEitherTable :: ()
210 => (exprs -> aggregates)
211 -> (exprs' -> aggregates')
212 -> EitherTable Expr exprs exprs'
213 -> EitherTable Aggregate aggregates aggregates'
214aggregateEitherTable f g (EitherTable tag a b) = EitherTable
215 { tag = groupByExpr tag
216 , left = aggregateNullify f a
217 , right = aggregateNullify g b
218 }
221-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
222-- have a 'EitherTable' that you are storing in a table and need to construct a
223-- 'TableSchema'.
224nameEitherTable
225 :: Name EitherTag
226 -- ^ The name of the column to track whether a row is a 'leftTable' or
227 -- 'rightTable'.
228 -> a
229 -- ^ Names of the columns in the @a@ table.
230 -> b
231 -- ^ Names of the columns in the @b@ table.
232 -> EitherTable Name a b
233nameEitherTable tag left right = EitherTable tag (pure left) (pure right)