git.iko.soy/rel8
on d07e3b5 help sign in
rel8/src/Rel8/Query/These.hs
131 lines 3.7 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 Prelude
18-- opaleye
19import qualified Opaleye.Internal.Join as Opaleye
20import qualified Opaleye.Internal.PrimQuery as Opaleye
22-- rel8
23import Rel8.Expr ( Expr )
24import Rel8.Expr.Bool ( boolExpr, not_ )
25import Rel8.Expr.Eq ( (==.) )
26import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
27import Rel8.Expr.Serialize ( litExpr )
28import Rel8.Query ( Query )
29import Rel8.Query.Filter ( where_ )
30import Rel8.Query.Maybe ( optional )
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.Tag ( Tag(..) )
37import Rel8.Table.These
38 ( TheseTable( TheseTable )
39 , hasHereTable, hasThereTable
40 , isThisTable, isThatTable, isThoseTable
41 )
42import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
45-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
46alignBy :: (Table Expr a, Table Expr b)
47 => (a -> b -> Expr Bool)
48 -> Query a -> Query b -> Query (TheseTable a b)
49alignBy condition as bs =
50 uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
51 where
52 fullOuterJoin a b =
53 Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
54 where
55 full = Opaleye.FullJoin
56 on = toColumn . toPrimExpr . uncurry condition
59keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
60keepHereTable = loseThatTable
63loseHereTable :: TheseTable a b -> Query b
64loseHereTable = keepThatTable
67keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
68keepThereTable = loseThisTable
71loseThereTable :: TheseTable a b -> Query a
72loseThereTable = keepThisTable
75keepThisTable :: TheseTable a b -> Query a
76keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
77 where_ $ isThisTable t
78 pure a
81loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
82loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
83 where_ $ not_ $ isThisTable t
84 pure (ma, b)
87keepThatTable :: TheseTable a b -> Query b
88keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
89 where_ $ isThatTable t
90 pure b
93loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
94loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
95 where_ $ not_ $ isThatTable t
96 pure (a, mb)
99keepThoseTable :: TheseTable a b -> Query (a, b)
100keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
101 where_ $ isThoseTable t
102 pure (a, b)
105loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
107 where_ $ not_ $ isThoseTable t
108 pure $ EitherTable result a b
109 where
110 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
111 result = (mempty `asTypeOf` result) {expr = tag}
114bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
115 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
116bindTheseTable query (TheseTable here (MaybeTable input i)) = do
117 TheseTable here' (MaybeTable output b) <- query i
118 pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
121bitraverseTheseTable :: ()
122 => (a -> Query c)
123 -> (b -> Query d)
124 -> TheseTable a b
125 -> Query (TheseTable c d)
126bitraverseTheseTable f g t = do
127 mc <- optional (f . fst =<< keepHereTable t)
128 md <- optional (g . snd =<< keepThereTable t)
129 where_ $ isJustTable mc ==. hasHereTable t
130 where_ $ isJustTable md ==. hasThereTable t
131 pure $ TheseTable mc md