opaleye 0.9.0.0 → 0.9.1.0

raw patch · 27 files changed

+283/−153 lines, 27 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• Test/Opaleye/Test/Arbitrary.hs +11/−3
• Test/Test.hs +6/−6
• opaleye.cabal +1/−1
• src/Opaleye/Aggregate.hs +5/−1
• src/Opaleye/Exists.hs +7/−8
• src/Opaleye/Internal/Aggregate.hs +2/−2
• src/Opaleye/Internal/Binary.hs +10/−6
• src/Opaleye/Internal/Join.hs +18/−19
• src/Opaleye/Internal/Locking.hs +3/−1
• src/Opaleye/Internal/MaybeFields.hs +4/−5
• src/Opaleye/Internal/Operators.hs +4/−3
• src/Opaleye/Internal/Order.hs +9/−9
• src/Opaleye/Internal/PrimQuery.hs +63/−0
• src/Opaleye/Internal/QueryArr.hs +43/−61
• src/Opaleye/Internal/Rebind.hs +7/−3
• src/Opaleye/Internal/RunQuery.hs +0/−1
• src/Opaleye/Internal/RunQueryExternal.hs +0/−2
• src/Opaleye/Internal/Tag.hs +8/−0
• src/Opaleye/Internal/Values.hs +4/−4
• src/Opaleye/Label.hs +15/−1
• src/Opaleye/Operators.hs +7/−5
• src/Opaleye/Order.hs +31/−5
• src/Opaleye/RunSelect.hs +0/−2
• src/Opaleye/SqlTypes.hs +1/−0
• src/Opaleye/Table.hs +4/−3
• src/Opaleye/Values.hs +7/−2

@@ -1,3 +1,16 @@+## 0.9.1.0++* Added `distinctOnExplicit` and `distinctOnByExplicit`++* Added `label'` as a future replacement for `label`++* Exported `SqlFractional` from `Opaleye.SqlTypes`++* Fixed [a bug in+  `forUpdate`](https://github.com/tomjaguarpaw/haskell-opaleye/issues/540)++* The internal implementation of `QueryArr` has changed.+ ## 0.9.0.0  The switch from `Column` to `Field` is complete.  This is a small yet

