The Tag shouldn't depend on the PrimQuery

opaleye.cabal

@@ -85,7 +85,6 @@ library
                    Opaleye.Internal.Inferrable,
                    Opaleye.Internal.Join,
                    Opaleye.Internal.JSONBuildObjectFields,
-                   Opaleye.Internal.Label,
                    Opaleye.Internal.Lateral,
                    Opaleye.Internal.Map,
                    Opaleye.Internal.Manipulation,

src/Opaleye/Internal/Join.hs

@@ -70,13 +70,13 @@ leftJoinAExplicit :: U.Unpackspec a a
                   -> Q.Query a
                   -> Q.QueryArr (a -> Column T.PGBool) nullableA
 leftJoinAExplicit uA nullmaker rq =
-  Q.QueryArr $ \(p, primQueryL, t1) ->
+  Q.QueryArr $ \(p, t1) ->
     let (columnsR, primQueryR, t2) = Q.runSimpleQueryArr rq ((), t1)
         (newColumnsR, ljPEsR) = PM.run $ U.runUnpackspec uA (extractLeftJoinFields 2 t2) columnsR
         renamedNullable = toNullable nullmaker newColumnsR
         Column cond = p newColumnsR
     in ( renamedNullable
-       , PQ.Join
+       , \primQueryL -> PQ.Join
            PQ.LeftJoin
            cond
            []

src/Opaleye/Internal/Locking.hs

@@ -22,4 +22,5 @@ import qualified Opaleye.Internal.PrimQuery as PQ
 -- easy to create queries that fail at run time using this operation.
 forUpdate :: Q.Select a -> Q.Select a
 forUpdate s =
-  Q.QueryArr ((\(a, pq, t) -> (a, PQ.ForUpdate pq, t)) . Q.runQueryArr s)
+  Q.QueryArr ((\(a, pqf, t') -> (a, PQ.ForUpdate . pqf, t'))
+              . Q.runEndoQueryArr s)

src/Opaleye/Internal/MaybeFields.hs

@@ -131,7 +131,7 @@ optional = Opaleye.Internal.Lateral.laterally optionalSelect
     optionalSelect :: Select a -> Select (MaybeFields a)
     optionalSelect = IQ.QueryArr . go
 
-    go query ((), left, tag) = (MaybeFields present a, join, Tag.next tag')
+    go query ((), tag) = (MaybeFields present a, join, Tag.next tag')
       where
         (MaybeFields t a, right, tag') =
           IQ.runSimpleQueryArr (justFields <$> query) ((), tag)
@@ -140,7 +140,7 @@ optional = Opaleye.Internal.Lateral.laterally optionalSelect
 
         (t', bindings) =
           PM.run (U.runUnpackspec U.unpackspecField (PM.extractAttr "maybe" tag') t)
-        join = PQ.Join PQ.LeftJoin true [] bindings left right
+        join left = PQ.Join PQ.LeftJoin true [] bindings left right
     true = HPQ.ConstExpr (HPQ.BoolLit True)
     isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull
 

src/Opaleye/Internal/Operators.hs

@@ -23,7 +23,7 @@ import qualified Data.Profunctor.Product.Default as D
 
 restrict :: S.SelectArr (F.Field T.SqlBool) ()
 restrict = QA.QueryArr f where
-  f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)
+  f (Column predicate, t0) = ((), PQ.restrict predicate, t0)
 
 infix 4 .==
 (.==) :: forall columns. D.Default EqPP columns columns

src/Opaleye/Internal/QueryArr.hs

@@ -28,22 +28,27 @@ import qualified Data.Profunctor.Product as PP
 -- of type @a@.
 --
 -- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.
-newtype SelectArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag))
+newtype SelectArr a b = QueryArr ((a, Tag) -> (b, PQ.PrimQuery -> PQ.PrimQuery, Tag))
 
 type QueryArr = SelectArr
 type Query = SelectArr ()
 
 productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
 productQueryArr f = QueryArr g
-  where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1)
+  where g (a0, t0) = (a1, \primQuery -> PQ.times primQuery primQuery', t1)
           where (a1, primQuery', t1) = f (a0, t0)
 
 {-# DEPRECATED simpleQueryArr "Use 'productQueryArr' instead. Its name indicates better what it actually does" #-}
 simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
 simpleQueryArr = productQueryArr
 
 runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)
-runQueryArr (QueryArr f) = f
+runQueryArr (QueryArr f) = \(a, pq, t) ->
+  let (b, pqf, t') = f (a, t)
+  in (b, pqf pq, t')
+
+runEndoQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery -> PQ.PrimQuery, Tag)
+runEndoQueryArr (QueryArr f) = f
 
 runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)
 runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t)
@@ -77,10 +82,10 @@ type Select = SelectArr ()
 lateral :: (i -> Select a) -> SelectArr i a
 lateral f = QueryArr qa
   where
-    qa (i, primQueryL, tag) = (a, primQueryJoin, tag')
+    qa (i, tag) = (a, primQueryJoin, tag')
       where
         (a, primQueryR, tag') = runSimpleQueryArr (f i) ((), tag)
-        primQueryJoin = PQ.Product ((PQ.NonLateral, primQueryL)
+        primQueryJoin primQueryL = PQ.Product ((PQ.NonLateral, primQueryL)
                                     :| [(PQ.Lateral, primQueryR)])
                                    []
 
@@ -99,20 +104,23 @@ arrowApply :: SelectArr (SelectArr i a, i) a
 arrowApply = lateral (\(f, i) -> viaLateral f i)
 
 instance C.Category QueryArr where
-  id = QueryArr id
-  QueryArr f . QueryArr g = QueryArr (f . g)
+  id = QueryArr (\(a, t) -> (a, id, t))
+  QueryArr f . QueryArr g = QueryArr (\(a, t) ->
+                                        let (b, pqf, t') = g (a, t)
+                                            (c, pqf', t'') = f (b, t')
+                                        in (c, pqf' . pqf, t''))
 
 instance Arr.Arrow QueryArr where
-  arr f   = QueryArr (first3 f)
-  first f = QueryArr g
-    where g ((b, d), primQ, t0) = ((c, d), primQ', t1)
-            where (c, primQ', t1) = runQueryArr f (b, primQ, t0)
+  arr f   = QueryArr (\(a, t) -> (f a, id, t))
+  first (QueryArr f) = QueryArr g
+    where g ((b, d), t0) = ((c, d), primQ', t1)
+            where (c, primQ', t1) = f (b, t0)
 
 instance Arr.ArrowChoice QueryArr where
-  left f = QueryArr g
-    where g (e, primQ, t0) = case e of
-            Left a -> first3 Left (runQueryArr f (a, primQ, t0))
-            Right b -> (Right b, primQ, t0)
+  left (QueryArr f) = QueryArr g
+    where g (e, t0) = case e of
+            Left a -> first3 Left (f (a, t0))
+            Right b -> (Right b, id, t0)
 
 instance Arr.ArrowApply QueryArr where
   app = arrowApply

src/Opaleye/Label.hs

@@ -2,10 +2,11 @@ module Opaleye.Label (
   label
   ) where
 
-import qualified Opaleye.Internal.Label as L
+import qualified Opaleye.Internal.PrimQuery as PQ
 import qualified Opaleye.Internal.QueryArr as Q
 import qualified Opaleye.Select            as S
 
--- | Add a commented label to the generated SQL.
+-- | Add a commented label to the generated SQ
 label :: String -> S.SelectArr a b -> S.SelectArr a b
-label l a = Q.QueryArr (L.label' l . Q.runQueryArr a)
+label l s = Q.QueryArr ((\(a, pqf, t') -> (a, PQ.Label l . pqf, t'))
+                         . Q.runEndoQueryArr s)

src/Opaleye/Operators.hs

@@ -156,13 +156,13 @@ restrict = O.restrict
 {-| Add a @WHERE EXISTS@ clause to the current query. -}
 restrictExists :: S.SelectArr a b -> S.SelectArr a ()
 restrictExists criteria = QueryArr f where
-  f (a, primQ, t0) = ((), PQ.Semijoin PQ.Semi primQ existsQ, t1) where
+  f (a, t0) = ((), \primQ -> PQ.Semijoin PQ.Semi primQ existsQ, t1) where
     (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)
 
 {-| Add a @WHERE NOT EXISTS@ clause to the current query. -}
 restrictNotExists :: S.SelectArr a b -> S.SelectArr a ()
 restrictNotExists criteria = QueryArr f where
-  f (a, primQ, t0) = ((), PQ.Semijoin PQ.Anti primQ existsQ, t1) where
+  f (a, t0) = ((), \primQ -> PQ.Semijoin PQ.Anti primQ existsQ, t1) where
     (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)
 
 infix 4 .==