git.iko.soy/rel8
on 707a36a help sign in
rel8/src/Rel8/Query/These.hs
135 lines 4.3 kB history raw
1{-# language FlexibleContexts #-}
2{-# language GADTs #-}
4module Rel8.Query.These
5 ( alignBy
6 , keepHereTable, loseHereTable
7 , keepThereTable, loseThereTable
8 , keepThisTable, loseThisTable
9 , keepThatTable, loseThatTable
10 , keepThoseTable, loseThoseTable
11 , bitraverseTheseTable
12 )
13where
15-- base
16import Prelude
18-- opaleye
19import qualified Opaleye.Internal.PackMap as Opaleye
20import qualified Opaleye.Internal.PrimQuery as Opaleye
21import qualified Opaleye.Internal.QueryArr as Opaleye
22import qualified Opaleye.Internal.Tag as Opaleye
24-- rel8
25import Rel8.Expr ( Col( E ), Expr )
26import Rel8.Expr.Bool ( boolExpr, not_ )
27import Rel8.Expr.Eq ( (==.) )
28import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
29import Rel8.Expr.Serialize ( litExpr )
30import Rel8.Query ( Query )
31import Rel8.Query.Filter ( where_ )
32import Rel8.Query.Maybe ( optional )
33import Rel8.Query.Opaleye ( zipOpaleyeWith )
34import Rel8.Table.Either ( EitherTable( EitherTable ) )
35import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
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 Expr a b)
48alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
49 (_, 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 (E hasHere) a = ma
54 MaybeTable (E 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 lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
61 where
62 on = toPrimExpr $ condition a b
63 left'' = (lateral, Opaleye.Rebind True lbindings left')
64 right'' = (lateral, Opaleye.Rebind True rbindings right')
65 ma' = MaybeTable (E hasHere') a
66 mb' = MaybeTable (E hasThere') b
67 tab = TheseTable {here = ma', there = mb'}
68 join' lateral input = Opaleye.times lateral input (join lateral)
71keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
72keepHereTable = loseThatTable
75loseHereTable :: TheseTable Expr a b -> Query b
76loseHereTable = keepThatTable
79keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
80keepThereTable = loseThisTable
83loseThereTable :: TheseTable Expr a b -> Query a
84loseThereTable = keepThisTable
87keepThisTable :: TheseTable Expr a b -> Query a
88keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
89 where_ $ isThisTable t
90 pure a
93loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
94loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
95 where_ $ not_ $ isThisTable t
96 pure (ma, b)
99keepThatTable :: TheseTable Expr a b -> Query b
100keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
101 where_ $ isThatTable t
102 pure b
105loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
106loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
107 where_ $ not_ $ isThatTable t
108 pure (a, mb)
111keepThoseTable :: TheseTable Expr a b -> Query (a, b)
112keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
113 where_ $ isThoseTable t
114 pure (a, b)
117loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
118loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
119 where_ $ not_ $ isThoseTable t
120 pure $ EitherTable (E tag) a b
121 where
122 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
125bitraverseTheseTable :: ()
126 => (a -> Query c)
127 -> (b -> Query d)
128 -> TheseTable Expr a b
129 -> Query (TheseTable Expr c d)
130bitraverseTheseTable f g t = do
131 mc <- optional (f . fst =<< keepHereTable t)
132 md <- optional (g . snd =<< keepThereTable t)
133 where_ $ isJustTable mc ==. hasHereTable t
134 where_ $ isJustTable md ==. hasThereTable t
135 pure $ TheseTable mc md