git.iko.soy/rel8
on 97d89cf help sign in
rel8/src/Rel8/Table/Either.hs
241 lines 8.0 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.Kind ( Type )
29import Prelude hiding ( undefined )
31-- comonad
32import Control.Comonad ( extract )
34-- rel8
35import Rel8.Aggregate ( Aggregate( A ) )
36import Rel8.Expr ( Expr( E ) )
37import Rel8.Expr.Aggregate ( groupByExpr )
38import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Kind.Context ( Reifiable )
40import Rel8.Schema.Context.Nullify ( Nullifiable )
41import Rel8.Schema.Dict ( Dict( Dict ) )
42import Rel8.Schema.HTable.Either ( HEitherTable(..) )
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import qualified Rel8.Schema.Kind as K
46import Rel8.Schema.Name ( Name( N ) )
47import Rel8.Schema.Result ( Result( R ) )
48import Rel8.Schema.Spec ( Spec( Spec ) )
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
51 , FromExprs, fromResult, toResult
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.Recontextualize ( Recontextualize )
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 ('Spec EitherTag)
76 , left :: Nullify context a
77 , right :: Nullify context b
78 }
79 deriving stock Functor
82instance Nullifiable context => Bifunctor (EitherTable context) where
83 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
86instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
87 EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
88 EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)
91instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
92 pure = rightTable
93 (<*>) = (<.>)
96instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
97 EitherTable (E tag) l1 a >>- f = case f (extract a) of
98 EitherTable (E tag') l2 b ->
99 EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
102instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
103 (>>=) = (>>-)
106instance (context ~ Expr, Table Expr a, Table Expr b) =>
107 Semigroup (EitherTable context a b)
108 where
109 a <> b = bool a b (isRightTable a)
112instance
113 ( Table context a, Table context b
114 , Reifiable context, context ~ context'
115 )
116 => Table context' (EitherTable context a b)
117 where
118 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
119 type Context (EitherTable context a b) = Context a
120 type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
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 toResult = \case
135 Left table -> HEitherTable
136 { htag = hlabel (HType (R IsLeft))
137 , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
138 , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
139 }
140 Right table -> HEitherTable
141 { htag = hlabel (HType (R IsRight))
142 , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
143 , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
144 }
146 fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
147 HType (R tag) -> case tag of
148 IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
149 IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
150 where
151 err = error "Either.fromColumns: mismatch between tag and data"
154instance
155 ( Reifiable from, from ~ from'
156 , Reifiable to, to ~ to'
157 , Recontextualize from to a1 b1
158 , Recontextualize from to a2 b2
159 )
160 => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)
163instance (EqTable a, EqTable b, context ~ Expr) =>
164 EqTable (EitherTable context a b)
165 where
166 eqTable = HEitherTable
167 { htag = hlabel (HType Dict)
168 , hleft = hlabel (eqTable @(Nullify context a))
169 , hright = hlabel (eqTable @(Nullify context b))
170 }
173instance (OrdTable a, OrdTable b, context ~ Expr) =>
174 OrdTable (EitherTable context a b)
175 where
176 ordTable = HEitherTable
177 { htag = hlabel (HType Dict)
178 , hleft = hlabel (ordTable @(Nullify context a))
179 , hright = hlabel (ordTable @(Nullify context b))
180 }
183instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
184 ToExprs x (Either a b)
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 (extract left)) (g (extract 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)) (pure a) undefined
210-- | Construct a right 'EitherTable'. Like 'Right'.
211rightTable :: Table Expr a => b -> EitherTable Expr a b
212rightTable = EitherTable (E (litExpr IsRight)) undefined . pure
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) = EitherTable
223 { tag = A (groupByExpr tag)
224 , left = aggregateNullify f a
225 , right = aggregateNullify g b
226 }
229-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
230-- have a 'EitherTable' that you are storing in a table and need to construct a
231-- 'TableSchema'.
232nameEitherTable
233 :: Name EitherTag
234 -- ^ The name of the column to track whether a row is a 'leftTable' or
235 -- 'rightTable'.
236 -> a
237 -- ^ Names of the columns in the @a@ table.
238 -> b
239 -- ^ Names of the columns in the @b@ table.
240 -> EitherTable Name a b
241nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)