git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Table/Either.hs
173 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.Label ( Labelable, labeler, unlabeler )
29import Rel8.Schema.Context.Nullify
30 ( Nullifiable, NullifiableEq
31 , encodeTag, decodeTag
32 , nullifier, unnullifier
33 )
34import Rel8.Schema.HTable.Either ( HEitherTable(..) )
35import Rel8.Schema.HTable.Identity ( HIdentity(..) )
36import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
37import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
38import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
39import Rel8.Table.Bool ( bool )
40import Rel8.Table.Lifted
41 ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
42 , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
43 )
44import Rel8.Table.Recontextualize ( Recontextualize )
45import Rel8.Table.Undefined ( undefined )
46import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
48-- semigroupoids
49import Data.Functor.Apply ( Apply, (<.>) )
50import Data.Functor.Bind ( Bind, (>>-) )
53type EitherTable :: Type -> Type -> Type
54data EitherTable a b = EitherTable
55 { tag :: Expr EitherTag
56 , left :: a
57 , right :: b
58 }
59 deriving stock (Show, Functor)
62instance Bifunctor EitherTable where
63 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
66instance Table Expr a => Apply (EitherTable a) where
67 EitherTable tag l1 f <.> EitherTable tag' l2 a =
68 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
71instance Table Expr a => Applicative (EitherTable a) where
72 pure = rightTable
73 (<*>) = (<.>)
76instance Table Expr a => Bind (EitherTable a) where
77 EitherTable tag l1 a >>- f = case f a of
78 EitherTable tag' l2 b ->
79 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
82instance Table Expr a => Monad (EitherTable a) where
83 (>>=) = (>>-)
86instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
87 a <> b = bool a b (isRightTable a)
90instance Table2 EitherTable where
91 type Columns2 EitherTable = HEitherTable
92 type ConstrainContext2 EitherTable = Nullifiable
94 toColumns2 f g EitherTable {tag, left, right} = HEitherTable
95 { htag
96 , hleft = hnullify (nullifier (isLeft tag)) $ f left
97 , hright = hnullify (nullifier (isRight tag)) $ g right
98 }
99 where
100 htag = HIdentity (encodeTag tag)
102 fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
103 EitherTable
104 { tag
105 , left = f $ runIdentity $
106 hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
107 , right = g $ runIdentity $
108 hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
109 }
110 where
111 tag = decodeTag $ unHIdentity htag
113 {-# INLINABLE fromColumns2 #-}
114 {-# INLINABLE toColumns2 #-}
117instance Table context a => Table1 (EitherTable a) where
118 type Columns1 (EitherTable a) = HEitherTable (Columns a)
119 type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
121 toColumns1 = toColumns2 toColumns
122 fromColumns1 = fromColumns2 fromColumns
125instance
126 ( Table context a, Table context b
127 , Labelable context, Nullifiable context
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
147 , Nullifiable to, Labelable to
148 , Recontextualize from to a1 b1
149 , Recontextualize from to a2 b2
150 ) =>
151 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
154isLeftTable :: EitherTable a b -> Expr Bool
155isLeftTable = isLeft . tag
158isRightTable :: EitherTable a b -> Expr Bool
159isRightTable = isRight . tag
162eitherTable :: Table Expr c
163 => (a -> c) -> (b -> c) -> EitherTable a b -> c
164eitherTable f g EitherTable {tag, left, right} =
165 bool (f left) (g right) (isRight tag)
168leftTable :: Table Expr b => a -> EitherTable a b
169leftTable a = EitherTable (litExpr IsLeft) a undefined
172rightTable :: Table Expr a => b -> EitherTable a b
173rightTable = EitherTable (litExpr IsRight) undefined