@@ -13,6 +13,7 @@ import           Opaleye.Test.Fields  import qualified Opaleye as O+import qualified Opaleye.Exists as OE import qualified Opaleye.Join as OJ  import           Control.Applicative (pure, (<$>), (<*>), liftA2)@@ -492,6 +493,15 @@                             . fmap listFields)                            (O.optionalRestrictExplicit unpackFields q)         return q'+    , do+        thisLabel <- TQ.arbitrary+        pure $ \select -> do+          O.label' thisLabel+          select+    , do+        pure $ \select -> do+          exists <- OE.exists select+          pure (Choices [Left (CBool exists)])     ]  genSelectMapper2 :: [TQ.Gen (O.Select Fields -> O.Select Fields@@ -515,9 +525,7 @@  genSelectArrMapper :: [TQ.Gen (O.SelectArr a Fields -> O.SelectArr a Fields)] genSelectArrMapper =-    [ do-        thisLabel        <- TQ.arbitrary-        return (O.label thisLabel)+    [     ]  genSelectArrMaybeMapper :: [TQ.Gen (O.SelectArr a Fields

@@ -354,8 +354,8 @@           O.restrict -< fst t .== 1           Arr.returnA -< t -testExists :: Test-testExists = it "restricts the rows returned with EXISTS" $+testRestrictExists :: Test+testRestrictExists = it "restricts the rows returned with EXISTS" $     select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)   where select = proc () -> do           t <- table1Q -< ()@@ -364,8 +364,8 @@                             O.restrict -< fst t' .> fst t) -< t           Arr.returnA -< t -testNotExists :: Test-testNotExists = it "restricts the rows returned with NOT EXISTS" $+testRestrictNotExists :: Test+testRestrictNotExists = it "restricts the rows returned with NOT EXISTS" $     select `selectShouldReturnSorted` filter ((== 2) . fst)  (L.sort table1data)   where select = proc () -> do           t <- table1Q -< ()@@ -1453,8 +1453,8 @@         testSelect         testProduct         testRestrict-        testExists-        testNotExists+        testRestrictExists+        testRestrictNotExists         testIn         testNum         testDiv

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2022 Tom Ellis-version:         0.9.0.0+version:         0.9.1.0 synopsis:        An SQL-generating DSL targeting PostgreSQL description:     An SQL-generating DSL targeting PostgreSQL.  Allows                  Postgres queries to be written within Haskell in a

@@ -43,6 +43,7 @@ import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.Tag as Tag  import qualified Opaleye.Field     as F import qualified Opaleye.Order     as Ord@@ -81,7 +82,10 @@ -- See 'Opaleye.Internal.Sql.aggregate' for details of how aggregating -- by an empty query with no group by is handled. aggregate :: Aggregator a b -> S.Select a -> S.Select b-aggregate agg q = Q.productQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)+aggregate agg q = Q.productQueryArr' $ \() -> do+  (a, pq) <- Q.runSimpleQueryArr' q ()+  t <- Tag.fresh+  pure (A.aggregateU agg (a, pq, t))  -- | Order the values within each aggregation in `Aggregator` using -- the given ordering. This is only relevant for aggregations that

@@ -2,10 +2,10 @@  import           Opaleye.Field (Field) import           Opaleye.Internal.Column (Field_(Column))-import           Opaleye.Internal.QueryArr (runSimpleQueryArr, productQueryArr)+import           Opaleye.Internal.QueryArr (productQueryArr', runSimpleQueryArr') import           Opaleye.Internal.PackMap (run, extractAttr) import           Opaleye.Internal.PrimQuery (PrimQuery' (Exists))-import           Opaleye.Internal.Tag (next)+import           Opaleye.Internal.Tag (fresh) import           Opaleye.Select (Select) import           Opaleye.SqlTypes (SqlBool) @@ -13,9 +13,8 @@ -- -- This operation is equivalent to Postgres's @EXISTS@ operator. exists :: Select a -> Select (Field SqlBool)-exists q = productQueryArr (f . runSimpleQueryArr q)-  where-    f (_, query, tag) = (Column result, Exists binding query, tag')-      where-        (result, [(binding, ())]) = run (extractAttr "exists" tag ())-        tag' = next tag+exists q = productQueryArr' $ \() -> do+  (_, query) <- runSimpleQueryArr' q ()+  tag <- fresh+  let (result, [(binding, ())]) = run (extractAttr "exists" tag ())+  pure (Column result, Exists binding query)

@@ -102,8 +102,8 @@ -- aggregate.  On the other hand, referring to a field from a previous -- query in an ORDER BY expression is totally fine! aggregateU :: Aggregator a b-           -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)-aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0)+           -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery)+aggregateU agg (c0, primQ, t0) = (c1, primQ')   where (c1, projPEs_inners) =           PM.run (runAggregator agg (extractAggregateFields t0) c0) 

@@ -40,19 +40,23 @@  sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'                     -> Q.Query columns -> Q.Query columns -> Q.Query columns'-sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr q where-  q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)-    where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)-          (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)+sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr' $ \() -> do+  (columns1, primQuery1) <- Q.runSimpleQueryArr' q1 ()+  (columns2, primQuery2) <- Q.runSimpleQueryArr' q2 () -          (newColumns, pes) =+  endTag <- T.fresh++  let (newColumns, pes) =             PM.run (runBinaryspec binaryspec (extractBinaryFields endTag)                                     (columns1, columns2)) -          newPrimQuery = PQ.Binary binop+      newPrimQuery = PQ.Binary binop             ( PQ.Rebind False (map (fmap fst) pes) primQuery1             , PQ.Rebind False (map (fmap snd) pes) primQuery2             )++  pure (newColumns, newPrimQuery)+  instance Default Binaryspec (Field_ n a) (Field_ n a) where   def = binaryspecColumn

@@ -17,11 +17,9 @@ import qualified Opaleye.SqlTypes as T import qualified Opaleye.Field as C import           Opaleye.Field   (Field)-import qualified Opaleye.Internal.Map as Map import           Opaleye.Internal.MaybeFields (MaybeFields(MaybeFields),                                                mfPresent, mfFields) import qualified Opaleye.Select  as S-import qualified Opaleye.Internal.TypeFamilies as TF  import qualified Control.Applicative as A import qualified Control.Arrow@@ -50,39 +48,40 @@              -> ((columnsA, columnsB) -> Field T.PGBool)              -> Q.Query (returnedColumnsA, returnedColumnsB) joinExplicit uA uB returnColumnsA returnColumnsB joinType-             qA qB cond = Q.productQueryArr q where-  q ((), startTag) = ((nullableColumnsA, nullableColumnsB), primQueryR, T.next endTag)-    where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)-          (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag)+             qA qB cond = Q.productQueryArr' $ \() -> do+  (columnsA, primQueryA) <- Q.runSimpleQueryArr' qA ()+  (columnsB, primQueryB) <- Q.runSimpleQueryArr' qB () -          (newColumnsA, ljPEsA) =+  endTag <- T.fresh++  let (newColumnsA, ljPEsA) =             PM.run (U.runUnpackspec uA (extractLeftJoinFields 1 endTag) columnsA)-          (newColumnsB, ljPEsB) =+      (newColumnsB, ljPEsB) =             PM.run (U.runUnpackspec uB (extractLeftJoinFields 2 endTag) columnsB) -          nullableColumnsA = returnColumnsA newColumnsA-          nullableColumnsB = returnColumnsB newColumnsB+      nullableColumnsA = returnColumnsA newColumnsA+      nullableColumnsB = returnColumnsB newColumnsB -          Column cond' = cond (columnsA, columnsB)-          primQueryR = PQ.Join joinType cond'+      Column cond' = cond (columnsA, columnsB)+      primQueryR = PQ.Join joinType cond'                                (PQ.NonLateral, (PQ.Rebind True ljPEsA primQueryA))                                (PQ.NonLateral, (PQ.Rebind True ljPEsB primQueryB)) +  pure ((nullableColumnsA, nullableColumnsB), primQueryR)++ leftJoinAExplicit :: U.Unpackspec a a                   -> NullMaker a nullableA                   -> Q.Query a                   -> Q.QueryArr (a -> Field T.PGBool) nullableA leftJoinAExplicit uA nullmaker rq =-  Q.leftJoinQueryArr $ \(p, t1) ->-    let (newColumnsR, right, tag') = flip Q.runSimpleQueryArr ((), t1) $ proc () -> do+  Q.leftJoinQueryArr' $ \p -> do+    (newColumnsR, right) <- flip Q.runSimpleQueryArr' () $ proc () -> do           a <- rq -< ()           Rebind.rebindExplicit uA -< a-        renamedNullable = toNullable nullmaker newColumnsR+    let renamedNullable = toNullable nullmaker newColumnsR         Column cond = p newColumnsR-    in ( renamedNullable-       , cond-       , right-       , tag')+    pure (renamedNullable, cond, right)  optionalRestrict :: D.Default U.Unpackspec a a                  => S.Select a

@@ -21,4 +21,6 @@ -- enforce those restrictions through its type system so it's very -- easy to create queries that fail at run time using this operation. forUpdate :: Q.Select a -> Q.Select a-forUpdate = Q.mapPrimQuery PQ.ForUpdate+forUpdate s = Q.productQueryArr' $ \() -> do+  (a, query) <- Q.runSimpleQueryArr' s ()+  pure (a, PQ.ForUpdate query)

@@ -11,7 +11,6 @@  module Opaleye.Internal.MaybeFields where -import           Control.Applicative hiding (optional) import           Control.Arrow (returnA, (<<<), (>>>))  import qualified Opaleye.Internal.Binary as B@@ -139,15 +138,15 @@   where isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull  optionalInternal :: (Opaleye.Field.FieldNullable SqlBool -> a -> r) -> Select a -> Select r-optionalInternal f query = IQ.leftJoinQueryArr $ \arg ->+optionalInternal f query = IQ.leftJoinQueryArr' $ \() -> do     -- This is basically a left join on TRUE, but Shane (@duairc)     -- wrote it to ensure that we don't need an Unpackspec a a.-    let (r, right, tag') = flip IQ.runSimpleQueryArr arg $ proc () -> do+    let true = HPQ.ConstExpr (HPQ.BoolLit True)+    (r, right) <- flip IQ.runSimpleQueryArr' () $ proc () -> do           a <- query -< ()           true_ <- Rebind.rebind -< Opaleye.Field.toNullable (IC.Column true)           returnA -< f true_ a-        true = HPQ.ConstExpr (HPQ.BoolLit True)-    in (r, true, right, tag')+    pure (r, true, right)   -- | An example to demonstrate how the functionality of (lateral)

@@ -28,7 +28,7 @@ restrict = QA.QueryArr f where   -- A where clause can always refer to columns defined by the query   -- it references so needs no special treatment on LATERAL.-  f (Column predicate, t0) = ((), \_ -> PQ.restrict predicate, t0)+  f (Column predicate) = pure ((), PQ.aRestrict predicate)  infix 4 .== (.==) :: forall columns. D.Default EqPP columns columns@@ -103,11 +103,12 @@                            -> (a -> HPQ.PrimExpr)                            -> QA.QueryArr a columns relationValuedExprExplicit rem_ strings pe =-  QA.productQueryArr $ \(a, tag) ->+  QA.productQueryArr' $ \a -> do+    tag <- Tag.fresh     let (primExprs, projcols) = runRelExprMaker rem_ tag strings         primQ :: PQ.PrimQuery         primQ = PQ.RelExpr (pe a) projcols-    in (primExprs, primQ, Tag.next tag)+    pure (primExprs, primQ)  relationValuedExpr :: D.Default RelExprMaker strings columns                    => strings

@@ -53,27 +53,27 @@ order :: HPQ.OrderOp -> (a -> F.Field_ n b) -> Order a order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f) -orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-orderByU os (columns, primQ, t) = (columns, primQ', t)+orderByU :: Order a -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+orderByU os (columns, primQ) = (columns, primQ')   where primQ' = PQ.DistinctOnOrderBy Nothing oExprs primQ         oExprs = orderExprs columns os  orderExprs :: a -> Order a -> [HPQ.OrderExpr] orderExprs x (Order os) = map (uncurry HPQ.OrderExpr) (os x) -limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t)+limit' :: Int -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+limit' n (x, q) = (x, PQ.Limit (PQ.LimitOp n) q) -offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t)+offset' :: Int -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+offset' n (x, q) = (x, PQ.Limit (PQ.OffsetOp n) q)  distinctOn :: U.Unpackspec b b -> (a -> b)-           -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+           -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) distinctOn ups proj = distinctOnBy ups proj M.mempty  distinctOnBy :: U.Unpackspec b b -> (a -> b) -> Order a-             -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-distinctOnBy ups proj ord (cols, pq, t) = (cols, pqOut, t)+             -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+distinctOnBy ups proj ord (cols, pq) = (cols, pqOut)     where pqOut = case NL.nonEmpty (U.collectPEs ups (proj cols)) of             Just xs -> PQ.DistinctOnOrderBy (Just xs) oexprs pq             Nothing -> PQ.Limit (PQ.LimitOp 1) (PQ.DistinctOnOrderBy Nothing oexprs pq)

@@ -45,6 +45,69 @@   mappend = (<>)   mempty = NonLateral +aLeftJoin :: HPQ.PrimExpr -> PrimQuery -> PrimQueryArr+aLeftJoin cond primQuery' = PrimQueryArr $ \lat primQueryL ->+  Join LeftJoin cond (NonLateral, primQueryL) (lat, primQuery')++aProduct :: PrimQuery -> PrimQueryArr+aProduct pq = PrimQueryArr (\lat primQuery -> times lat primQuery pq)++aSemijoin :: SemijoinType -> PrimQuery -> PrimQueryArr+aSemijoin joint existsQ = PrimQueryArr $ \_ primQ -> Semijoin joint primQ existsQ++aRebind :: Bindings HPQ.PrimExpr -> PrimQueryArr+aRebind bindings = PrimQueryArr $ \_ -> Rebind True bindings++aRestrict :: HPQ.PrimExpr -> PrimQueryArr+aRestrict predicate = PrimQueryArr $ \_ -> restrict predicate++aLabel :: String -> PrimQueryArr+aLabel l = PrimQueryArr $ \_ primQ -> Label l primQ++-- The function 'Lateral -> PrimQuery -> PrimQuery' represents a+-- select arrow in the following way:+--+--    Lateral+-- -- ^ Whether to join me laterally+-- -> PrimQuery+-- -- ^ The query that I will be joined after.  If I refer to columns+-- -- in here in a way that is only valid when I am joined laterally,+-- -- then Lateral must be passed in as the argument above.+-- -> PrimQuery+-- -- ^ The result after joining me+--+-- It is *always* valid to pass Lateral as the first argument.  So why+-- wouldn't we do that?  Because we don't want to generate lateral+-- subqueries if they are not needed; it might have performance+-- implications.  Even though there is good evidence that it *doesn't*+-- have performance implications+-- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still+-- want to be cautious.+--+-- Not every function of type `Lateral -> PrimQuery -> PrimQuery` is+-- valid to be a PrimQuery.  I think the condition that they must+-- satisfy for validity is+--+--     q == lateral (aProduct (toPrimQuery q)+--+-- where == is observable equivalence, i.e. both queries must give the+-- same results when combined with other queries and then run.+newtype PrimQueryArr =+  PrimQueryArr { runPrimQueryArr :: Lateral -> PrimQuery -> PrimQuery }++instance Semigroup PrimQueryArr where+  PrimQueryArr f1 <> PrimQueryArr f2 = PrimQueryArr (\lat -> f2 lat . f1 lat)++instance Monoid PrimQueryArr where+  mappend = (<>)+  mempty = PrimQueryArr (\_ -> id)++lateral :: PrimQueryArr -> PrimQueryArr+lateral (PrimQueryArr pq) = PrimQueryArr (\_ -> pq Lateral)++toPrimQuery :: PrimQueryArr -> PrimQuery+toPrimQuery (PrimQueryArr f) = f NonLateral Unit+ -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check -- for emptiness explicity in the SQL generation phase. 

@@ -19,65 +19,49 @@ import qualified Control.Category as C import           Control.Category ((<<<), id) import           Control.Applicative (Applicative, pure, (<*>))-import           Data.List.NonEmpty ( NonEmpty((:|)) )+import           Control.Monad.Trans.State.Strict (State, runState, state) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP---- Ideally this should be wrapped in a monad which automatically--- increments the Tag, but I couldn't be bothered to do that.------ The function 'Lateral -> PrimQuery -> PrimQuery' represents a--- select arrow in the following way:------    Lateral--- -- ^ Whether to join me laterally--- -> PrimQuery--- -- ^ The query that I will be joined after.  If I refer to columns--- -- in here in a way that is only valid when I am joined laterally,--- -- then Lateral must be passed in as the argument above.--- -> PrimQuery--- -- ^ The result after joining me------ It is *always* valid to pass Lateral as the first argument.  So why--- wouldn't we do that?  Because we don't want to generate lateral--- subqueries if they are not needed; it might have performance--- implications.  Even though there is good evidence that it *doesn't*--- have performance implications--- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still--- want to be cautious.+import           Data.Semigroup ((<>))  -- | A parametrised 'Select'.  A @SelectArr a b@ accepts an argument -- of type @a@. -- -- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.-newtype SelectArr a b = QueryArr ((a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag))+newtype SelectArr a b = QueryArr { unQueryArr :: a -> State Tag (b, PQ.PrimQueryArr) }  type QueryArr = SelectArr type Query = SelectArr () -productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b-productQueryArr f = QueryArr g-  where g (a0, t0) = (a1, \lat primQuery -> PQ.times lat primQuery primQuery', t1)-          where (a1, primQuery', t1) = f (a0, t0)+productQueryArr' :: (a -> State Tag (b, PQ.PrimQuery)) -> QueryArr a b+productQueryArr' f = QueryArr $ \a -> do+  (b, pq) <- f a+  pure (b, PQ.aProduct pq) -leftJoinQueryArr :: ((a, Tag) -> (b, HPQ.PrimExpr, PQ.PrimQuery, Tag)) -> QueryArr a b-leftJoinQueryArr f = QueryArr g-  where g (a0, t0) = (a1, \lat primQueryL ->-                            PQ.Join PQ.LeftJoin cond (PQ.NonLateral, primQueryL) (lat, primQuery'), t1)-          where (a1, cond, primQuery', t1) = f (a0, t0)-mapPrimQuery :: (PQ.PrimQuery -> PQ.PrimQuery) -> SelectArr a b -> SelectArr a b-mapPrimQuery f sa =-  QueryArr ((\(b, pqf, t) -> (b, \lat -> f . pqf lat, t)) . runQueryArr sa)+leftJoinQueryArr' :: (a -> State Tag (b, HPQ.PrimExpr, PQ.PrimQuery)) -> QueryArr a b+leftJoinQueryArr' f = QueryArr $ \a -> do+  (a1, cond, primQuery') <- f a+  pure (a1, PQ.aLeftJoin cond primQuery') -runQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag)-runQueryArr (QueryArr f) = f+runSimpleQueryArr' :: QueryArr a b -> a -> State Tag (b, PQ.PrimQuery)+runSimpleQueryArr' f a = do+  (b, pqf) <- unQueryArr f a+  pure (b, PQ.toPrimQuery pqf) --- Unit defines no columns so joining it non-LATERAL is OK.-runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArr f = (\(b, pqf, t) -> (b, pqf PQ.NonLateral PQ.Unit, t)) . runQueryArr f+runStateQueryArr :: QueryArr a b -> a -> Tag -> (b, PQ.PrimQueryArr, Tag)+runStateQueryArr (QueryArr f) a tag =+  let ((b, pq), tag') = runState (f a) tag+  in (b, pq, tag') +stateQueryArr :: (a -> Tag -> (b, PQ.PrimQueryArr, Tag)) -> QueryArr a b+stateQueryArr f = QueryArr $ \a -> state $ \tag ->+  let (b, pq, tag') = f a tag+  in ((b, pq), tag')+ runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start)+runSimpleQueryArrStart q a =+  let ((b, pqa), t') = runState (runSimpleQueryArr' q a) Tag.start+  in (b, pqa, t')  runQueryArrUnpack :: U.Unpackspec a b                   -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag)@@ -85,9 +69,6 @@   where (columns, primQ, endTag) = runSimpleQueryArrStart q ()         primExprs = U.collectPEs unpackspec columns -first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)-first3 f (a1, a2, a3) = (f a1, a2, a3)- -- | A @SELECT@, i.e. an SQL query which produces a collection of -- rows. --@@ -103,12 +84,9 @@ -- 'Opaleye.Binary.union', 'Opaleye.Binary.intersect' and -- 'Opaleye.Binary.except' to two 'SelectArr's). lateral :: (i -> Select a) -> SelectArr i a-lateral f = QueryArr qa-  where-    qa (i, tag) = (a, primQueryJoin, tag')-      where-        (a, primQueryR, tag') = runQueryArr (f i) ((), tag)-        primQueryJoin _ = primQueryR PQ.Lateral+lateral f = QueryArr $ \i -> do+  (a, primQueryR) <- unQueryArr (f i) ()+  pure (a, PQ.lateral primQueryR)  -- | Convert an arrow argument into a function argument so that it can -- be applied inside @do@-notation rather than arrow notation.@@ -126,21 +104,25 @@  instance C.Category QueryArr where   id = arr id-  QueryArr f . QueryArr g = QueryArr (\(a, t) ->-                                        let (b, pqf, t') = g (a, t)-                                            (c, pqf', t'') = f (b, t')-                                        in (c, \lat -> pqf' lat . pqf lat, t''))+  QueryArr f . QueryArr g = QueryArr $ \a -> do+    (b, pqf)  <- g a+    (c, pqf') <- f b+    pure (c, pqf <> pqf')  instance Arr.Arrow QueryArr where-  arr f   = QueryArr (\(a, t) -> (f a, const id, t))+  arr f   = QueryArr (\a -> pure (f a, mempty))   first (QueryArr f) = QueryArr g-    where g ((b, d), t0) = first3 (\c -> (c, d)) (f (b, t0))+    where g (b, d) = do+            (c, pq) <- f b+            pure ((c, d), pq)  instance Arr.ArrowChoice QueryArr where   left (QueryArr f) = QueryArr g-    where g (e, t0) = case e of-            Left a -> first3 Left (f (a, t0))-            Right b -> (Right b, const id, t0)+    where g e = case e of+            Left a -> do+              (r, pq) <- f a+              pure (Left r, pq)+            Right b -> pure (Right b, mempty)  instance Arr.ArrowApply QueryArr where   app = arrowApply

@@ -13,6 +13,10 @@ rebind = rebindExplicit def  rebindExplicit :: Unpackspec a b -> SelectArr a b-rebindExplicit u = QueryArr (\(a, tag) ->-                     let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr "rebind" tag) a)-                     in (b, \_ -> PQ.Rebind True bindings, Tag.next tag))+rebindExplicit = rebindExplicitPrefix "rebind"++rebindExplicitPrefix :: String -> Unpackspec a b -> SelectArr a b+rebindExplicitPrefix prefix u = QueryArr $ \a -> do+  tag <- Tag.fresh+  let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr prefix tag) a)+  pure (b, PQ.aRebind bindings)

