Instead of trying to extract a binding from the previous subquery upo…

…n which to laterally depend, we instead explicitly add a call to `random()` if necessary. `random()`'s volatility will force Postgres' optimiser not to optimise away a reference to what it would otherwise believe to be a constant.

src/Rel8.hs

@@ -267,7 +267,7 @@ module Rel8
 
     -- ** Sequences
   , nextval
-  , eval
+  , evaluate
 
     -- * Implementation details
   , Labelable

src/Rel8/Query.hs

@@ -9,15 +9,20 @@ where
 import Control.Applicative ( liftA2 )
 import Control.Monad ( liftM2 )
 import Data.Kind ( Type )
+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
+import Data.Monoid ( Any( Any ) )
 import Prelude
 
 -- opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+import qualified Opaleye.Internal.PackMap as Opaleye
+import qualified Opaleye.Internal.PrimQuery as Opaleye
 import qualified Opaleye.Internal.QueryArr as Opaleye
+import qualified Opaleye.Internal.Tag as Opaleye
 
 -- rel8
 import Rel8.Query.Set ( unionAll )
-import Rel8.Query.Opaleye ( fromOpaleye, withSymbols )
+import Rel8.Query.Opaleye ( fromOpaleye )
 import Rel8.Query.Values ( values )
 import Rel8.Table.Alternative
   ( AltTable, (<|>:)
@@ -32,11 +37,11 @@ import Data.Functor.Bind ( Bind, (>>-) )
 -- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
 -- semantics similar to the list (@[]@) monad.
 type Query :: Type -> Type
-newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select a)
+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
 
 
 instance Functor Query where
-  fmap f (Query a) = Query (fmap (fmap f) a)
+  fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
 
 
 instance Apply Query where
@@ -53,15 +58,33 @@ instance Bind Query where
 
 
 instance Monad Query where
-  Query q >>= f = Query $ \exprs -> do
-    (symbols, a) <- withSymbols (q exprs)
+  Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, query, tag) ->
     let
-      exprs' =
-        case symbols of
-          [] -> exprs
-          symbol : _ -> Opaleye.AttrExpr symbol : exprs
-    case f a of
-      Query q' -> q' exprs'
+      Opaleye.QueryArr qa = q dummies
+      ((m, a), query', tag') = qa ((), query, tag)
+      Query q' = f a
+      (dummies', lquery, tag'') =
+        ( dummy : dummies
+        , Opaleye.Rebind True bindings query'
+        , Opaleye.next tag'
+        )
+        where
+          (dummy, bindings) = Opaleye.run $ name random
+            where
+              random = Opaleye.FunExpr "random" []
+              name = Opaleye.extractAttr "dummy" tag'
+      Opaleye.QueryArr qa' = q' dummies'
+      ((m'@(Any needsDummies), b), rquery, tag''') = qa' ((), Opaleye.Unit, tag'')
+      lquery'
+        | needsDummies = lquery
+        | otherwise = query'
+      query'''' =
+        Opaleye.Product
+          ((Opaleye.NonLateral, lquery') :| [(Opaleye.Lateral, rquery)])
+          []
+      m'' = m <> m'
+    in
+      ((m'', b), query'''', tag''')
 
 
 -- | '<|>:' = 'unionAll'.

src/Rel8/Query.hs-boot

@@ -7,6 +7,7 @@ where
 
 -- base
 import Data.Kind ( Type )
+import Data.Monoid ( Any )
 import Prelude ()
 
 -- opaleye
@@ -15,4 +16,4 @@ import qualified Opaleye.Select as Opaleye
 
 
 type Query :: Type -> Type
-newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select a)
+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))

src/Rel8/Query/Evaluate.hs

