git.iko.soy/rel8
on ca7aaef help sign in
rel8/src/Rel8/Table/Either.hs
205 lines 6.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 #-}
14module Rel8.Table.Either
15 ( EitherTable(..)
16 , eitherTable, leftTable, rightTable
17 , isLeftTable, isRightTable
18 , aggregateEitherTable, nameEitherTable
19 )
20where
22-- base
23import Data.Bifunctor ( Bifunctor, bimap )
24import Data.Functor.Identity ( runIdentity )
25import Data.Kind ( Type )
26import Prelude hiding ( undefined )
28-- rel8
29import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
30import Rel8.Expr ( Expr )
31import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
32import Rel8.Expr.Serialize ( litExpr )
33import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
34import Rel8.Schema.Context.Nullify
35 ( Nullifiable, ConstrainTag
36 , hencodeTag, hdecodeTag
37 , hnullifier, hunnullifier
38 )
39import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
42import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
43import Rel8.Schema.Name ( Name )
44import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
45import Rel8.Table.Bool ( bool )
46import Rel8.Table.Eq ( EqTable, eqTable )
47import Rel8.Table.Lifted
48 ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
49 )
50import Rel8.Table.Ord ( OrdTable, ordTable )
51import Rel8.Table.Recontextualize ( Recontextualize )
52import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
53import Rel8.Table.Undefined ( undefined )
54import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
56-- semigroupoids
57import Data.Functor.Apply ( Apply, (<.>), liftF3 )
58import Data.Functor.Bind ( Bind, (>>-) )
61type EitherTable :: Type -> Type -> Type
62data EitherTable a b = EitherTable
63 { tag :: Tag "isRight" EitherTag
64 , left :: a
65 , right :: b
66 }
67 deriving stock Functor
70instance Bifunctor EitherTable where
71 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
74instance Table Expr a => Apply (EitherTable a) where
75 EitherTable tag l1 f <.> EitherTable tag' l2 a =
76 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
79instance Table Expr a => Applicative (EitherTable a) where
80 pure = rightTable
81 (<*>) = (<.>)
84instance Table Expr a => Bind (EitherTable a) where
85 EitherTable tag l1 a >>- f = case f a of
86 EitherTable tag' l2 b ->
87 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
90instance Table Expr a => Monad (EitherTable a) where
91 (>>=) = (>>-)
94instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
95 a <> b = bool a b (isRightTable a)
98instance Table2 EitherTable where
99 type Columns2 EitherTable = HEitherTable
100 type ConstrainHContext2 EitherTable = HEitherNullifiable
102 toColumns2 f g EitherTable {tag, left, right} = HEitherTable
103 { htag
104 , hleft = hnullify (hnullifier tag isLeft) $ f left
105 , hright = hnullify (hnullifier tag isRight) $ g right
106 }
107 where
108 htag = HIdentity (hencodeTag tag)
110 fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
111 EitherTable
112 { tag
113 , left = f $ runIdentity $
114 hunnullify (\a -> pure . hunnullifier a) hleft
115 , right = g $ runIdentity $
116 hunnullify (\a -> pure . hunnullifier a) hright
117 }
118 where
119 tag = hdecodeTag $ unHIdentity htag
121 {-# INLINABLE fromColumns2 #-}
122 {-# INLINABLE toColumns2 #-}
125instance
126 ( Table context a, Table context b
127 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
128 ) =>
129 Table context (EitherTable a b)
130 where
131 type Columns (EitherTable a b) =
132 HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
133 type Context (EitherTable a b) = Context a
135 toColumns =
136 toColumns2
137 (hlabel labeler . toColumns)
138 (hlabel labeler . toColumns)
139 fromColumns =
140 fromColumns2
141 (fromColumns . hunlabel unlabeler)
142 (fromColumns . hunlabel unlabeler)
145instance
146 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
147 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
148 , Recontextualize from to a1 b1
149 , Recontextualize from to a2 b2
150 ) =>
151 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
154instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
155 eqTable =
156 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
157 (rightTableWith (eqTable @a) (eqTable @b))
160instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
161 ordTable =
162 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
163 (rightTableWith (ordTable @a) (ordTable @b))
166isLeftTable :: EitherTable a b -> Expr Bool
167isLeftTable = isLeft . expr . tag
170isRightTable :: EitherTable a b -> Expr Bool
171isRightTable = isRight . expr . tag
174eitherTable :: Table Expr c
175 => (a -> c) -> (b -> c) -> EitherTable a b -> c
176eitherTable f g EitherTable {tag, left, right} =
177 bool (f left) (g right) (isRight (expr tag))
180leftTable :: Table Expr b => a -> EitherTable a b
181leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
184rightTable :: Table Expr a => b -> EitherTable a b
185rightTable = rightTableWith undefined
188rightTableWith :: a -> b -> EitherTable a b
189rightTableWith = EitherTable (fromExpr (litExpr IsRight))
192aggregateEitherTable :: ()
193 => (a -> Aggregate c)
194 -> (b -> Aggregate d)
195 -> EitherTable a b
196 -> Aggregate (EitherTable c d)
197aggregateEitherTable f g EitherTable {tag, left, right} =
198 liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
199 where
200 Tag {aggregator, expr} = tag
201 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
204nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
205nameEitherTable = EitherTable . fromName