git.iko.soy/rel8
on eb180fa help sign in
rel8/src/Rel8/Query/These.hs
128 lines 3.6 kB history raw
1{-# language FlexibleContexts #-}
3module Rel8.Query.These
4 ( alignBy
5 , keepHereTable, loseHereTable
6 , keepThereTable, loseThereTable
7 , keepThisTable, loseThisTable
8 , keepThatTable, loseThatTable
9 , keepThoseTable, loseThoseTable
10 , bindTheseTable
11 , bitraverseTheseTable
12 )
13where
15-- base
16import Data.Bifunctor ( bimap )
17import Prelude
19-- opaleye
20import qualified Opaleye.Internal.Join as Opaleye
21import qualified Opaleye.Internal.PrimQuery as Opaleye
23-- rel8
24import Rel8.Expr ( Expr )
25import Rel8.Expr.Bool ( (&&.), boolExpr, not_ )
26import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
27import Rel8.Expr.Serialize ( litExpr )
28import Rel8.Query ( Query )
29import Rel8.Query.Filter ( where_ )
30import Rel8.Query.Maybe ( traverseMaybeTable )
31import Rel8.Query.Opaleye ( zipOpaleyeWith )
32import Rel8.Table ( Table )
33import Rel8.Table.Either ( EitherTable( EitherTable ) )
34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35import Rel8.Table.Opaleye ( unpackspec )
36import Rel8.Table.These
37 ( TheseTable( TheseTable )
38 , isThisTable, isThatTable, isThoseTable
39 )
40import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
43alignBy :: (Table Expr a, Table Expr b)
44 => (a -> b -> Expr Bool)
45 -> Query a -> Query b -> Query (TheseTable a b)
46alignBy condition as bs =
47 uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
48 where
49 fullOuterJoin a b =
50 Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
51 where
52 full = Opaleye.FullJoin
53 on = toColumn . toPrimExpr . uncurry condition
56keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
57keepHereTable = loseThatTable
60loseHereTable :: TheseTable a b -> Query b
61loseHereTable = keepThatTable
64keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
65keepThereTable = loseThisTable
68loseThereTable :: TheseTable a b -> Query a
69loseThereTable = keepThisTable
72keepThisTable :: TheseTable a b -> Query a
73keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
74 where_ $ isThisTable t
75 pure a
78loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
79loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
80 where_ $ not_ $ isThisTable t
81 pure (ma, b)
84keepThatTable :: TheseTable a b -> Query b
85keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
86 where_ $ isThatTable t
87 pure b
90loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
91loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
92 where_ $ not_ $ isThatTable t
93 pure (a, mb)
96keepThoseTable :: TheseTable a b -> Query (a, b)
97keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
98 where_ $ isThoseTable t
99 pure (a, b)
102loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
103loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
104 where_ $ not_ $ isThoseTable t
105 pure $ EitherTable tag a b
106 where
107 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
110bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
111 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
112bindTheseTable query (TheseTable here (MaybeTable input i)) = do
113 TheseTable here' (MaybeTable output b) <- query i
114 pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
117bitraverseTheseTable :: (Table Expr c, Table Expr d)
118 => (a -> Query c)
119 -> (b -> Query d)
120 -> TheseTable a b
121 -> Query (TheseTable c d)
122bitraverseTheseTable f g (TheseTable here there) =
123 bimap fromJustTable fromJustTable <$>
124 alignBy (\l r -> isJustTable l &&. isJustTable r)
125 (traverseMaybeTable f here)
126 (traverseMaybeTable g there)
127 where
128 fromJustTable (MaybeTable _ a) = a