@@ -1,7 +1,8 @@
 {-# language FlexibleContexts #-}
+{-# language TupleSections #-}
 
 module Rel8.Query.Evaluate
-  ( eval
+  ( evaluate
   , rebind
   )
 where
@@ -10,6 +11,7 @@ where
 import Control.Monad ( (>=>) )
 import Data.Foldable ( foldl' )
 import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )
+import Data.Monoid ( Any( Any ) )
 import Prelude hiding ( undefined )
 
 -- opaleye
@@ -31,24 +33,22 @@ import Rel8.Table.Opaleye ( unpackspec )
 import Rel8.Table.Undefined
 
 
--- | 'eval' takes expressions that could potentially have side effects and
--- \"runs\" them in the 'Query' monad. The returned expressions have no
--- side effetcs and can safely be reused.
-eval :: Table Expr a => a -> Query a
-eval = laterally >=> rebind
+-- | 'evaluate' takes expressions that could potentially have side effects and
+-- \"runs\" them in the 'Query' monad. The returned expressions have no side
+-- effects and can safely be reused.
+evaluate :: Table Expr a => a -> Query a
+evaluate = laterally >=> rebind
 
 
 laterally :: Table Expr a => a -> Query a
-laterally a = Query $ \bindings -> pure $ case nonEmpty bindings of
-  Nothing -> a
-  Just bindings' -> case_ [(condition, a)] undefined
-    where
-      condition = foldl1' (&&.) (fmap go bindings')
-        where
-          go expr =
-            fromPrimExpr $ Opaleye.BinExpr Opaleye.OpOr
-              (Opaleye.UnExpr Opaleye.OpIsNull expr)
-              (Opaleye.UnExpr Opaleye.OpIsNotNull expr)
+laterally a = Query $ \bindings -> pure $ (Any True,) $
+  case nonEmpty bindings of
+    Nothing -> a
+    Just bindings' -> case_ [(condition, a)] undefined
+      where
+        condition = foldl1' (&&.) (fmap go bindings')
+          where
+            go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
 
 
 rebind :: Table Expr a => a -> Query a
@@ -58,7 +58,7 @@ rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, query, tag) ->
     (a', bindings) = Opaleye.run $
       Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
   in
-    (a', Opaleye.Rebind True bindings query, tag')
+    ((mempty, a'), Opaleye.Rebind True bindings query, tag')
 
 
 foldl1' :: (a -> a -> a) -> NonEmpty a -> a

src/Rel8/Query/Opaleye.hs

@@ -1,79 +1,62 @@
-{-# language LambdaCase #-}
+{-# language TupleSections #-}
 
 module Rel8.Query.Opaleye
   ( fromOpaleye
   , toOpaleye
   , mapOpaleye
   , zipOpaleyeWith
-  , withSymbols
   )
 where
 
 -- base
 import Control.Applicative ( liftA2 )
-import Data.Bifunctor ( first )
 import Prelude
 
 -- opaleye
-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
-import qualified Opaleye.Internal.PrimQuery as Opaleye
 import qualified Opaleye.Internal.QueryArr as Opaleye
 
 -- rel8
 import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
 
 
 fromOpaleye :: Opaleye.Select a -> Query a
-fromOpaleye = Query . const
+fromOpaleye = Query . pure . fmap pure
 
 
 toOpaleye :: Query a -> Opaleye.Select a
-toOpaleye (Query a) = a []
+toOpaleye (Query a) = snd <$> a mempty
 
 
 mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
-mapOpaleye f (Query a) = Query (fmap f a)
+mapOpaleye f (Query a) = Query (fmap (mapping f) a)
 
 
 zipOpaleyeWith :: ()
   => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
   -> Query a -> Query b -> Query c
-zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 f a b
-
-
-withSymbols :: Opaleye.Select a -> Opaleye.Select ([Opaleye.Symbol], a)
-withSymbols = fmap (first extractSymbols) . withPrimQuery
-
-
-withPrimQuery :: Opaleye.Select a -> Opaleye.Select (Opaleye.PrimQuery, a)
-withPrimQuery (Opaleye.QueryArr q) = Opaleye.QueryArr $ \(_, query, tag) ->
-  case q ((), query, tag) of
-    (a, query', tag') -> ((query', a), query', tag')
-
-
-extractSymbols :: Opaleye.PrimQuery -> [Opaleye.Symbol]
-extractSymbols = \case
-  Opaleye.Unit -> []
-  Opaleye.Empty _ -> []
-  Opaleye.BaseTable _ bindings -> map fst bindings
-  Opaleye.Product as _ -> foldMap (foldMap extractSymbols) as
-  Opaleye.Aggregate bindings _ -> map fst bindings
-  Opaleye.DistinctOnOrderBy _ _ query -> extractSymbols query
-  Opaleye.Limit _ query -> extractSymbols query
-  Opaleye.Join _ _ bindings bindings' query query' ->
-    map fst bindings <>
-    map fst bindings' <>
-    extractSymbols query <>
-    extractSymbols query'
-  Opaleye.Exists _ query _ -> extractSymbols query
-  Opaleye.Values symbols _ -> symbols
-  Opaleye.Binary _ (query, query') ->
-    extractSymbols query <>
-    extractSymbols query'
-  Opaleye.Label _ query -> extractSymbols query
-  Opaleye.RelExpr _ bindings -> map fst bindings
-  Opaleye.Rebind False bindings _ -> map fst bindings
-  Opaleye.Rebind True bindings query ->
-    map fst bindings <>
-    extractSymbols query
-  Opaleye.ForUpdate query -> extractSymbols query
+zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
+
+
+mapping :: ()
+  => (Opaleye.Select a -> Opaleye.Select b)
+  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
+mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, query, tag) ->
+  let
+    ((m, _), _, _) = qa ((), query, tag)
+    Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
+  in
+    qa' ((), query, tag)
+
+
+zipping :: Semigroup m
+  => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
+  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
+zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
+  Opaleye.QueryArr $ \(_, query, tag) ->
+    let
+      ((m, _), _, _) = qa ((), query, tag)
+      ((m', _), _, _) = qa' ((), query, tag)
+      m'' = m <> m'
+      Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
+    in
+      qa'' ((), query, tag)