@@ -22,7 +22,6 @@                                           Nullability(Nullable, NonNullable)) import qualified Opaleye.Internal.PackMap as PackMap import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Column as C import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.PGTypesExternal as T import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)

@@ -16,12 +16,10 @@ import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple.Cursor  as PGSC -import           Opaleye.Column (Column) import qualified Opaleye.Select as S import           Opaleye.Internal.RunQuery (prepareQuery) import qualified Opaleye.Internal.RunQuery as IRQ -import qualified Data.Profunctor as P import qualified Data.Profunctor.Product.Default as D  -- * Running 'S.Select's

@@ -1,5 +1,7 @@ module Opaleye.Internal.Tag where +import Control.Monad.Trans.State.Strict ( get, modify', State )+ -- | Tag is for use as a source of unique IDs in QueryArr newtype Tag = UnsafeTag Int deriving (Read, Show) @@ -14,3 +16,9 @@  tagWith :: Tag -> String -> String tagWith t s = s ++ "_" ++ show (unsafeUnTag t)++fresh :: State Tag Tag+fresh = do+  t <- get+  modify' next+  pure t

@@ -26,8 +26,8 @@ valuesU :: U.Unpackspec columns columns'         -> ValuesspecUnsafe columns columns'         -> [columns]-        -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)-valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t)+        -> ((), T.Tag) -> (columns', PQ.PrimQuery)+valuesU unpack valuesspec rows ((), t) = (newColumns, primQ')   where runRow row = valuesRow            where (_, valuesRow) =                    PM.run (U.runUnpackspec unpack extractValuesEntry row)@@ -68,9 +68,9 @@  valuesUSafe :: Valuesspec columns columns'             -> [columns]-            -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)+            -> ((), T.Tag) -> (columns', PQ.PrimQuery) valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =-  (newColumns, primQ', T.next t)+  (newColumns, primQ')   where runRow row =           case PM.run (U.runUnpackspec unpack extractValuesEntry row) of             (_, []) -> [zero]

