git.iko.soy/rel8
on 8de0eec help sign in
rel8/src/Rel8/Table/Either.hs
243 lines 8.1 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.Projection ( Biprojectable, Projectable, biproject, project )
58import Rel8.Table.Serialize ( ToExprs )
59import Rel8.Table.Undefined ( undefined )
60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
62-- semigroupoids
63import Data.Functor.Apply ( Apply, (<.>) )
64import Data.Functor.Bind ( Bind, (>>-) )
67-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
68-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
69-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
70--
71-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
72-- adapted to work with Rel8.
73type EitherTable :: K.Context -> Type -> Type -> Type
74data EitherTable context a b = EitherTable
75 { tag :: context EitherTag
76 , left :: Nullify context a
77 , right :: Nullify context b
78 }
79 deriving stock Functor
82instance Biprojectable (EitherTable context) where
83 biproject f g (EitherTable tag a b) =
84 EitherTable tag (project f a) (project g b)
87instance Nullifiable context => Bifunctor (EitherTable context) where
88 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
91instance Projectable (EitherTable context a) where
92 project f (EitherTable tag a b) = EitherTable tag a (project f b)
95instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
96 EitherTable tag l1 f <.> EitherTable tag' l2 a =
97 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
100instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
101 pure = rightTable
102 (<*>) = (<.>)
105instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
106 EitherTable tag l1 a >>- f = case f (extract a) of
107 EitherTable tag' l2 b ->
108 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
111instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
112 (>>=) = (>>-)
115instance (context ~ Expr, Table Expr a, Table Expr b) =>
116 Semigroup (EitherTable context a b)
117 where
118 a <> b = bool a b (isRightTable a)
121instance
122 ( Table context a, Table context b
123 , Reifiable context, context ~ context'
124 )
125 => Table context' (EitherTable context a b)
126 where
127 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
128 type Context (EitherTable context a b) = Context a
129 type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
130 type Transpose to (EitherTable context a b) =
131 EitherTable to (Transpose to a) (Transpose to b)
133 toColumns EitherTable {tag, left, right} = HEitherTable
134 { htag = hlabel $ HIdentity tag
135 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
136 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
137 }
139 fromColumns HEitherTable {htag, hleft, hright} = EitherTable
140 { tag = unHIdentity $ hunlabel htag
141 , left = fromColumns $ hunlabel hleft
142 , right = fromColumns $ hunlabel hright
143 }
145 toResult = \case
146 Left table -> HEitherTable
147 { htag = hlabel (HIdentity (Identity IsLeft))
148 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
149 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
150 }
151 Right table -> HEitherTable
152 { htag = hlabel (HIdentity (Identity IsRight))
153 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
154 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
155 }
157 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
158 HIdentity (Identity tag) -> case tag of
159 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
160 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
161 where
162 err = error "Either.fromColumns: mismatch between tag and data"
165instance (EqTable a, EqTable b, context ~ Expr) =>
166 EqTable (EitherTable context a b)
167 where
168 eqTable = HEitherTable
169 { htag = hlabel (HIdentity Dict)
170 , hleft = hlabel (eqTable @(Nullify context a))
171 , hright = hlabel (eqTable @(Nullify context b))
172 }
175instance (OrdTable a, OrdTable b, context ~ Expr) =>
176 OrdTable (EitherTable context a b)
177 where
178 ordTable = HEitherTable
179 { htag = hlabel (HIdentity Dict)
180 , hleft = hlabel (ordTable @(Nullify context a))
181 , hright = hlabel (ordTable @(Nullify context b))
182 }
185instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
186 ToExprs x (Either a b)
189-- | Test if an 'EitherTable' is a 'leftTable'.
190isLeftTable :: EitherTable Expr a b -> Expr Bool
191isLeftTable EitherTable {tag} = isLeft tag
194-- | Test if an 'EitherTable' is a 'rightTable'.
195isRightTable :: EitherTable Expr a b -> Expr Bool
196isRightTable EitherTable {tag} = isRight tag
199-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200-- 'leftTable' and 'rightTable'.
201eitherTable :: Table Expr c
202 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
203eitherTable f g EitherTable {tag, left, right} =
204 bool (f (extract left)) (g (extract right)) (isRight tag)
207-- | Construct a left 'EitherTable'. Like 'Left'.
208leftTable :: Table Expr b => a -> EitherTable Expr a b
209leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
212-- | Construct a right 'EitherTable'. Like 'Right'.
213rightTable :: Table Expr a => b -> EitherTable Expr a b
214rightTable = EitherTable (litExpr IsRight) undefined . pure
217-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
218-- @leftTable@s and @rightTable@s are grouped separately.
219aggregateEitherTable :: ()
220 => (exprs -> aggregates)
221 -> (exprs' -> aggregates')
222 -> EitherTable Expr exprs exprs'
223 -> EitherTable Aggregate aggregates aggregates'
224aggregateEitherTable f g (EitherTable tag a b) = EitherTable
225 { tag = groupByExpr tag
226 , left = aggregateNullify f a
227 , right = aggregateNullify g b
228 }
231-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
232-- have a 'EitherTable' that you are storing in a table and need to construct a
233-- 'TableSchema'.
234nameEitherTable
235 :: Name EitherTag
236 -- ^ The name of the column to track whether a row is a 'leftTable' or
237 -- 'rightTable'.
238 -> a
239 -- ^ Names of the columns in the @a@ table.
240 -> b
241 -- ^ Names of the columns in the @b@ table.
242 -> EitherTable Name a b
243nameEitherTable tag left right = EitherTable tag (pure left) (pure right)