git.iko.soy/rel8
on ae4607a help sign in
rel8/src/Rel8/Query/These.hs
138 lines 4.4 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-- comonad
19import Control.Comonad ( extract )
21-- opaleye
22import qualified Opaleye.Internal.PackMap as Opaleye
23import qualified Opaleye.Internal.PrimQuery as Opaleye
24import qualified Opaleye.Internal.QueryArr as Opaleye
25import qualified Opaleye.Internal.Tag as Opaleye
27-- rel8
28import Rel8.Expr ( Expr )
29import Rel8.Expr.Bool ( boolExpr, not_ )
30import Rel8.Expr.Eq ( (==.) )
31import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
32import Rel8.Expr.Serialize ( litExpr )
33import Rel8.Query ( Query )
34import Rel8.Query.Filter ( where_ )
35import Rel8.Query.Maybe ( optional )
36import Rel8.Query.Opaleye ( zipOpaleyeWith )
37import Rel8.Table.Either ( EitherTable( EitherTable ) )
38import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
39import Rel8.Table.These
40 ( TheseTable( TheseTable, here, there )
41 , hasHereTable, hasThereTable
42 , isThisTable, isThatTable, isThoseTable
43 )
44import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
47-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
48alignBy :: ()
49 => (a -> b -> Expr Bool)
50 -> Query a -> Query b -> Query (TheseTable Expr a b)
51alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
52 (_, tag) -> (tab, join', tag''')
53 where
54 (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
55 (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
56 MaybeTable hasHere a = ma
57 MaybeTable hasThere b = mb
58 (hasHere', lbindings) = Opaleye.run $ do
59 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
60 (hasThere', rbindings) = Opaleye.run $ do
61 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
62 tag''' = Opaleye.next tag''
63 join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
64 where
65 on = toPrimExpr $ condition (extract a) (extract b)
66 left'' = (lateral, Opaleye.Rebind True lbindings left')
67 right'' = (lateral, Opaleye.Rebind True rbindings right')
68 ma' = MaybeTable hasHere' a
69 mb' = MaybeTable hasThere' b
70 tab = TheseTable {here = ma', there = mb'}
71 join' lateral input = Opaleye.times lateral input (join lateral)
74keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
75keepHereTable = loseThatTable
78loseHereTable :: TheseTable Expr a b -> Query b
79loseHereTable = keepThatTable
82keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
83keepThereTable = loseThisTable
86loseThereTable :: TheseTable Expr a b -> Query a
87loseThereTable = keepThisTable
90keepThisTable :: TheseTable Expr a b -> Query a
91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
92 where_ $ isThisTable t
93 pure (extract a)
96loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
98 where_ $ not_ $ isThisTable t
99 pure (ma, extract b)
102keepThatTable :: TheseTable Expr a b -> Query b
103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
104 where_ $ isThatTable t
105 pure (extract b)
108loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
110 where_ $ not_ $ isThatTable t
111 pure (extract a, mb)
114keepThoseTable :: TheseTable Expr a b -> Query (a, b)
115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
116 where_ $ isThoseTable t
117 pure (extract a, extract b)
120loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122 where_ $ not_ $ isThoseTable t
123 pure $ EitherTable tag a b
124 where
125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
128bitraverseTheseTable :: ()
129 => (a -> Query c)
130 -> (b -> Query d)
131 -> TheseTable Expr a b
132 -> Query (TheseTable Expr c d)
133bitraverseTheseTable f g t = do
134 mc <- optional (f . fst =<< keepHereTable t)
135 md <- optional (g . snd =<< keepThereTable t)
136 where_ $ isJustTable mc ==. hasHereTable t
137 where_ $ isJustTable md ==. hasThereTable t
138 pure $ TheseTable mc md