git.iko.soy/rel8
on 20ddd83 help sign in
rel8/src/Rel8/Table/Either.hs
184 lines 5.3 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 )
19where
21-- base
22import Data.Bifunctor ( Bifunctor, bimap )
23import Data.Functor.Identity ( runIdentity )
24import Data.Kind ( Type )
25import Prelude hiding ( undefined )
27-- rel8
28import Rel8.Expr ( Expr )
29import Rel8.Expr.Serialize ( litExpr )
30import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
31import Rel8.Schema.Context.Nullify
32 ( Nullifiable, ConstrainTag
33 , hencodeTag, hdecodeTag
34 , hnullifier, hunnullifier
35 )
36import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
37import Rel8.Schema.HTable.Identity ( HIdentity(..) )
38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
39import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
40import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
41import Rel8.Table.Bool ( bool )
42import Rel8.Table.Eq ( EqTable, eqTable )
43import Rel8.Table.Lifted
44 ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
45 )
46import Rel8.Table.Ord ( OrdTable, ordTable )
47import Rel8.Table.Recontextualize ( Recontextualize )
48import Rel8.Table.Undefined ( undefined )
49import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
51-- semigroupoids
52import Data.Functor.Apply ( Apply, (<.>) )
53import Data.Functor.Bind ( Bind, (>>-) )
56type EitherTable :: Type -> Type -> Type
57data EitherTable a b = EitherTable
58 { tag :: Expr EitherTag
59 , left :: a
60 , right :: b
61 }
62 deriving stock (Show, Functor)
65instance Bifunctor EitherTable where
66 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
69instance Table Expr a => Apply (EitherTable a) where
70 EitherTable tag l1 f <.> EitherTable tag' l2 a =
71 EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
74instance Table Expr a => Applicative (EitherTable a) where
75 pure = rightTable
76 (<*>) = (<.>)
79instance Table Expr a => Bind (EitherTable a) where
80 EitherTable tag l1 a >>- f = case f a of
81 EitherTable tag' l2 b ->
82 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
85instance Table Expr a => Monad (EitherTable a) where
86 (>>=) = (>>-)
89instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
90 a <> b = bool a b (isRightTable a)
93instance Table2 EitherTable where
94 type Columns2 EitherTable = HEitherTable
95 type ConstrainHContext2 EitherTable = HEitherNullifiable
97 toColumns2 f g EitherTable {tag, left, right} = HEitherTable
98 { htag
99 , hleft = hnullify (hnullifier (isLeft tag)) $ f left
100 , hright = hnullify (hnullifier (isRight tag)) $ g right
101 }
102 where
103 htag = HIdentity (hencodeTag tag)
105 fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
106 EitherTable
107 { tag
108 , left = f $ runIdentity $
109 hunnullify (\a -> pure . hunnullifier (isLeft tag) a) hleft
110 , right = g $ runIdentity $
111 hunnullify (\a -> pure . hunnullifier (isRight tag) a) hright
112 }
113 where
114 tag = hdecodeTag $ unHIdentity htag
116 {-# INLINABLE fromColumns2 #-}
117 {-# INLINABLE toColumns2 #-}
120instance
121 ( Table context a, Table context b
122 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
123 ) =>
124 Table context (EitherTable a b)
125 where
126 type Columns (EitherTable a b) =
127 HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
128 type Context (EitherTable a b) = Context a
130 toColumns =
131 toColumns2
132 (hlabel labeler . toColumns)
133 (hlabel labeler . toColumns)
134 fromColumns =
135 fromColumns2
136 (fromColumns . hunlabel unlabeler)
137 (fromColumns . hunlabel unlabeler)
140instance
141 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
142 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
143 , Recontextualize from to a1 b1
144 , Recontextualize from to a2 b2
145 ) =>
146 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
149instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
150 eqTable =
151 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
152 (rightTableWith (eqTable @a) (eqTable @b))
155instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
156 ordTable =
157 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
158 (rightTableWith (ordTable @a) (ordTable @b))
161isLeftTable :: EitherTable a b -> Expr Bool
162isLeftTable = isLeft . tag
165isRightTable :: EitherTable a b -> Expr Bool
166isRightTable = isRight . tag
169eitherTable :: Table Expr c
170 => (a -> c) -> (b -> c) -> EitherTable a b -> c
171eitherTable f g EitherTable {tag, left, right} =
172 bool (f left) (g right) (isRight tag)
175leftTable :: Table Expr b => a -> EitherTable a b
176leftTable a = EitherTable (litExpr IsLeft) a undefined
179rightTable :: Table Expr a => b -> EitherTable a b
180rightTable = rightTableWith undefined
183rightTableWith :: a -> b -> EitherTable a b
184rightTableWith = EitherTable (litExpr IsRight)