git.iko.soy/rel8
on 8a680c9 help sign in
rel8/src/Rel8/Table/Either.hs
238 lines 6.7 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 #-}
14{-# options_ghc -fno-warn-orphans #-}
16module Rel8.Table.Either
17 ( EitherTable(..)
18 , eitherTable, leftTable, rightTable
19 , isLeftTable, isRightTable
20 , aggregateEitherTable, nameEitherTable
21 )
22where
24-- base
25import Control.Applicative ( liftA2 )
26import Data.Bifunctor ( Bifunctor, bimap )
27import Data.Functor.Identity ( runIdentity )
28import Data.Kind ( Type )
29import Prelude hiding ( undefined )
31-- rel8
32import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
33import Rel8.Expr ( Expr )
34import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35import Rel8.Expr.Serialize ( litExpr )
36import Rel8.Schema.Context.Label
37 ( Labelable
38 , HLabelable, hlabeler, hunlabeler
39 )
40import Rel8.Schema.Context.Nullify
41 ( Nullifiable, ConstrainTag
42 , HNullifiable, HConstrainTag
43 , hencodeTag, hdecodeTag
44 , hnullifier, hunnullifier
45 )
46import Rel8.Schema.HTable ( HTable )
47import Rel8.Schema.HTable.Either ( HEitherTable(..) )
48import Rel8.Schema.HTable.Identity ( HIdentity(..) )
49import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
50import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
51import Rel8.Schema.Name ( Name )
52import Rel8.Table
53 ( Table, Columns, Context, fromColumns, toColumns
54 , reify, unreify
55 )
56import Rel8.Table.Bool ( bool )
57import Rel8.Table.Eq ( EqTable, eqTable )
58import Rel8.Table.Ord ( OrdTable, ordTable )
59import Rel8.Table.Recontextualize ( Recontextualize )
60import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
61import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
62import Rel8.Table.Undefined ( undefined )
63import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
65-- semigroupoids
66import Data.Functor.Apply ( Apply, (<.>), liftF3 )
67import Data.Functor.Bind ( Bind, (>>-) )
70type EitherTable :: Type -> Type -> Type
71data EitherTable a b = EitherTable
72 { tag :: Tag "isRight" EitherTag
73 , left :: a
74 , right :: b
75 }
76 deriving stock Functor
79instance Bifunctor EitherTable where
80 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
83instance Table Expr a => Apply (EitherTable a) where
84 EitherTable tag l1 f <.> EitherTable tag' l2 a =
85 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
88instance Table Expr a => Applicative (EitherTable a) where
89 pure = rightTable
90 (<*>) = (<.>)
93instance Table Expr a => Bind (EitherTable a) where
94 EitherTable tag l1 a >>- f = case f a of
95 EitherTable tag' l2 b ->
96 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
99instance Table Expr a => Monad (EitherTable a) where
100 (>>=) = (>>-)
103instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
104 a <> b = bool a b (isRightTable a)
107instance
108 ( Table context a, Table context b
109 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
110 ) =>
111 Table context (EitherTable a b)
112 where
113 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
114 type Context (EitherTable a b) = Context a
116 toColumns = toColumns2 toColumns toColumns
117 fromColumns = fromColumns2 fromColumns fromColumns
118 reify = liftA2 bimap reify reify
119 unreify = liftA2 bimap unreify unreify
122instance
123 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
124 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
125 , Recontextualize from to a1 b1
126 , Recontextualize from to a2 b2
127 )
128 => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
131instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
132 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
135instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
136 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
139type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
142instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
143 ToExprs x (Either a b)
144 where
145 fromResult =
146 bimap (fromResult @exprs1) (fromResult @exprs2) .
147 fromColumns
148 toResult =
149 toColumns .
150 bimap (toResult @exprs1) (toResult @exprs2)
153isLeftTable :: EitherTable a b -> Expr Bool
154isLeftTable = isLeft . expr . tag
157isRightTable :: EitherTable a b -> Expr Bool
158isRightTable = isRight . expr . tag
161eitherTable :: Table Expr c
162 => (a -> c) -> (b -> c) -> EitherTable a b -> c
163eitherTable f g EitherTable {tag, left, right} =
164 bool (f left) (g right) (isRight (expr tag))
167leftTable :: Table Expr b => a -> EitherTable a b
168leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
171rightTable :: Table Expr a => b -> EitherTable a b
172rightTable = rightTableWith undefined
175rightTableWith :: a -> b -> EitherTable a b
176rightTableWith = EitherTable (fromExpr (litExpr IsRight))
179aggregateEitherTable :: ()
180 => (a -> Aggregate c)
181 -> (b -> Aggregate d)
182 -> EitherTable a b
183 -> Aggregate (EitherTable c d)
184aggregateEitherTable f g EitherTable {tag, left, right} =
185 liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
186 where
187 Tag {aggregator, expr} = tag
188 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
191nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
192nameEitherTable = EitherTable . fromName
195toColumns2 ::
196 ( HTable t
197 , HTable u
198 , HConstrainTag context EitherTag
199 , HLabelable context
200 , HNullifiable context
201 )
202 => (a -> t context)
203 -> (b -> u context)
204 -> EitherTable a b
205 -> HEitherTable t u context
206toColumns2 f g EitherTable {tag, left, right} = HEitherTable
207 { htag
208 , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
209 , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
210 }
211 where
212 htag = HIdentity (hencodeTag tag)
215fromColumns2 ::
216 ( HTable t
217 , HTable u
218 , HConstrainTag context EitherTag
219 , HLabelable context
220 , HNullifiable context
221 )
222 => (t context -> a)
223 -> (u context -> b)
224 -> HEitherTable t u context
225 -> EitherTable a b
226fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
227 { tag
228 , left = f $ runIdentity $
229 hunnullify (\a -> pure . hunnullifier a) $
230 hunlabel hunlabeler
231 hleft
232 , right = g $ runIdentity $
233 hunnullify (\a -> pure . hunnullifier a) $
234 hunlabel hunlabeler
235 hright
236 }
237 where
238 tag = hdecodeTag $ unHIdentity htag