@@ -1,4 +1,8 @@+{-# LANGUAGE Arrows #-}+ module Opaleye.Label (+  label',+  -- * Deprecated   label   ) where @@ -6,6 +10,16 @@ import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Select            as S +import           Control.Arrow (returnA)+ -- | Add a commented label to the generated SQL.+label' :: String -> S.Select ()+label' l = Q.QueryArr f where+  f () = pure ((), PQ.aLabel l)++-- | Will be deprecated in version 0.10.  Use 'label\'' instead. label :: String -> S.SelectArr a b -> S.SelectArr a b-label = Q.mapPrimQuery . PQ.Label+label l s = proc a -> do+  b <- s -< a+  label' l -< ()+  returnA -< b

@@ -123,7 +123,7 @@ import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.JSONBuildObjectFields as JBOF import           Opaleye.Internal.QueryArr (SelectArr(QueryArr),-                                            runSimpleQueryArr)+                                            runSimpleQueryArr') import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Operators as O import           Opaleye.Internal.Helpers   ((.:))@@ -161,16 +161,18 @@ restrictExists criteria = QueryArr f where   -- A where exists clause can always refer to columns defined by the   -- query it references so needs no special treatment on LATERAL.-  f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Semi primQ existsQ, t1) where-    (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)+  f a = do+    (_, existsQ) <- runSimpleQueryArr' criteria a+    pure ((), PQ.aSemijoin PQ.Semi existsQ)  {-| Add a @WHERE NOT EXISTS@ clause to the current query. -} restrictNotExists :: S.SelectArr a b -> S.SelectArr a () restrictNotExists criteria = QueryArr f where   -- A where exists clause can always refer to columns defined by the   -- query it references so needs no special treatment on LATERAL.-  f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Anti primQ existsQ, t1) where-    (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)+  f a = do+    (_, existsQ) <- runSimpleQueryArr' criteria a+    pure ((), PQ.aSemijoin PQ.Anti existsQ)  infix 4 .== (.==) :: Field a -> Field a -> F.Field T.SqlBool

