git.iko.soy/rel8
on 70ce05d help sign in
rel8/src/Rel8/Query/These.hs
136 lines 4.2 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 , bitraverseTheseTable
11 )
12where
14-- base
15import Prelude
17-- opaleye
18import qualified Opaleye.Internal.PackMap as Opaleye
19import qualified Opaleye.Internal.PrimQuery as Opaleye
20import qualified Opaleye.Internal.QueryArr as Opaleye
21import qualified Opaleye.Internal.Tag as Opaleye
23-- rel8
24import Rel8.Expr ( Expr )
25import Rel8.Expr.Bool ( boolExpr, not_ )
26import Rel8.Expr.Eq ( (==.) )
27import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
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.Either ( EitherTable( EitherTable ) )
34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35import Rel8.Table.Tag ( Tag(..), fromExpr )
36import Rel8.Table.These
37 ( TheseTable( TheseTable, here, there )
38 , hasHereTable, hasThereTable
39 , isThisTable, isThatTable, isThoseTable
40 )
41import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
44-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
45alignBy :: ()
46 => (a -> b -> Expr Bool)
47 -> Query a -> Query b -> Query (TheseTable a b)
48alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
49 (_, input, tag) -> (tab, join', tag''')
50 where
51 (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
52 (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
53 MaybeTable Tag {expr = hasHere} a = ma
54 MaybeTable Tag {expr = hasThere} b = mb
55 (hasHere', lbindings) = Opaleye.run $ do
56 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
57 (hasThere', rbindings) = Opaleye.run $ do
58 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
59 tag''' = Opaleye.next tag''
60 join = Opaleye.Join Opaleye.FullJoin on lbindings rbindings left' right'
61 where
62 on = toPrimExpr $ condition a b
63 ma' = MaybeTable (fromExpr hasHere') a
64 mb' = MaybeTable (fromExpr hasThere') b
65 tab = TheseTable {here = ma', there = mb'}
66 join' = Opaleye.times input join
69-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.
70keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
71keepHereTable = loseThatTable
74-- | Filter 'TheseTable's, keeping on
75loseHereTable :: TheseTable a b -> Query b
76loseHereTable = keepThatTable
79keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
80keepThereTable = loseThisTable
83loseThereTable :: TheseTable a b -> Query a
84loseThereTable = keepThisTable
87keepThisTable :: TheseTable a b -> Query a
88keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
89 where_ $ isThisTable t
90 pure a
93loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
94loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
95 where_ $ not_ $ isThisTable t
96 pure (ma, b)
99keepThatTable :: TheseTable a b -> Query b
100keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
101 where_ $ isThatTable t
102 pure b
105loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
106loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
107 where_ $ not_ $ isThatTable t
108 pure (a, mb)
111keepThoseTable :: TheseTable a b -> Query (a, b)
112keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
113 where_ $ isThoseTable t
114 pure (a, b)
117loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
118loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
119 where_ $ not_ $ isThoseTable t
120 pure $ EitherTable result a b
121 where
122 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
123 result = (mempty `asTypeOf` result) {expr = tag}
126bitraverseTheseTable :: ()
127 => (a -> Query c)
128 -> (b -> Query d)
129 -> TheseTable a b
130 -> Query (TheseTable c d)
131bitraverseTheseTable f g t = do
132 mc <- optional (f . fst =<< keepHereTable t)
133 md <- optional (g . snd =<< keepThereTable t)
134 where_ $ isJustTable mc ==. hasHereTable t
135 where_ $ isJustTable md ==. hasThereTable t
136 pure $ TheseTable mc md