git.iko.soy/rel8
on b2e2fc9 help sign in
rel8/src/Rel8/Table/Either.hs
221 lines 6.2 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 Control.Applicative ( liftA2 )
24import Data.Bifunctor ( Bifunctor, bimap )
25import Data.Functor.Identity ( runIdentity )
26import Data.Kind ( Type )
27import Prelude hiding ( undefined )
29-- rel8
30import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
31import Rel8.Expr ( Expr )
32import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
33import Rel8.Expr.Serialize ( litExpr )
34import Rel8.Schema.Context.Label
35 ( Labelable
36 , HLabelable, hlabeler, hunlabeler
37 )
38import Rel8.Schema.Context.Nullify
39 ( Nullifiable, ConstrainTag
40 , HNullifiable, HConstrainTag
41 , hencodeTag, hdecodeTag
42 , hnullifier, hunnullifier
43 )
44import Rel8.Schema.HTable ( HTable )
45import Rel8.Schema.HTable.Either ( HEitherTable(..) )
46import Rel8.Schema.HTable.Identity ( HIdentity(..) )
47import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
48import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
49import Rel8.Schema.Name ( Name )
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , reify, unreify
53 )
54import Rel8.Table.Bool ( bool )
55import Rel8.Table.Eq ( EqTable, eqTable )
56import Rel8.Table.Ord ( OrdTable, ordTable )
57import Rel8.Table.Recontextualize ( Recontextualize )
58import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
59import Rel8.Table.Undefined ( undefined )
60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
62-- semigroupoids
63import Data.Functor.Apply ( Apply, (<.>), liftF3 )
64import Data.Functor.Bind ( Bind, (>>-) )
67type EitherTable :: Type -> Type -> Type
68data EitherTable a b = EitherTable
69 { tag :: Tag "isRight" EitherTag
70 , left :: a
71 , right :: b
72 }
73 deriving stock Functor
76instance Bifunctor EitherTable where
77 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
80instance Table Expr a => Apply (EitherTable a) where
81 EitherTable tag l1 f <.> EitherTable tag' l2 a =
82 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
85instance Table Expr a => Applicative (EitherTable a) where
86 pure = rightTable
87 (<*>) = (<.>)
90instance Table Expr a => Bind (EitherTable a) where
91 EitherTable tag l1 a >>- f = case f a of
92 EitherTable tag' l2 b ->
93 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
96instance Table Expr a => Monad (EitherTable a) where
97 (>>=) = (>>-)
100instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
101 a <> b = bool a b (isRightTable a)
104instance
105 ( Table context a, Table context b
106 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
107 ) =>
108 Table context (EitherTable a b)
109 where
110 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
111 type Context (EitherTable a b) = Context a
113 toColumns = toColumns2 toColumns toColumns
114 fromColumns = fromColumns2 fromColumns fromColumns
115 reify = liftA2 bimap reify reify
116 unreify = liftA2 bimap unreify unreify
119instance
120 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
121 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
122 , Recontextualize from to a1 b1
123 , Recontextualize from to a2 b2
124 ) =>
125 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
128instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
129 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
132instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
133 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
136isLeftTable :: EitherTable a b -> Expr Bool
137isLeftTable = isLeft . expr . tag
140isRightTable :: EitherTable a b -> Expr Bool
141isRightTable = isRight . expr . tag
144eitherTable :: Table Expr c
145 => (a -> c) -> (b -> c) -> EitherTable a b -> c
146eitherTable f g EitherTable {tag, left, right} =
147 bool (f left) (g right) (isRight (expr tag))
150leftTable :: Table Expr b => a -> EitherTable a b
151leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
154rightTable :: Table Expr a => b -> EitherTable a b
155rightTable = rightTableWith undefined
158rightTableWith :: a -> b -> EitherTable a b
159rightTableWith = EitherTable (fromExpr (litExpr IsRight))
162aggregateEitherTable :: ()
163 => (a -> Aggregate c)
164 -> (b -> Aggregate d)
165 -> EitherTable a b
166 -> Aggregate (EitherTable c d)
167aggregateEitherTable f g EitherTable {tag, left, right} =
168 liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
169 where
170 Tag {aggregator, expr} = tag
171 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
174nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
175nameEitherTable = EitherTable . fromName
178toColumns2 ::
179 ( HTable t
180 , HTable u
181 , HConstrainTag context EitherTag
182 , HLabelable context
183 , HNullifiable context
184 )
185 => (a -> t context)
186 -> (b -> u context)
187 -> EitherTable a b
188 -> HEitherTable t u context
189toColumns2 f g EitherTable {tag, left, right} = HEitherTable
190 { htag
191 , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
192 , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
193 }
194 where
195 htag = HIdentity (hencodeTag tag)
198fromColumns2 ::
199 ( HTable t
200 , HTable u
201 , HConstrainTag context EitherTag
202 , HLabelable context
203 , HNullifiable context
204 )
205 => (t context -> a)
206 -> (u context -> b)
207 -> HEitherTable t u context
208 -> EitherTable a b
209fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
210 { tag
211 , left = f $ runIdentity $
212 hunnullify (\a -> pure . hunnullifier a) $
213 hunlabel hunlabeler
214 hleft
215 , right = g $ runIdentity $
216 hunnullify (\a -> pure . hunnullifier a) $
217 hunlabel hunlabeler
218 hright
219 }
220 where
221 tag = hdecodeTag $ unHIdentity htag