git.iko.soy/rel8
on b018385 help sign in
rel8/src/Rel8/Query/Either.hs
67 lines 1.9 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-- | Extend an 'EitherTable' with queries for both 'leftTable' and
56-- 'rightTable'.
57bitraverseEitherTable :: ()
58 => (a -> Query c)
59 -> (b -> Query d)
60 -> EitherTable a b
61 -> Query (EitherTable c d)
62bitraverseEitherTable f g e@(EitherTable tag _ _) = do
63 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
64 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
65 where_ $ isJustTable mc ==. isLeftTable e
66 where_ $ isJustTable md ==. isRightTable e
67 pure $ EitherTable tag c d