git.iko.soy/rel8
on da86165 help sign in
rel8/src/Rel8/Table/Either.hs
225 lines 6.2 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 , nameEitherTable
22 )
23where
25-- base
26import Control.Applicative ( liftA2 )
27import Data.Bifunctor ( Bifunctor, bimap )
28import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
30import Prelude hiding ( undefined )
32-- rel8
33import Rel8.Expr ( Expr )
34import Rel8.Expr.Serialize ( litExpr )
35import Rel8.Schema.Context.Label
36 ( Labelable
37 , HLabelable, hlabeler, hunlabeler
38 )
39import Rel8.Schema.Context.Nullify
40 ( Nullifiable, ConstrainTag
41 , HNullifiable, HConstrainTag
42 , hencodeTag, hdecodeTag
43 , hnullifier, hunnullifier
44 )
45import Rel8.Schema.HTable ( HTable )
46import Rel8.Schema.HTable.Either ( HEitherTable(..) )
47import Rel8.Schema.HTable.Identity ( HIdentity(..) )
48import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
49import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
50import Rel8.Schema.Name ( Name )
51import Rel8.Table
52 ( Table, Columns, Context, fromColumns, toColumns
53 , reify, unreify
54 )
55import Rel8.Table.Bool ( bool )
56import Rel8.Table.Eq ( EqTable, eqTable )
57import Rel8.Table.Ord ( OrdTable, ordTable )
58import Rel8.Table.Recontextualize ( Recontextualize )
59import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
60import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
61import Rel8.Table.Undefined ( undefined )
62import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
64-- semigroupoids
65import Data.Functor.Apply ( Apply, (<.>) )
66import Data.Functor.Bind ( Bind, (>>-) )
69type EitherTable :: Type -> Type -> Type
70data EitherTable a b = EitherTable
71 { tag :: Tag "isRight" EitherTag
72 , left :: a
73 , right :: b
74 }
75 deriving stock Functor
78instance Bifunctor EitherTable where
79 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
82instance Table Expr a => Apply (EitherTable a) where
83 EitherTable tag l1 f <.> EitherTable tag' l2 a =
84 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
87instance Table Expr a => Applicative (EitherTable a) where
88 pure = rightTable
89 (<*>) = (<.>)
92instance Table Expr a => Bind (EitherTable a) where
93 EitherTable tag l1 a >>- f = case f a of
94 EitherTable tag' l2 b ->
95 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
98instance Table Expr a => Monad (EitherTable a) where
99 (>>=) = (>>-)
102instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
103 a <> b = bool a b (isRightTable a)
106instance
107 ( Table context a, Table context b
108 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
109 ) =>
110 Table context (EitherTable a b)
111 where
112 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
113 type Context (EitherTable a b) = Context a
115 toColumns = toColumns2 toColumns toColumns
116 fromColumns = fromColumns2 fromColumns fromColumns
117 reify = liftA2 bimap reify reify
118 unreify = liftA2 bimap unreify unreify
121instance
122 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
123 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
124 , Recontextualize from to a1 b1
125 , Recontextualize from to a2 b2
126 )
127 => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
130instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
131 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
134instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
135 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
138type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
141instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
142 ToExprs x (Either a b)
143 where
144 fromResult =
145 bimap (fromResult @exprs1) (fromResult @exprs2) .
146 fromColumns
147 toResult =
148 toColumns .
149 bimap (toResult @exprs1) (toResult @exprs2)
152isLeftTable :: EitherTable a b -> Expr Bool
153isLeftTable = isLeft . expr . tag
156isRightTable :: EitherTable a b -> Expr Bool
157isRightTable = isRight . expr . tag
160eitherTable :: Table Expr c
161 => (a -> c) -> (b -> c) -> EitherTable a b -> c
162eitherTable f g EitherTable {tag, left, right} =
163 bool (f left) (g right) (isRight (expr tag))
166leftTable :: Table Expr b => a -> EitherTable a b
167leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
170rightTable :: Table Expr a => b -> EitherTable a b
171rightTable = rightTableWith undefined
174rightTableWith :: a -> b -> EitherTable a b
175rightTableWith = EitherTable (fromExpr (litExpr IsRight))
178nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
179nameEitherTable = EitherTable . fromName
182toColumns2 ::
183 ( HTable t
184 , HTable u
185 , HConstrainTag context EitherTag
186 , HLabelable context
187 , HNullifiable context
188 )
189 => (a -> t context)
190 -> (b -> u context)
191 -> EitherTable a b
192 -> HEitherTable t u context
193toColumns2 f g EitherTable {tag, left, right} = HEitherTable
194 { htag
195 , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
196 , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
197 }
198 where
199 htag = HIdentity (hencodeTag tag)
202fromColumns2 ::
203 ( HTable t
204 , HTable u
205 , HConstrainTag context EitherTag
206 , HLabelable context
207 , HNullifiable context
208 )
209 => (t context -> a)
210 -> (u context -> b)
211 -> HEitherTable t u context
212 -> EitherTable a b
213fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
214 { tag
215 , left = f $ runIdentity $
216 hunnullify (\a -> pure . hunnullifier a) $
217 hunlabel hunlabeler
218 hleft
219 , right = g $ runIdentity $
220 hunnullify (\a -> pure . hunnullifier a) $
221 hunlabel hunlabeler
222 hright
223 }
224 where
225 tag = hdecodeTag $ unHIdentity htag