git.iko.soy/rel8
on ae2ce41 help sign in
rel8/src/Rel8/Table/Either.hs
248 lines 7.1 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 , aggregateEitherTable, insertEitherTable, 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.Aggregate ( Aggregate, unsafeMakeAggregate )
34import Rel8.Expr ( Expr )
35import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36import Rel8.Expr.Serialize ( litExpr )
37import Rel8.Schema.Context.Label
38 ( Labelable
39 , HLabelable, hlabeler, hunlabeler
40 )
41import Rel8.Schema.Context.Nullify
42 ( Nullifiable, ConstrainTag
43 , HNullifiable, HConstrainTag
44 , hencodeTag, hdecodeTag
45 , hnullifier, hunnullifier
46 )
47import Rel8.Schema.HTable ( HTable )
48import Rel8.Schema.HTable.Either ( HEitherTable(..) )
49import Rel8.Schema.HTable.Identity ( HIdentity(..) )
50import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
51import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
52import Rel8.Schema.Insert ( Insert )
53import Rel8.Schema.Name ( Name )
54import Rel8.Table
55 ( Table, Columns, Context, fromColumns, toColumns
56 , reify, unreify
57 )
58import Rel8.Table.Bool ( bool )
59import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Insert ( toInsert )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
68-- semigroupoids
69import Data.Functor.Apply ( Apply, (<.>), liftF3 )
70import Data.Functor.Bind ( Bind, (>>-) )
73type EitherTable :: Type -> Type -> Type
74data EitherTable a b = EitherTable
75 { tag :: Tag "isRight" EitherTag
76 , left :: a
77 , right :: b
78 }
79 deriving stock Functor
82instance Bifunctor EitherTable where
83 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
86instance Table Expr a => Apply (EitherTable a) where
87 EitherTable tag l1 f <.> EitherTable tag' l2 a =
88 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
91instance Table Expr a => Applicative (EitherTable a) where
92 pure = rightTable
93 (<*>) = (<.>)
96instance Table Expr a => Bind (EitherTable a) where
97 EitherTable tag l1 a >>- f = case f a of
98 EitherTable tag' l2 b ->
99 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
102instance Table Expr a => Monad (EitherTable a) where
103 (>>=) = (>>-)
106instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
107 a <> b = bool a b (isRightTable a)
110instance
111 ( Table context a, Table context b
112 , Labelable context, Nullifiable context, ConstrainTag context EitherTag
113 ) =>
114 Table context (EitherTable a b)
115 where
116 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
117 type Context (EitherTable a b) = Context a
119 toColumns = toColumns2 toColumns toColumns
120 fromColumns = fromColumns2 fromColumns fromColumns
121 reify = liftA2 bimap reify reify
122 unreify = liftA2 bimap unreify unreify
125instance
126 ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
127 , Nullifiable to, Labelable to, ConstrainTag to EitherTag
128 , Recontextualize from to a1 b1
129 , Recontextualize from to a2 b2
130 )
131 => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
134instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
135 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
138instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
139 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
142type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
145instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
146 ToExprs x (Either a b)
147 where
148 fromResult =
149 bimap (fromResult @exprs1) (fromResult @exprs2) .
150 fromColumns
151 toResult =
152 toColumns .
153 bimap (toResult @exprs1) (toResult @exprs2)
156isLeftTable :: EitherTable a b -> Expr Bool
157isLeftTable = isLeft . expr . tag
160isRightTable :: EitherTable a b -> Expr Bool
161isRightTable = isRight . expr . tag
164eitherTable :: Table Expr c
165 => (a -> c) -> (b -> c) -> EitherTable a b -> c
166eitherTable f g EitherTable {tag, left, right} =
167 bool (f left) (g right) (isRight (expr tag))
170leftTable :: Table Expr b => a -> EitherTable a b
171leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
174rightTable :: Table Expr a => b -> EitherTable a b
175rightTable = rightTableWith undefined
178rightTableWith :: a -> b -> EitherTable a b
179rightTableWith = EitherTable (fromExpr (litExpr IsRight))
182aggregateEitherTable :: ()
183 => (a -> Aggregate c)
184 -> (b -> Aggregate d)
185 -> EitherTable a b
186 -> Aggregate (EitherTable c d)
187aggregateEitherTable f g EitherTable {tag, left, right} =
188 liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
189 where
190 Tag {aggregator, expr} = tag
191 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
194insertEitherTable :: (Table Insert a, Table Insert b)
195 => Either a b -> EitherTable a b
196insertEitherTable = \case
197 Left a -> EitherTable (fromExpr (litExpr IsLeft)) a (fromColumns (toInsert undefined))
198 Right b -> EitherTable (fromExpr (litExpr IsRight)) (fromColumns (toInsert undefined)) b
201nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
202nameEitherTable = EitherTable . fromName
205toColumns2 ::
206 ( HTable t
207 , HTable u
208 , HConstrainTag context EitherTag
209 , HLabelable context
210 , HNullifiable context
211 )
212 => (a -> t context)
213 -> (b -> u context)
214 -> EitherTable a b
215 -> HEitherTable t u context
216toColumns2 f g EitherTable {tag, left, right} = HEitherTable
217 { htag
218 , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
219 , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
220 }
221 where
222 htag = HIdentity (hencodeTag tag)
225fromColumns2 ::
226 ( HTable t
227 , HTable u
228 , HConstrainTag context EitherTag
229 , HLabelable context
230 , HNullifiable context
231 )
232 => (t context -> a)
233 -> (u context -> b)
234 -> HEitherTable t u context
235 -> EitherTable a b
236fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
237 { tag
238 , left = f $ runIdentity $
239 hunnullify (\a -> pure . hunnullifier a) $
240 hunlabel hunlabeler
241 hleft
242 , right = g $ runIdentity $
243 hunnullify (\a -> pure . hunnullifier a) $
244 hunlabel hunlabeler
245 hright
246 }
247 where
248 tag = hdecodeTag $ unHIdentity htag