git.iko.soy/rel8
on master help sign in
Simplify `eval` to run directly inside the `Query` monad
d630639Shane O'Brien
src/Rel8.hs−3
compare with master
unifiedsplit
@@ -267,9 +267,6 @@ module Rel8
267
267
268 -- ** Sequences
268 -- ** Sequences
269 , nextval
269 , nextval
270−
271− , Evaluate
272− , eval
273 , evaluate
270 , evaluate
274
271
275 -- * Implementation details
272 -- * Implementation details
src/Rel8/Query.hs+163−7
@@ -1,5 +1,3 @@
1−{-# language DerivingVia #-}
2−{-# language GeneralizedNewtypeDeriving #-}
3{-# language StandaloneKindSignatures #-}
1{-# language StandaloneKindSignatures #-}
4
2
5module Rel8.Query
3module Rel8.Query
@@ -8,14 +6,22 @@ module Rel8.Query
8where
6where
9
7
10-- base
8-- base
9+import Control.Applicative ( liftA2 )
10+import Control.Monad ( liftM2 )
11import Data.Kind ( Type )
11import Data.Kind ( Type )
12+import Data.Monoid ( Any( Any ) )
12import Prelude
13import Prelude
13
14
14-- opaleye
15-- opaleye
15−import qualified Opaleye.Select as Opaleye
16+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
17+import qualified Opaleye.Internal.PackMap as Opaleye
18+import qualified Opaleye.Internal.PrimQuery as Opaleye
19+import qualified Opaleye.Internal.QueryArr as Opaleye
20+import qualified Opaleye.Internal.Tag as Opaleye
16
21
17-- rel8
22-- rel8
18import Rel8.Query.Set ( unionAll )
23import Rel8.Query.Set ( unionAll )
24+import Rel8.Query.Opaleye ( fromOpaleye )
19import Rel8.Query.Values ( values )
25import Rel8.Query.Values ( values )
20import Rel8.Table.Alternative
26import Rel8.Table.Alternative
21 ( AltTable, (<|>:)
27 ( AltTable, (<|>:)
@@ -23,22 +29,172 @@ import Rel8.Table.Alternative
23 )
29 )
24
30
25-- semigroupoids
31-- semigroupoids
26−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
32+import Data.Functor.Apply ( Apply, (<.>) )
27import Data.Functor.Bind ( Bind, (>>-) )
33import Data.Functor.Bind ( Bind, (>>-) )
28
34
29
35
30-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
36-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
31-- semantics similar to the list (@[]@) monad.
37-- semantics similar to the list (@[]@) monad.
32type Query :: Type -> Type
38type Query :: Type -> Type
33−newtype Query a = Query (Opaleye.Select a)
39+newtype Query a =
34− deriving newtype (Functor, Applicative, Monad)
40+ Query (
35− deriving Apply via (WrappedApplicative Opaleye.Select)
41+ -- This is based on Opaleye's Select monad, but with two addtions. We
42+ -- maintain a stack of PrimExprs from parent previous subselects. In
43+ -- practice, these are always the results of dummy calls to random().
44+ --
45+ -- We also return a Bool that indicates to the parent subselect whether
46+ -- or not that stack of PrimExprs were used at any point. If they weren't,
47+ -- then the call to random() is never added to the query.
48+ --
49+ -- This is all needed to implement evaluate. Consider the following code:
50+ --
51+ -- do
52+ -- x <- values [lit 'a', lit 'b', lit 'c']
53+ -- y <- evaluate $ nextval "user_id_seq"
54+ -- pure (x, y)
55+ --
56+ -- If we just used Opaleye's Select monad directly, the SQL would come out
57+ -- like this:
58+ --
59+ -- SELECT
60+ -- a, b
61+ -- FROM
62+ -- (VALUES ('a'), ('b'), ('c')) Q1(a),
63+ -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);
64+ --
65+ -- From the Haskell code, you would intuitively expect to get back the
66+ -- results of three different calls to nextval(), but from Postgres' point
67+ -- of view, because the Q2 subquery doesn't reference anything from the Q1
68+ -- query, it thinks it only needs to call nextval() once. This is actually
69+ -- exactly the same problem you get with the deprecated ListT IO monad from
70+ -- the transformers package — *> behaves differently to >>=, so
71+ -- using ApplicativeDo can change the results of a program. ApplicativeDo
72+ -- is exactly the optimisation Postgres does on a "LATERAL" query that
73+ -- doesn't make any references to previous subselects.
74+ --
75+ -- Rel8's solution is generate the following SQL instead:
76+ --
77+ -- SELECT
78+ -- a, b
79+ -- FROM
80+ -- (SELECT
81+ -- random() AS dummy,
82+ -- *
83+ -- FROM
84+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
85+ -- LATERAL (SELECT
86+ -- CASE
87+ -- WHEN dummy IS NOT NULL
88+ -- THEN nextval('user_id_seq')
89+ -- END) Q2(b);
90+ --
91+ -- We use random() here as the dummy value (and not some constant) because
92+ -- Postgres will again optimize if it sees that a value is constant
93+ -- (and thus only call nextval() once), but because random() is marked as
94+ -- VOLATILE, this inhibits Postgres from doing that optimisation.
95+ --
96+ -- Why not just reference the a column from the previous query directly
97+ -- instead of adding a dummy value? Basically, even if we extract out all
98+ -- the bindings introduced in a PrimQuery, we can't always be sure which
99+ -- ones refer to constant values, so if we end up laterally referencing a
100+ -- constant value, then all of this would be for nothing.
101+ --
102+ -- Why not just add the call to the previous subselect directly, like so:
103+ --
104+ -- SELECT
105+ -- a, b
106+ -- FROM
107+ -- (SELECT
108+ -- nextval('user_id_seq') AS eval,
109+ -- *
110+ -- FROM
111+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
112+ -- LATERAL (SELECT eval) Q2(b);
113+ --
114+ -- That would work in this case. But consider the following Rel8 code:
115+ --
116+ -- do
117+ -- x <- values [lit 'a', lit 'b', lit 'c']
118+ -- y <- values [lit 'd', lit 'e', lit 'f']
119+ -- z <- evaluate $ nextval "user_id_seq"
120+ -- pure (x, y, z)
121+ --
122+ -- How many calls to nextval should there be? Our Haskell intuition says
123+ -- nine. But that's not what you would get if you used the above
124+ -- technique. The problem is, which VALUES query should the nextval be
125+ -- added to? You can choose one or the other to get three calls to
126+ -- nextval, but you still need to make a superfluous LATERAL references to
127+ -- the other if you want nine calls. So for the above Rel8 code we generate
128+ -- the following SQL:
129+ --
130+ -- SELECT
131+ -- a, b, c
132+ -- FROM
133+ -- (SELECT
134+ -- random() AS dummy,
135+ -- *
136+ -- FROM
137+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
138+ -- (SELECT
139+ -- random() AS dummy,
140+ -- *
141+ -- FROM
142+ -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,
143+ -- LATERAL (SELECT
144+ -- CASE
145+ -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL
146+ -- THEN nextval('user_id_seq')
147+ -- END) Q3(c);
148+ --
149+ -- This gives nine calls to nextval() as we would expect.
150+ [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)
151+ )
152+
153+
154+instance Functor Query where
155+ fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
156+
157+
158+instance Apply Query where
159+ (<.>) = (<*>)
160+
161+
162+instance Applicative Query where
163+ pure = fromOpaleye . pure
164+ liftA2 = liftM2
36
165
37
166
38instance Bind Query where
167instance Bind Query where
39 (>>-) = (>>=)
168 (>>-) = (>>=)
40
169
41
170
171+instance Monad Query where
172+ Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, query, tag) ->
173+ let
174+ Opaleye.QueryArr qa = q dummies
175+ ((m, a), query', tag') = qa ((), query, tag)
176+ Query q' = f a
177+ (dummies', lquery, tag'') =
178+ ( dummy : dummies
179+ , Opaleye.Rebind True bindings query'
180+ , Opaleye.next tag'
181+ )
182+ where
183+ (dummy, bindings) = Opaleye.run $ name random
184+ where
185+ random = Opaleye.FunExpr "random" []
186+ name = Opaleye.extractAttr "dummy" tag'
187+ Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'
188+ ((m'@(Any needsDummies), b), rquery, tag''') = qa' ((), Opaleye.Unit, tag'')
189+ lquery'
190+ | needsDummies = lquery
191+ | otherwise = query'
192+ query'''' = Opaleye.times lquery' rquery
193+ m'' = m <> m'
194+ in
195+ ((m'', b), query'''', tag''')
196+
197+
42-- | '<|>:' = 'unionAll'.
198-- | '<|>:' = 'unionAll'.
43instance AltTable Query where
199instance AltTable Query where
44 (<|>:) = unionAll
200 (<|>:) = unionAll
src/Rel8/Query.hs-boot+3−1
@@ -7,11 +7,13 @@ where
7
7
8-- base
8-- base
9import Data.Kind ( Type )
9import Data.Kind ( Type )
10+import Data.Monoid ( Any )
10import Prelude ()
11import Prelude ()
11
12
12-- opaleye
13-- opaleye
14+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
13import qualified Opaleye.Select as Opaleye
15import qualified Opaleye.Select as Opaleye
14
16
15
17
16type Query :: Type -> Type
18type Query :: Type -> Type
17−newtype Query a = Query (Opaleye.Select a)
19+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
src/Rel8/Query/Evaluate.hs+36−50
@@ -1,20 +1,18 @@
1−{-# language DerivingStrategies #-}
2{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
3−{-# language GeneralizedNewtypeDeriving #-}
2+{-# language TupleSections #-}
4−{-# language NamedFieldPuns #-}
5−{-# language StandaloneKindSignatures #-}
6
3
7module Rel8.Query.Evaluate
4module Rel8.Query.Evaluate
8− ( Evaluate
9− , eval
10− , evaluate
5+ ( evaluate
6+ , rebind
11 )
7 )
12where
8where
13
9
14-- base
10-- base
15−import Data.Kind ( Type )
11+import Control.Monad ( (>=>) )
12+import Data.Foldable ( foldl' )
13+import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )
16−import Data.Monoid ( Endo ( Endo ), appEndo )
14+import Data.Monoid ( Any( Any ) )
17−import Prelude
15+import Prelude hiding ( undefined )
18
16
19-- opaleye
17-- opaleye
20import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
18import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
@@ -26,57 +24,45 @@ import qualified Opaleye.Internal.Unpackspec as Opaleye
26
24
27-- rel8
25-- rel8
28import Rel8.Expr ( Expr )
26import Rel8.Expr ( Expr )
27+import Rel8.Expr.Bool ( (&&.) )
28+import Rel8.Expr.Opaleye ( fromPrimExpr )
29import Rel8.Query ( Query( Query ) )
29import Rel8.Query ( Query( Query ) )
30import Rel8.Table ( Table )
30import Rel8.Table ( Table )
31+import Rel8.Table.Bool ( case_ )
31import Rel8.Table.Opaleye ( unpackspec )
32import Rel8.Table.Opaleye ( unpackspec )
33+import Rel8.Table.Undefined
32
34
33−-- semigroupoids
34−import Data.Functor.Apply ( Apply )
35−import Data.Functor.Bind ( Bind, (>>-) )
36
35
37−-- transformers
36+-- | 'evaluate' takes expressions that could potentially have side effects and
38−import Control.Monad.Trans.State.Strict ( State, get, put, runState )
37+-- \"runs\" them in the 'Query' monad. The returned expressions have no side
38+-- effects and can safely be reused.
39+evaluate :: Table Expr a => a -> Query a
40+evaluate = laterally >=> rebind
39
41
40
42
41−type Evaluations :: Type
43+laterally :: Table Expr a => a -> Query a
42−data Evaluations = Evaluations
44+laterally a = Query $ \bindings -> pure $ (Any True,) $
43− { tag :: !Opaleye.Tag
45+ case nonEmpty bindings of
44− , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))
46+ Nothing -> a
45− }
47+ Just bindings' -> case_ [(condition, a)] undefined
48+ where
49+ condition = foldl1' (&&.) (fmap go bindings')
50+ where
51+ go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
46
52
47
53
48−-- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects,
54+-- | 'rebind' takes some expressions, and binds each of them to a new
49−-- breaking the referential transparency we would otherwise enjoy.
55+-- variable in the SQL. The @a@ returned consists only of these
50−--
56+-- variables. It's essentially a @let@ binding for Postgres expressions.
51−-- To try to recover our ability to reason about such expressions, 'Evaluate'
52−-- allows us to control the evaluation order of side-effects by sequencing
53−-- them monadically.
54−type Evaluate :: Type -> Type
55−newtype Evaluate a = Evaluate (State Evaluations a)
56− deriving newtype (Functor, Apply, Applicative, Monad)
57−
58−
59−instance Bind Evaluate where
60− (>>-) = (>>=)
61−
62−
63−-- | 'eval' takes expressions that could potentially have side effects and
64−-- \"runs\" them in the 'Evaluate' monad. The returned expressions have no
65−-- side effetcs and can safely be reused.
66−eval :: Table Expr a => a -> Evaluate a
57+rebind :: Table Expr a => a -> Query a
67−eval a = Evaluate $ do
58+rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, query, tag) ->
68− Evaluations {tag, bindings} <- get
69 let
59 let
70 tag' = Opaleye.next tag
60 tag' = Opaleye.next tag
71− (a', bindings') = Opaleye.run $
61+ (a', bindings) = Opaleye.run $
72 Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
62 Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
73− put Evaluations {tag = tag', bindings = bindings <> Endo (bindings' ++)}
63+ in
74− pure a'
64+ ((mempty, a'), Opaleye.Rebind True bindings query, tag')
75
65
76
66
77−-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.
67+foldl1' :: (a -> a -> a) -> NonEmpty a -> a
78−evaluate :: Evaluate a -> Query a
68+foldl1' f (a :| as) = foldl' f a as
79−evaluate (Evaluate m) = Query $ Opaleye.QueryArr $ \(_, query, tag) ->
80− case runState m (Evaluations tag mempty) of
81− (a, Evaluations {tag = tag', bindings}) ->
82− (a, Opaleye.Rebind True (appEndo bindings mempty) query, tag')
src/Rel8/Query/Opaleye.hs+33−5
@@ -1,3 +1,5 @@
1+{-# language TupleSections #-}
2+
1module Rel8.Query.Opaleye
3module Rel8.Query.Opaleye
2 ( fromOpaleye
4 ( fromOpaleye
3 , toOpaleye
5 , toOpaleye
@@ -7,28 +9,54 @@ module Rel8.Query.Opaleye
7where
9where
8
10
9-- base
11-- base
12+import Control.Applicative ( liftA2 )
10import Prelude
13import Prelude
11
14
12-- opaleye
15-- opaleye
13−import qualified Opaleye.Select as Opaleye
16+import qualified Opaleye.Internal.QueryArr as Opaleye
14
17
15-- rel8
18-- rel8
16import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
19import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
17
20
18
21
19fromOpaleye :: Opaleye.Select a -> Query a
22fromOpaleye :: Opaleye.Select a -> Query a
20−fromOpaleye = Query
23+fromOpaleye = Query . pure . fmap pure
21
24
22
25
23toOpaleye :: Query a -> Opaleye.Select a
26toOpaleye :: Query a -> Opaleye.Select a
24−toOpaleye (Query a) = a
27+toOpaleye (Query a) = snd <$> a mempty
25
28
26
29
27mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
30mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
28−mapOpaleye f = fromOpaleye . f . toOpaleye
31+mapOpaleye f (Query a) = Query (fmap (mapping f) a)
29
32
30
33
31zipOpaleyeWith :: ()
34zipOpaleyeWith :: ()
32 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
35 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
33 -> Query a -> Query b -> Query c
36 -> Query a -> Query b -> Query c
34−zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
37+zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
38+
39+
40+mapping :: ()
41+ => (Opaleye.Select a -> Opaleye.Select b)
42+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
43+mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, query, tag) ->
44+ let
45+ ((m, _), _, _) = qa ((), query, tag)
46+ Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
47+ in
48+ qa' ((), query, tag)
49+
50+
51+zipping :: Semigroup m
52+ => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
53+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
54+zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
55+ Opaleye.QueryArr $ \(_, query, tag) ->
56+ let
57+ ((m, _), _, _) = qa ((), query, tag)
58+ ((m', _), _, _) = qa' ((), query, tag)
59+ m'' = m <> m'
60+ Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
61+ in
62+ qa'' ((), query, tag)
tests/Main.hs+51
@@ -121,6 +121,7 @@ tests =
121 , testSelectNestedPairs getTestDatabase
121 , testSelectNestedPairs getTestDatabase
122 , testSelectArray getTestDatabase
122 , testSelectArray getTestDatabase
123 , testNestedMaybeTable getTestDatabase
123 , testNestedMaybeTable getTestDatabase
124+ , testEvaluate getTestDatabase
124 ]
125 ]
125
126
126 where
127 where
@@ -132,6 +133,7 @@ tests =
132 flip run conn do
133 flip run conn do
133 sql "CREATE EXTENSION citext"
134 sql "CREATE EXTENSION citext"
134 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
136+ sql "CREATE SEQUENCE test_seq"
135
137
136 return db
138 return db
137
139
@@ -728,3 +730,52 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
728 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
730 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
729
731
730 selected === [True]
732 selected === [True]
733+
734+
735+testEvaluate :: IO TmpPostgres.DB -> TestTree
736+testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
737+
738+ transaction \connection -> do
739+ selected <- liftIO $ Rel8.select connection do
740+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
741+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
742+ pure (x, (y, y))
743+
744+ normalize selected ===
745+ [ ('a', (0, 0))
746+ , ('b', (1, 1))
747+ , ('c', (2, 2))
748+ ]
749+
750+ selected' <- liftIO $ Rel8.select connection do
751+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
752+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
753+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
754+ pure ((x, y), (z, z))
755+
756+ normalize selected' ===
757+ [ (('a', 'd'), (0, 0))
758+ , (('b', 'd'), (1, 1))
759+ , (('c', 'd'), (2, 2))
760+ , (('a', 'e'), (3, 3))
761+ , (('b', 'e'), (4, 4))
762+ , (('c', 'e'), (5, 5))
763+ , (('a', 'f'), (6, 6))
764+ , (('b', 'f'), (7, 7))
765+ , (('c', 'f'), (8, 8))
766+ ]
767+
768+ where
769+ normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
770+ normalize [] = []
771+ normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
772+
773+{-
774+ selected <- liftIO $ Rel8.select connection do
775+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
776+ x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
777+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
778+ pure (x, y, y)
779+
780+ selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
781+-}