git.iko.soy/rel8
on 04e24ae help sign in
rel8/src/Rel8/Query/These.hs
129 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 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 ) )
43-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
44alignBy :: (Table Expr a, Table Expr b)
45 => (a -> b -> Expr Bool)
46 -> Query a -> Query b -> Query (TheseTable a b)
47alignBy condition as bs =
48 uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
49 where
50 fullOuterJoin a b =
51 Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
52 where
53 full = Opaleye.FullJoin
54 on = toColumn . toPrimExpr . uncurry condition
57keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
58keepHereTable = loseThatTable
61loseHereTable :: TheseTable a b -> Query b
62loseHereTable = keepThatTable
65keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
66keepThereTable = loseThisTable
69loseThereTable :: TheseTable a b -> Query a
70loseThereTable = keepThisTable
73keepThisTable :: TheseTable a b -> Query a
74keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
75 where_ $ isThisTable t
76 pure a
79loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
80loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
81 where_ $ not_ $ isThisTable t
82 pure (ma, b)
85keepThatTable :: TheseTable a b -> Query b
86keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
87 where_ $ isThatTable t
88 pure b
91loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
92loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
93 where_ $ not_ $ isThatTable t
94 pure (a, mb)
97keepThoseTable :: TheseTable a b -> Query (a, b)
98keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
99 where_ $ isThoseTable t
100 pure (a, b)
103loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
104loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
105 where_ $ not_ $ isThoseTable t
106 pure $ EitherTable tag a b
107 where
108 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
111bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
112 => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
113bindTheseTable query (TheseTable here (MaybeTable input i)) = do
114 TheseTable here' (MaybeTable output b) <- query i
115 pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
118bitraverseTheseTable :: (Table Expr c, Table Expr d)
119 => (a -> Query c)
120 -> (b -> Query d)
121 -> TheseTable a b
122 -> Query (TheseTable c d)
123bitraverseTheseTable f g (TheseTable here there) =
124 bimap fromJustTable fromJustTable <$>
125 alignBy (\l r -> isJustTable l &&. isJustTable r)
126 (traverseMaybeTable f here)
127 (traverseMaybeTable g there)
128 where
129 fromJustTable (MaybeTable _ a) = a