git.iko.soy/rel8
on 134ddcf help sign in
rel8/src/Rel8/Query/Maybe.hs
103 lines 3.6 kB history raw
1module Rel8.Query.Maybe
2 ( optional
3 , catMaybeTable
4 , bindMaybeTable
5 , traverseMaybeTable
6 )
7where
9-- base
10import Prelude
12-- opaleye
13import qualified Opaleye.Internal.PackMap as Opaleye
14import qualified Opaleye.Internal.PrimQuery as Opaleye
15import qualified Opaleye.Internal.QueryArr as Opaleye
16import qualified Opaleye.Internal.Tag as Opaleye
17import qualified Opaleye.Internal.Unpackspec as Opaleye
19-- rel8
20import Rel8.Expr.Bool ( true )
21import Rel8.Expr.Eq ( (==.) )
22import Rel8.Expr.Opaleye ( toPrimExpr )
23import Rel8.Query ( Query )
24import Rel8.Query.Filter ( where_ )
25import Rel8.Query.Opaleye ( mapOpaleye )
26import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27import Rel8.Table.Opaleye ( unpackspec )
30optional :: Query a -> Query (MaybeTable a)
31optional = mapOpaleye $ Opaleye.QueryArr . go
32 where
33 go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
34 where
35 (MaybeTable t a, right, tag') =
36 Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
37 (t', bindings) = Opaleye.run $
38 Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
39 join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
40 condition = toPrimExpr true
43catMaybeTable :: MaybeTable a -> Query a
44catMaybeTable ma@(MaybeTable _ a) = do
45 where_ $ isJustTable ma
46 pure a
49-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
50-- allows you to "extend" an optional query with another query. If either the
51-- input or output are 'noTable', then the result is 'noTable'.
52--
53-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
54-- resulting @MaybeTable@s.
55--
56-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< optional (values [lit True])
57-- [Just False]
58--
59-- >>> select c $ bindMaybeTable (\_ -> return (noTable :: MaybeTable (Expr Bool))) =<< optional (values [lit True])
60-- [Nothing]
61--
62-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< return (noTable :: MaybeTable (Expr Bool))
63-- [Nothing]
64bindMaybeTable :: Monad m
65 => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
66bindMaybeTable query (MaybeTable input a) = do
67 MaybeTable output b <- query a
68 pure $ MaybeTable (input <> output) b
71-- | Extend an optional query with another query. This is useful if you want
72-- to step through multiple @LEFT JOINs@.
73--
74-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
75-- you also have the ability to "expand" one row into multiple rows.
76--
77-- >>> :{
78-- duplicate :: Expr Bool -> Query (Expr Bool)
79-- duplicate x = unionAll (return x) (return x)
80-- :}
81--
82-- >>> select c $ traverseMaybeTable duplicate =<< optional (values [lit True])
83-- [Just True,Just True]
84--
85-- Note that if the @a -> Query b@ function returns no rows, then the resulting
86-- query will also have no rows:
87--
88-- >>> select c $ traverseMaybeTable (limit 0 . pure) =<< optional (values [lit True])
89-- []
90--
91-- However, regardless of the given @a -> Query b@ function, if the input is
92-- @noTable@, you will always get exactly one @noTable@ back:
93--
94-- >>> select c $ traverseMaybeTable duplicate (noTable :: MaybeTable (Expr Bool))
95-- [Nothing]
96--
97-- >>> select c $ traverseMaybeTable (limit 0 . pure) (noTable :: MaybeTable (Expr Bool))
98-- [Nothing]
99traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
100traverseMaybeTable query ma@(MaybeTable input _) = do
101 MaybeTable output b <- optional (query =<< catMaybeTable ma)
102 where_ $ output ==. input
103 pure $ MaybeTable input b