@@ -22,6 +22,9 @@                      , O.exact                      -- * Other                      , SqlOrd+                     -- * Explicit versions+                     , distinctOnExplicit+                     , distinctOnByExplicit                      -- * Deprecated                      , distinctOnCorrect                      , distinctOnByCorrect@@ -54,7 +57,9 @@ -} orderBy :: O.Order a -> S.Select a -> S.Select a orderBy os q =-  Q.productQueryArr (O.orderByU os . Q.runSimpleQueryArr q)+  Q.productQueryArr' $ \() -> do+    a_pq <- Q.runSimpleQueryArr' q ()+    pure (O.orderByU os a_pq)  -- | Specify an ascending ordering by the given expression. --   (Any NULLs appear last)@@ -111,7 +116,9 @@ @ -} limit :: Int -> S.Select a -> S.Select a-limit n a = Q.productQueryArr (O.limit' n . Q.runSimpleQueryArr a)+limit n a = Q.productQueryArr' $ \() -> do+  a_pq <- Q.runSimpleQueryArr' a ()+  pure (O.limit' n a_pq)  {- | Offset the results of the given 'S.Select' by the given amount, skipping@@ -121,7 +128,9 @@ 'offset' with 'limit'. -} offset :: Int -> S.Select a -> S.Select a-offset n a = Q.productQueryArr (O.offset' n . Q.runSimpleQueryArr a)+offset n a = Q.productQueryArr' $ \() -> do+  a_pq <- Q.runSimpleQueryArr' a ()+  pure (O.offset' n a_pq)  -- * Distinct on @@ -130,7 +139,7 @@                   => (a -> b)                   -> S.Select a                   -> S.Select a-distinctOnCorrect proj q = Q.productQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)+distinctOnCorrect = distinctOnExplicit D.def  -- | Use 'distinctOnBy' instead.  Will be deprecated in 0.10. distinctOnByCorrect :: D.Default U.Unpackspec b b@@ -138,7 +147,7 @@                     -> O.Order a                     -> S.Select a                     -> S.Select a-distinctOnByCorrect proj ord q = Q.productQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)+distinctOnByCorrect = distinctOnByExplicit D.def   -- * Other@@ -176,3 +185,20 @@ distinctOnBy :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a              -> S.Select a -> S.Select a distinctOnBy = distinctOnByCorrect++distinctOnExplicit :: U.Unpackspec b b+                   -> (a -> b)+                   -> S.Select a+                   -> S.Select a+distinctOnExplicit unpack proj q = Q.productQueryArr' $ \() -> do+  a_pq <- Q.runSimpleQueryArr' q ()+  pure (O.distinctOn unpack proj a_pq)++distinctOnByExplicit :: U.Unpackspec b b+                     -> (a -> b)+                     -> O.Order a+                     -> S.Select a+                     -> S.Select a+distinctOnByExplicit unpack proj ord q = Q.productQueryArr' $ \() -> do+  a_pq <- Q.runSimpleQueryArr' q ()+  pure (O.distinctOnBy unpack proj ord a_pq)

