git.iko.soy/rel8
on 760dcd8 help sign in
rel8/src/Rel8/Query/Either.hs
81 lines 2.3 kB history raw
1{-# language FlexibleContexts #-}
3module Rel8.Query.Either
4 ( keepLeftTable
5 , keepRightTable
6 , bindEitherTable
7 , bitraverseEitherTable
8 )
9where
11-- base
12import Data.Functor ( (<&>) )
13import Prelude
15-- rel8
16import Rel8.Expr ( Expr )
17import Rel8.Expr.Eq ( (==.) )
18import Rel8.Query ( Query )
19import Rel8.Query.Filter ( where_ )
20import Rel8.Query.Maybe ( optional )
21import Rel8.Table ( Table )
22import Rel8.Table.Bool ( bool )
23import Rel8.Table.Either
24 ( EitherTable( EitherTable )
25 , isLeftTable, isRightTable
26 )
27import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
30-- | Filter 'EitherTable's, keeping only 'leftTable's.
31keepLeftTable :: EitherTable a b -> Query a
32keepLeftTable e@(EitherTable _ a _) = do
33 where_ $ isLeftTable e
34 pure a
37-- | Filter 'EitherTable's, keeping only 'rightTable's.
38keepRightTable :: EitherTable a b -> Query b
39keepRightTable e@(EitherTable _ _ b) = do
40 where_ $ isRightTable e
41 pure b
44-- | Extend an 'EitherTable' with a 'Query' if it's a 'rightTable'. If the
45-- @EitherTable@ is a 'leftTable', the original value is preserved.
46--
47-- This is like the '>>=' implementation for @ExceptT@.
48bindEitherTable :: (Table Expr a, Functor m)
49 => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
50bindEitherTable query e@(EitherTable input a i) = do
51 query i <&> \(EitherTable output a' b) ->
52 EitherTable (input <> output) (bool a a' (isRightTable e)) b
55-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
56-- all @rightTable@s through @g@. The results are then lifted back into
57-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'
58-- for 'Either'.
59--
60-- For example,
61--
62-- >>> :{
63-- select do
64-- x <- values (map lit [ Left True, Right (42 :: Int32) ])
65-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x
66-- :}
67-- [ Left True
68-- , Left False
69-- , Right 4200
70-- ]
71bitraverseEitherTable :: ()
72 => (a -> Query c)
73 -> (b -> Query d)
74 -> EitherTable a b
75 -> Query (EitherTable c d)
76bitraverseEitherTable f g e@(EitherTable tag _ _) = do
77 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
78 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
79 where_ $ isJustTable mc ==. isLeftTable e
80 where_ $ isJustTable md ==. isRightTable e
81 pure $ EitherTable tag c d