git.iko.soy/rel8
on 17c67ad help sign in
rel8/src/Rel8/Query/These.hs
132 lines 3.8 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.Functor ( (<&>) )
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.Eq ( (==.) )
27import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
28import Rel8.Expr.Serialize ( litExpr )
29import Rel8.Query ( Query )
30import Rel8.Query.Filter ( where_ )
31import Rel8.Query.Maybe ( optional )
32import Rel8.Query.Opaleye ( zipOpaleyeWith )
33import Rel8.Table ( Table )
34import Rel8.Table.Either ( EitherTable( EitherTable ) )
35import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
36import Rel8.Table.Opaleye ( unpackspec )
37import Rel8.Table.Tag ( Tag(..) )
38import Rel8.Table.These
39 ( TheseTable( TheseTable )
40 , hasHereTable, hasThereTable
41 , isThisTable, isThatTable, isThoseTable
42 )
43import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
46-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
47alignBy :: (Table Expr a, Table Expr b)
48 => (a -> b -> Expr Bool)
49 -> Query a -> Query b -> Query (TheseTable a b)
50alignBy condition as bs =
51 uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
52 where
53 fullOuterJoin a b =
54 Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
55 where
56 full = Opaleye.FullJoin
57 on = toColumn . toPrimExpr . uncurry condition
60keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
61keepHereTable = loseThatTable
64loseHereTable :: TheseTable a b -> Query b
65loseHereTable = keepThatTable
68keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
69keepThereTable = loseThisTable
72loseThereTable :: TheseTable a b -> Query a
73loseThereTable = keepThisTable
76keepThisTable :: TheseTable a b -> Query a
77keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
78 where_ $ isThisTable t
79 pure a
82loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
83loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
84 where_ $ not_ $ isThisTable t
85 pure (ma, b)
88keepThatTable :: TheseTable a b -> Query b
89keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
90 where_ $ isThatTable t
91 pure b
94loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
95loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
96 where_ $ not_ $ isThatTable t
97 pure (a, mb)
100keepThoseTable :: TheseTable a b -> Query (a, b)
101keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
102 where_ $ isThoseTable t
103 pure (a, b)
106loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
107loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
108 where_ $ not_ $ isThoseTable t
109 pure $ EitherTable result a b
110 where
111 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
112 result = (mempty `asTypeOf` result) {expr = tag}
115bindTheseTable :: (Table Expr a, Semigroup a, Functor m)
116 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
117bindTheseTable query (TheseTable here (MaybeTable input i)) =
118 query i <&> \(TheseTable here' (MaybeTable output b)) ->
119 TheseTable (here <> here') (MaybeTable (input <> output) b)
122bitraverseTheseTable :: ()
123 => (a -> Query c)
124 -> (b -> Query d)
125 -> TheseTable a b
126 -> Query (TheseTable c d)
127bitraverseTheseTable f g t = do
128 mc <- optional (f . fst =<< keepHereTable t)
129 md <- optional (g . snd =<< keepThereTable t)
130 where_ $ isJustTable mc ==. hasHereTable t
131 where_ $ isJustTable md ==. hasThereTable t
132 pure $ TheseTable mc md