git.iko.soy/rel8
on 1276beb help sign in
rel8/src/Rel8/Table/Either.hs
215 lines 6.1 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 Data.Bifunctor ( Bifunctor, bimap )
24import Data.Functor.Identity ( runIdentity )
25import Data.Kind ( Type )
26import Prelude hiding ( undefined )
28-- rel8
29import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
30import Rel8.Expr ( Expr )
31import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
32import Rel8.Expr.Serialize ( litExpr )
33import Rel8.Schema.Context.Label
34 ( Labelable
35 , HLabelable, hlabeler, hunlabeler
36 )
37import Rel8.Schema.Context.Nullify
38 ( Nullifiable, ConstrainTag
39 , HNullifiable, HConstrainTag
40 , hencodeTag, hdecodeTag
41 , hnullifier, hunnullifier
42 )
43import Rel8.Schema.HTable ( HTable )
44import Rel8.Schema.HTable.Either ( HEitherTable(..) )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
48import Rel8.Schema.Name ( Name )
49import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
50import Rel8.Table.Bool ( bool )
51import Rel8.Table.Eq ( EqTable, eqTable )
52import Rel8.Table.Ord ( OrdTable, ordTable )
53import Rel8.Table.Recontextualize ( Recontextualize )
54import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
55import Rel8.Table.Undefined ( undefined )
56import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
58-- semigroupoids
59import Data.Functor.Apply ( Apply, (<.>), liftF3 )
60import Data.Functor.Bind ( Bind, (>>-) )
63type EitherTable :: Type -> Type -> Type
64data EitherTable a b = EitherTable
65 { tag :: Tag "isRight" EitherTag
66 , left :: a
67 , right :: b
68 }
69 deriving stock Functor
72instance Bifunctor EitherTable where
73 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
76instance Table Expr a => Apply (EitherTable a) where
77 EitherTable tag l1 f <.> EitherTable tag' l2 a =
78 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
81instance Table Expr a => Applicative (EitherTable a) where
82 pure = rightTable
83 (<*>) = (<.>)
86instance Table Expr a => Bind (EitherTable a) where
87 EitherTable tag l1 a >>- f = case f a of
88 EitherTable tag' l2 b ->
89 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
92instance Table Expr a => Monad (EitherTable a) where
93 (>>=) = (>>-)
96instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
97 a <> b = bool a b (isRightTable a)
100instance
101 ( Table context a, Table context b
102 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
103 ) =>
104 Table context (EitherTable a b)
105 where
106 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
107 type Context (EitherTable a b) = Context a
109 toColumns = toColumns2 toColumns toColumns
110 fromColumns = fromColumns2 fromColumns fromColumns
113instance
114 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
115 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
116 , Recontextualize from to a1 b1
117 , Recontextualize from to a2 b2
118 ) =>
119 Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
122instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
123 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
126instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
127 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
130isLeftTable :: EitherTable a b -> Expr Bool
131isLeftTable = isLeft . expr . tag
134isRightTable :: EitherTable a b -> Expr Bool
135isRightTable = isRight . expr . tag
138eitherTable :: Table Expr c
139 => (a -> c) -> (b -> c) -> EitherTable a b -> c
140eitherTable f g EitherTable {tag, left, right} =
141 bool (f left) (g right) (isRight (expr tag))
144leftTable :: Table Expr b => a -> EitherTable a b
145leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
148rightTable :: Table Expr a => b -> EitherTable a b
149rightTable = rightTableWith undefined
152rightTableWith :: a -> b -> EitherTable a b
153rightTableWith = EitherTable (fromExpr (litExpr IsRight))
156aggregateEitherTable :: ()
157 => (a -> Aggregate c)
158 -> (b -> Aggregate d)
159 -> EitherTable a b
160 -> Aggregate (EitherTable c d)
161aggregateEitherTable f g EitherTable {tag, left, right} =
162 liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
163 where
164 Tag {aggregator, expr} = tag
165 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
168nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
169nameEitherTable = EitherTable . fromName
172toColumns2 ::
173 ( HTable t
174 , HTable u
175 , HConstrainTag context EitherTag
176 , HLabelable context
177 , HNullifiable context
178 )
179 => (a -> t context)
180 -> (b -> u context)
181 -> EitherTable a b
182 -> HEitherTable t u context
183toColumns2 f g EitherTable {tag, left, right} = HEitherTable
184 { htag
185 , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
186 , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
187 }
188 where
189 htag = HIdentity (hencodeTag tag)
192fromColumns2 ::
193 ( HTable t
194 , HTable u
195 , HConstrainTag context EitherTag
196 , HLabelable context
197 , HNullifiable context
198 )
199 => (t context -> a)
200 -> (u context -> b)
201 -> HEitherTable t u context
202 -> EitherTable a b
203fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
204 { tag
205 , left = f $ runIdentity $
206 hunnullify (\a -> pure . hunnullifier a) $
207 hunlabel hunlabeler
208 hleft
209 , right = g $ runIdentity $
210 hunnullify (\a -> pure . hunnullifier a) $
211 hunlabel hunlabeler
212 hright
213 }
214 where
215 tag = hdecodeTag $ unHIdentity htag