@@ -29,10 +29,8 @@    runSelectTF,    ) where -import qualified Data.Profunctor            as P import qualified Database.PostgreSQL.Simple as PGS -import qualified Opaleye.Column as C import qualified Opaleye.Select as S import qualified Opaleye.Internal.RunQueryExternal as RQ import qualified Opaleye.TypeFamilies as TF

@@ -19,6 +19,7 @@   -- ** Type classes   IC.SqlNum,   IC.SqlIntegral,+  IC.SqlFractional,   -- * Date and time   -- ** Creating values   sqlDay,

@@ -132,6 +132,7 @@                     -> Table a tablefields                     -- ^                     -> S.Select fields-selectTableExplicit cm table' = Q.productQueryArr f where-  f ((), t0) = (retwires, primQ, Tag.next t0) where-    (retwires, primQ) = T.queryTable cm table' t0+selectTableExplicit cm table' = Q.productQueryArr' $ \() -> do+  t0 <- Tag.fresh+  let (retwires, primQ) = T.queryTable cm table' t0+  pure (retwires, primQ)

@@ -16,6 +16,7 @@   ) where  import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Tag as Tag import           Opaleye.Internal.Values as V import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Select              as S@@ -33,7 +34,9 @@                      -> V.ValuesspecUnsafe fields fields'                      -> [fields] -> S.Select fields' valuesUnsafeExplicit unpack valuesspec fields =-  Q.productQueryArr (V.valuesU unpack valuesspec fields)+  Q.productQueryArr' $ \() -> do+  t <- Tag.fresh+  pure (V.valuesU unpack valuesspec fields ((), t))  -- | 'values' implements Postgres's @VALUES@ construct and allows you -- to create a @SELECT@ that consists of the given rows.@@ -57,7 +60,9 @@ valuesExplicit :: V.Valuesspec fields fields'                -> [fields] -> S.Select fields' valuesExplicit valuesspec fields =-  Q.productQueryArr (V.valuesUSafe valuesspec fields)+  Q.productQueryArr' $ \() -> do+    t <- Tag.fresh+    pure (V.valuesUSafe valuesspec fields ((), t))  {-# DEPRECATED valuesSafe "Use 'values' instead.  Will be removed in 0.10." #-} valuesSafe :: Default V.Valuesspec fields fields