git.iko.soy/rel8
on 07daf4f help sign in
rel8/src/Rel8/Table/Either.hs
242 lines 7.0 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.Nullify
36 ( Nullifiable, ConstrainTag
37 , HNullifiable, HConstrainTag
38 , hencodeTag, hdecodeTag
39 , hnullifier, hunnullifier
40 )
41import Rel8.Schema.HTable ( HTable )
42import Rel8.Schema.HTable.Either ( HEitherTable(..) )
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
46import Rel8.Schema.Name ( Name )
47import Rel8.Table
48 ( Table, Columns, Context, fromColumns, toColumns
49 , reify, unreify
50 )
51import Rel8.Table.Bool ( bool )
52import Rel8.Table.Eq ( EqTable, eqTable )
53import Rel8.Table.Ord ( OrdTable, ordTable )
54import Rel8.Table.Recontextualize ( Recontextualize )
55import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
56import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
57import Rel8.Table.Undefined ( undefined )
58import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
60-- semigroupoids
61import Data.Functor.Apply ( Apply, (<.>) )
62import Data.Functor.Bind ( Bind, (>>-) )
65-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
66-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
67-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
68--
69-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
70-- adapted to work with Rel8.
71type EitherTable :: Type -> Type -> Type
72data EitherTable a b = EitherTable
73 { tag :: Tag "isRight" EitherTag
74 , left :: a
75 , right :: b
76 }
77 deriving stock Functor
80instance Bifunctor EitherTable where
81 bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
84instance Table Expr a => Apply (EitherTable a) where
85 EitherTable tag l1 f <.> EitherTable tag' l2 a =
86 EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
89instance Table Expr a => Applicative (EitherTable a) where
90 pure = rightTable
91 (<*>) = (<.>)
94instance Table Expr a => Bind (EitherTable a) where
95 EitherTable tag l1 a >>- f = case f a of
96 EitherTable tag' l2 b ->
97 EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
100instance Table Expr a => Monad (EitherTable a) where
101 (>>=) = (>>-)
104instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
105 a <> b = bool a b (isRightTable a)
108instance
109 ( Table context a, Table context b
110 , Nullifiable context, ConstrainTag context EitherTag
111 ) =>
112 Table context (EitherTable a b)
113 where
114 type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
115 type Context (EitherTable a b) = Context a
117 toColumns = toColumns2 toColumns toColumns
118 fromColumns = fromColumns2 fromColumns fromColumns
119 reify = liftA2 bimap reify reify
120 unreify = liftA2 bimap unreify unreify
123instance
124 ( Nullifiable from, ConstrainTag from EitherTag
125 , Nullifiable to, ConstrainTag to EitherTag
126 , Recontextualize from to a1 b1
127 , Recontextualize from to a2 b2
128 )
129 => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
132instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
133 eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
136instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
137 ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
140type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
143instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
144 ToExprs x (Either a b)
145 where
146 fromResult =
147 bimap (fromResult @exprs1) (fromResult @exprs2) .
148 fromColumns
149 toResult =
150 toColumns .
151 bimap (toResult @exprs1) (toResult @exprs2)
154-- | Test if an 'EitherTable' is a 'leftTable'.
155isLeftTable :: EitherTable a b -> Expr Bool
156isLeftTable = isLeft . expr . tag
159-- | Test if an 'EitherTable' is a 'rightTable'.
160isRightTable :: EitherTable a b -> Expr Bool
161isRightTable = isRight . expr . tag
164-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
165-- 'leftTable' and 'rightTable'.
166eitherTable :: Table Expr c
167 => (a -> c) -> (b -> c) -> EitherTable a b -> c
168eitherTable f g EitherTable {tag, left, right} =
169 bool (f left) (g right) (isRight (expr tag))
172-- | Construct a left 'EitherTable'. Like 'Left'.
173leftTable :: Table Expr b => a -> EitherTable a b
174leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
177-- | Construct a right 'EitherTable'. Like 'Right'.
178rightTable :: Table Expr a => b -> EitherTable a b
179rightTable = rightTableWith undefined
182rightTableWith :: a -> b -> EitherTable a b
183rightTableWith = EitherTable (fromExpr (litExpr IsRight))
186-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
187-- have a 'EitherTable' that you are storing in a table and need to construct a
188-- 'TableSchema'.
189nameEitherTable
190 :: Name EitherTag
191 -- ^ The name of the column to track whether a row is a 'leftTable' or
192 -- 'rightTable'.
193 -> a
194 -- ^ Names of the columns in the @a@ table.
195 -> b
196 -- ^ Names of the columns in the @b@ table.
197 -> EitherTable a b
198nameEitherTable = EitherTable . fromName
201toColumns2 ::
202 ( HTable t
203 , HTable u
204 , HConstrainTag context EitherTag
205 , HNullifiable context
206 )
207 => (a -> t context)
208 -> (b -> u context)
209 -> EitherTable a b
210 -> HEitherTable t u context
211toColumns2 f g EitherTable {tag, left, right} = HEitherTable
212 { htag
213 , hleft = hlabel $ hnullify (hnullifier tag isLeft) $ f left
214 , hright = hlabel $ hnullify (hnullifier tag isRight) $ g right
215 }
216 where
217 htag = hlabel $ HType $ hencodeTag tag
220fromColumns2 ::
221 ( HTable t
222 , HTable u
223 , HConstrainTag context EitherTag
224 , HNullifiable context
225 )
226 => (t context -> a)
227 -> (u context -> b)
228 -> HEitherTable t u context
229 -> EitherTable a b
230fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
231 { tag
232 , left = f $ runIdentity $
233 hunnullify (\a -> pure . hunnullifier a) $
234 hunlabel
235 hleft
236 , right = g $ runIdentity $
237 hunnullify (\a -> pure . hunnullifier a) $
238 hunlabel
239 hright
240 }
241 where
242 tag = hdecodeTag $ unHIdentity $ hunlabel htag