git.iko.soy/rel8
on 0787c47 help sign in
rel8/src/Rel8/Table/Either.hs
174 lines 4.9 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 StandaloneKindSignatures #-}
9{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
12module Rel8.Table.Either
13 ( EitherTable(..)
14 , eitherTable, leftTable, rightTable
15 , isLeftTable, isRightTable
16 )
17where
19-- base
20import Data.Bifunctor ( Bifunctor, bimap )
21import Data.Functor.Identity ( runIdentity )
22import Data.Kind ( Type )
23import Prelude hiding ( undefined )
25-- rel8
26import Rel8.Expr ( Expr )
27import Rel8.Expr.Serialize ( litExpr )
28import Rel8.Schema.Context ( DB )
29import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30import Rel8.Schema.Context.Nullify
31 ( Nullifiable, NullifiableEq
32 , encodeTag, decodeTag
33 , nullifier, unnullifier
34 )
35import Rel8.Schema.HTable.Either ( HEitherTable(..) )
36import Rel8.Schema.HTable.Identity ( HIdentity(..) )
37import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
38import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
39import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
40import Rel8.Table.Bool ( bool )
41import Rel8.Table.Lifted
42 ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
43 , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
44 )
45import Rel8.Table.Recontextualize ( Recontextualize )
46import Rel8.Table.Undefined ( undefined )
47import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
49-- semigroupoids
50import Data.Functor.Apply ( Apply, (<.>) )
51import Data.Functor.Bind ( Bind, (>>-) )
54type EitherTable :: Type -> Type -> Type
55data EitherTable a b = EitherTable
56 { tag :: Expr EitherTag
57 , left :: a
58 , right :: b
59 }
60 deriving stock (Show, Functor)
63instance Bifunctor EitherTable where
64 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
67instance Table DB a => Apply (EitherTable a) where
68 EitherTable tag l1 f <.> EitherTable tag' l2 a =
69 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
72instance Table DB a => Applicative (EitherTable a) where
73 pure = rightTable
74 (<*>) = (<.>)
77instance Table DB a => Bind (EitherTable a) where
78 EitherTable tag l1 a >>- f = case f a of
79 EitherTable tag' l2 b ->
80 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
83instance Table DB a => Monad (EitherTable a) where
84 (>>=) = (>>-)
87instance (Table DB a, Table DB b) => Semigroup (EitherTable a b) where
88 a <> b = bool a b (isRightTable a)
91instance Table2 EitherTable where
92 type Columns2 EitherTable = HEitherTable
93 type ConstrainContext2 EitherTable = Nullifiable
95 toColumns2 f g EitherTable {tag, left, right} = HEitherTable
96 { htag
97 , hleft = hnullify (nullifier (isLeft tag)) $ f left
98 , hright = hnullify (nullifier (isRight tag)) $ g right
99 }
100 where
101 htag = HIdentity (encodeTag tag)
103 fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
104 EitherTable
105 { tag
106 , left = f $ runIdentity $
107 hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
108 , right = g $ runIdentity $
109 hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
110 }
111 where
112 tag = decodeTag $ unHIdentity htag
114 {-# INLINABLE fromColumns2 #-}
115 {-# INLINABLE toColumns2 #-}
118instance Table context a => Table1 (EitherTable a) where
119 type Columns1 (EitherTable a) = HEitherTable (Columns a)
120 type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
122 toColumns1 = toColumns2 toColumns
123 fromColumns1 = fromColumns2 fromColumns
126instance
127 ( Table context a, Table context b
128 , Labelable context, Nullifiable context
129 ) =>
130 Table context (EitherTable a b)
131 where
132 type Columns (EitherTable a b) =
133 HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
134 type Context (EitherTable a b) = Context a
136 toColumns =
137 toColumns2
138 (hlabel labeler . toColumns)
139 (hlabel labeler . toColumns)
140 fromColumns =
141 fromColumns2
142 (fromColumns . hunlabel unlabeler)
143 (fromColumns . hunlabel unlabeler)
146instance
147 ( Nullifiable from, Labelable from
148 , Nullifiable to, Labelable to
149 , Recontextualize from to a1 b1
150 , Recontextualize from to a2 b2
151 ) =>
152 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
155isLeftTable :: EitherTable a b -> Expr Bool
156isLeftTable = isLeft . tag
159isRightTable :: EitherTable a b -> Expr Bool
160isRightTable = isRight . tag
163eitherTable :: Table DB c
164 => (a -> c) -> (b -> c) -> EitherTable a b -> c
165eitherTable f g EitherTable {tag, left, right} =
166 bool (f left) (g right) (isRight tag)
169leftTable :: Table DB b => a -> EitherTable a b
170leftTable a = EitherTable (litExpr IsLeft) a undefined
173rightTable :: Table DB a => b -> EitherTable a b
174rightTable = EitherTable (litExpr IsRight) undefined