opaleye 0.6.7004.2 → 0.6.7005.0

raw patch · 57 files changed

+3064/−910 lines, 57 filesdep ~bytestringdep ~product-profunctorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: bytestring, product-profunctors

API changes (from Hackage documentation)

Files

• CHANGELOG.md +42/−1
• Doc/Tutorial/TutorialAdvanced.lhs +1/−1
• Doc/Tutorial/TutorialBasic.lhs +2/−2
• Doc/Tutorial/TutorialBasicMonomorphic.lhs +2/−2
• Doc/Tutorial/TutorialBasicTypeFamilies.lhs +4/−4
• Doc/Tutorial/TutorialManipulation.lhs +2/−2
• Test/Connection.hs +44/−0
• Test/Opaleye/Test/Arbitrary.hs +464/−0
• Test/Opaleye/Test/Fields.hs +199/−0
• Test/QuickCheck.hs +359/−287
• Test/Test.hs +416/−319
• Test/TypeFamilies.hs +1/−1
• Test/Wrapped.hs +87/−0
• opaleye.cabal +16/−6
• src/Opaleye.hs +11/−1
• src/Opaleye/Adaptors.hs +84/−0
• src/Opaleye/Aggregate.hs +10/−6
• src/Opaleye/Binary.hs +20/−7
• src/Opaleye/Column.hs +5/−2
• src/Opaleye/Distinct.hs +14/−5
• src/Opaleye/Field.hs +3/−0
• src/Opaleye/FunctionalJoin.hs +3/−5
• src/Opaleye/Internal/Aggregate.hs +54/−18
• src/Opaleye/Internal/Binary.hs +8/−5
• src/Opaleye/Internal/Distinct.hs +17/−4
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +5/−1
• src/Opaleye/Internal/Join.hs +42/−3
• src/Opaleye/Internal/Lateral.hs +27/−0
• src/Opaleye/Internal/Manipulation.hs +2/−2
• src/Opaleye/Internal/MaybeFields.hs +316/−0
• src/Opaleye/Internal/Operators.hs +24/−3
• src/Opaleye/Internal/Optimize.hs +15/−9
• src/Opaleye/Internal/PackMap.hs +13/−8
• src/Opaleye/Internal/PrimQuery.hs +49/−16
• src/Opaleye/Internal/Print.hs +13/−4
• src/Opaleye/Internal/QueryArr.hs +59/−3
• src/Opaleye/Internal/RunQuery.hs +11/−12
• src/Opaleye/Internal/Sql.hs +64/−32
• src/Opaleye/Internal/Table.hs +48/−32
• src/Opaleye/Internal/TableMaker.hs +3/−3
• src/Opaleye/Internal/Unpackspec.hs +9/−4
• src/Opaleye/Internal/Values.hs +132/−4
• src/Opaleye/Join.hs +164/−23
• src/Opaleye/Label.hs +2/−2
• src/Opaleye/Lateral.hs +9/−0
• src/Opaleye/Manipulation.hs +6/−5
• src/Opaleye/Map.hs +2/−0
• src/Opaleye/MaybeFields.hs +73/−0
• src/Opaleye/Operators.hs +12/−8
• src/Opaleye/Order.hs +12/−12
• src/Opaleye/PGTypes.hs +9/−4
• src/Opaleye/RunSelect.hs +8/−4
• src/Opaleye/Select.hs +2/−14
• src/Opaleye/Sql.hs +3/−3
• src/Opaleye/SqlTypes.hs +1/−1
• src/Opaleye/Table.hs +8/−6
• src/Opaleye/Values.hs +53/−14

@@ -1,6 +1,47 @@+## 0.6.7005.0++* Add a `Monad` instance for `Select` (and `SelectArr i`).++* Add `Opaleye.Lateral`, to support LATERAL subqueries.++* Add `Opaleye.Join.optionalRestrict` and `Opaleye.Join.optional`, as+  more convenient and composable ways of doing left/right joins.++* Add `Opaleye.MaybeFields`++* Add `optionalTableField`, `readOnlyTableField`,+  `requiredTableField`, to replace `optional`, `readOnly` and+  `required` in a later version.++* Add `valuesSafe`, a version of `values`. `values` of an empty list+  generates incorrect queries when mixed with @OUTER@/@LEFT@/@RIGHT+  JOIN@s.  `valuesSafe` will replace it in version 0.7++* Add `Opaleye.Adaptors` as the forward-compatible place to import+  `Unpackspec` and `unpackspecField` from, as well as other adaptors.++* Unicode characters are escaped properly in `sqlString`/`toFields`++* Add `inSelect`, to replace `inQuery` in a future version.++* Add `unsafeCoerceField`, to replace `unsafeCoerceColumn` in a future+  version.++* Generalise label to type `label :: String -> S.SelectArr a b ->+S.SelectArr a b`++* [Fix invalid queries+  bug](https://github.com/tomjaguarpaw/haskell-opaleye/pull/468) in+  `union`, `unionAll`, `except` and `exceptAll` where one side was+  empty.++## 0.6.7004.2++* No user-visible changes+ ## 0.6.7004.1 -* Fixed quadratic slowdown in `removeEmpty`.+* Fixed exponential slowdown in `removeEmpty`.  * Fixed `read` compatibility with time-1.9 in test suite. 

@@ -72,4 +72,4 @@ ===============  > printSql :: Default U.Unpackspec a a => Select a -> IO ()-> printSql = putStrLn . maybe "Empty query" id . Sql.showSqlForPostgres+> printSql = putStrLn . maybe "Empty query" id . Sql.showSql

@@ -14,7 +14,7 @@ >                          (.===), >                          (.++), ifThenElse, sqlString, aggregate, groupBy, >                          count, avg, sum, leftJoin, runSelect,->                          showSqlForPostgres, Unpackspec,+>                          showSql, Unpackspec, >                          SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8, SqlBool) > > import           Data.Profunctor.Product (p2, p3)@@ -857,4 +857,4 @@ This is a little utility function to help with printing generated SQL.  > printSql :: Default Unpackspec a a => Select a -> IO ()-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres+> printSql = putStrLn . maybe "Empty query" id . showSql

@@ -12,7 +12,7 @@ >                          Select, (.==), >                          aggregate, groupBy, >                          count, avg, sum, leftJoin, runSelect,->                          showSqlForPostgres, Unpackspec,+>                          showSql, Unpackspec, >                          SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8) > > import qualified Opaleye                 as O@@ -405,4 +405,4 @@ This is a little utility function to help with printing generated SQL.  > printSql :: Default Unpackspec a a => Select a -> IO ()-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres+> printSql = putStrLn . maybe "Empty query" id . showSql

@@ -18,7 +18,7 @@ >                          Table, table, tableField, selectTable, >                          Select, (.==), aggregate, groupBy, >                          count, avg, sum, leftJoin, runSelect, runSelectTF,->                          showSqlForPostgres, Unpackspec,+>                          showSql, Unpackspec, >                          SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8) > > import qualified Opaleye              as O@@ -354,9 +354,9 @@ >     O.fullJoinInferrable (O.fullJoinInferrable >                     birthdaySelect >                     (selectTable widgetTable)->                     (const (O.pgBool True)))+>                     (const (O.sqlBool True))) >                birthdaySelect->                (const (O.pgBool True))+>                (const (O.sqlBool True))  Running queries on Postgres ===========================@@ -396,4 +396,4 @@ This is a little utility function to help with printing generated SQL.  > printSql :: Default Unpackspec a a => Select a -> IO ()-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres+> printSql = putStrLn . maybe "Empty query" id . showSql

@@ -50,7 +50,7 @@ > delete :: Delete Int64 > delete = Delete >   { dTable     = myTable->   , dWhere     = (\(_, x, y, _) -> x .< y)+>   , dWhere     = \(_, x, y, _) -> x .< y >   , dReturning = rCount >   } @@ -133,7 +133,7 @@ > update = Update >   { uTable      = myTable >   , uUpdateWith = updateEasy (\(id_, x, y, s) -> (id_, x + y, x - y, s))->   , uWhere      = (\(id_, _, _, _) -> id_ .== 5)+>   , uWhere      = \(id_, _, _, _) -> id_ .== 5 >   , uReturning  = rCount >   } 

@@ -0,0 +1,44 @@+module Connection where++import           Control.Concurrent (threadDelay)+import           Control.Exception (tryJust)+import           Data.IORef (IORef, readIORef, writeIORef, newIORef)+import           Data.ByteString (ByteString)+import qualified Database.PostgreSQL.Simple       as PGS+import           GHC.IO.Exception (ioe_description)++type Connection = (IORef PGS.Connection, ByteString)++withConnection :: Connection -> (PGS.Connection -> IO r) -> IO (Either () r)+withConnection (conn, connectString) k = do+  conn' <- readIORef conn++  er <- tryJust (\e -> if ioe_description e == "failed to fetch file descriptor"+                       then Just e+                       else Nothing)+                (k conn')++  case er of+    Right r -> pure (Right r)+    Left _ -> do+      PGS.close conn'+      -- If we reconnect immediately then the connection fails with+      -- "Exception: libpq: failed (FATAL: the database system is in+      -- recovery mode".  We could try to handle that, but it's easier+      -- just to delay for ten seconds, which seems to be enough time+      -- for the database to recover.+      threadDelay (10 * 1000 * 1000) -- microseconds+      conn'new <- PGS.connectPostgreSQL connectString+      writeIORef conn conn'new+      return (Left ())++connectPostgreSQL :: ByteString -> IO Connection+connectPostgreSQL connectString = do+  conn' <- PGS.connectPostgreSQL connectString+  conn <- newIORef conn'+  pure (conn, connectString)++close :: Connection -> IO ()+close (conn, _) = do+  conn' <- readIORef conn+  PGS.close conn'

@@ -0,0 +1,464 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Opaleye.Test.Arbitrary where++import           Prelude hiding (compare, (.), id)++import           Opaleye.Test.Fields++import qualified Opaleye as O+import qualified Opaleye.Join as OJ++import           Control.Applicative (pure, (<$>), (<*>), liftA2)+import qualified Control.Arrow as Arrow+import           Control.Arrow ((<<<))+import           Control.Category ((.), id)+import           Control.Monad ((<=<))+import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import qualified Data.Monoid as Monoid+import qualified Test.QuickCheck as TQ++data Order = Asc | Desc deriving Show++newtype ArbitrarySelect   = ArbitrarySelect (O.Select Fields)+newtype ArbitrarySelectMaybe =+  ArbitrarySelectMaybe (O.Select (O.MaybeFields Fields))+newtype ArbitrarySelectArr = ArbitrarySelectArr (O.SelectArr Fields Fields)+newtype ArbitraryKleisli = ArbitraryKleisli (Fields -> O.Select Fields)+newtype ArbitraryHaskells = ArbitraryHaskells { unArbitraryHaskells :: Haskells }+                        deriving Show+newtype ArbitraryHaskellsList =+  ArbitraryHaskellsList { unArbitraryHaskellsList :: [HaskellsTuple] }+                             deriving Show+newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int+                            deriving Show+newtype ArbitraryOrder = ArbitraryOrder { unArbitraryOrder :: [(Order, Int)] }+                      deriving Show+newtype ArbitraryFunction =+  ArbitraryFunction { unArbitraryFunction :: forall m i b s.+                      Functor m => Choices m i b s -> Choices m i b s }++twoIntTable :: String+            -> O.Table (O.Field O.SqlInt4, O.Field O.SqlInt4)+                       (O.Field O.SqlInt4, O.Field O.SqlInt4)+twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))++table1 :: O.Table (O.Field O.SqlInt4, O.Field O.SqlInt4)+                  (O.Field O.SqlInt4, O.Field O.SqlInt4)+table1 = twoIntTable "table1"++instance TQ.Arbitrary ArbitraryFunction where+  arbitrary = do+    i <- TQ.choose (0 :: Int, 4)++    return (ArbitraryFunction (\xs ->+        if i == 0 then+          evens xs `appendChoices` odds xs+        else if i == 1 then+          evens xs `appendChoices` evens xs+        else if i == 2 then+          odds xs `appendChoices` odds xs+        else if i == 3 then+          evens xs+        else+          odds xs))++-- We don't have the ability to aggregate MaybeFields, at least, not+-- yet.  Therefore we just replace them with Nothing.+aggregateFields :: O.Aggregator Fields Fields+aggregateFields =+  -- The requirement to cast to int4 is silly, but we still have a bug+  --+  --     https://github.com/tomjaguarpaw/haskell-opaleye/issues/117+  ppChoices (choicePP (P.rmap (O.unsafeCast "int4") O.sum)+                      O.boolAnd+                      (O.stringAgg (O.sqlString ", ")))+            (const (PP.purePP (O.nothingFieldsExplicit (pure emptyChoices))))++arbitraryOrder :: ArbitraryOrder -> O.Order Fields+arbitraryOrder =+  Monoid.mconcat+  . map (\(direction, index) ->+           (case direction of+              Asc  -> \f -> chooseChoice f (O.asc id) (O.asc id) (O.asc id)+              Desc -> \f -> chooseChoice f (O.desc id) (O.desc id) (O.desc id))+           -- If the list is empty we have to conjure up an arbitrary+           -- value of type Field.  We don't know how to order+           -- MaybeFields (yet) so we do the same if we hit a+           -- MaybeFields.+           (\c -> let l = unChoices c+                      len = length l+                  in if len > 0 then+                       case l !! (index `mod` length l) of+                         Left i  -> i+                         Right _ -> CInt 0+                  else+                       CInt 0))+  . unArbitraryOrder++restrictFirstBool :: O.SelectArr Fields Fields+restrictFirstBool = Arrow.arr snd+      <<< Arrow.first O.restrict+      <<< Arrow.arr (firstBoolOrTrue (O.sqlBool True))++instance Show ArbitrarySelect where+  show (ArbitrarySelect q) = maybe "Empty query" id+                              (O.showSqlExplicit unpackFields q)++instance Show ArbitrarySelectMaybe where+  show (ArbitrarySelectMaybe q) =+    maybe "Empty query" id+          (O.showSqlExplicit (O.unpackspecMaybeFields unpackFields) q)++instance Show ArbitrarySelectArr where+  -- We could plug in dummy data here, or maybe just an empty list+  show _ = "ArbitrarySelectArr"++instance Show ArbitraryKleisli where+  -- We could plug in dummy data here, or maybe just an empty list+  show _ = "ArbitraryKleisli"++instance Show ArbitraryFunction where+  show = const "A function"++recurseSafelyOneof :: [TQ.Gen a] -> [TQ.Gen a] -> [TQ.Gen a] -> TQ.Gen a+recurseSafelyOneof r0 r1 r2 =+  recurseSafely (TQ.oneof r0) (TQ.oneof r1) (TQ.oneof r2)++recurseSafely :: TQ.Gen a -> TQ.Gen a -> TQ.Gen a -> TQ.Gen a+recurseSafely r0 r1 r2 = do+    -- The range of choose is inclusive+    c <- TQ.choose (1, 10 :: Int)++    if c <= 3+    then r0+    else if c <= 8+    then r1+    else if c <= 10+    then r2+    else error "Impossible"++instance TQ.Arbitrary ArbitrarySelect where+  arbitrary = recurseSafelyOneof+                  arbitrarySelectRecurse0+                  arbitrarySelectRecurse1+                  arbitrarySelectRecurse2++instance TQ.Arbitrary ArbitrarySelectArr where+  arbitrary = recurseSafelyOneof+                  arbitrarySelectArrRecurse0+                  arbitrarySelectArrRecurse1+                  arbitrarySelectArrRecurse2++instance TQ.Arbitrary ArbitraryKleisli where+  arbitrary = recurseSafelyOneof+                  arbitraryKleisliRecurse0+                  arbitraryKleisliRecurse1+                  arbitraryKleisliRecurse2++-- It would be better if ArbitrarySelect recursively called this, but+-- it will do for now.+instance TQ.Arbitrary ArbitrarySelectMaybe where+  arbitrary = do+    TQ.oneof $+      (fmap . fmap) ArbitrarySelectMaybe $+      map (\fg -> do { ArbitrarySelect q <- TQ.arbitrary+                     ; f <- fg+                     ; return (f q)+                     })+      genSelectArrMaybeMapper+      +++      [ do+          ArbitrarySelect q <- TQ.arbitrary+          return (fmap fieldsToMaybeFields q)+      ]++-- [Note] Testing strategy+--+-- We have to be very careful otherwise we will generate+-- infinite-sized expressions.  On the other hand we probably generate+-- far too small small expressions.  We should probably improve that+-- but explicitly passing a size parameter to the sub-generators.+--+-- The idea here is that only arbitrary... generators can do+-- recursion, i.e. call arbitrary in a way that could lead to other+-- calls of arbitrary.  The gen... functions don't call arbitrary+-- again, but can return functions to which arbitrary argument can be+-- applied by arbitrary... generators.++arbitrarySelectRecurse0 :: [TQ.Gen ArbitrarySelect]+arbitrarySelectRecurse0 =+  (fmap . fmap) ArbitrarySelect $+  genSelect++arbitrarySelectRecurse1 :: [TQ.Gen ArbitrarySelect]+arbitrarySelectRecurse1 =+  (fmap . fmap) ArbitrarySelect $+  -- I'm not sure this is neccessary anymore.  It should be covered by+  -- other generation pathways.+  [ do+      ArbitrarySelectArr q <- TQ.arbitrary+      return (q <<< pure emptyChoices)+  ]+  +++  map (\fg -> do { ArbitrarySelect q <- TQ.arbitrary+                 ; f <- fg+                 ; return (f q) })+      genSelectMapper++arbitrarySelectRecurse2 :: [TQ.Gen ArbitrarySelect]+arbitrarySelectRecurse2 =+    (fmap . fmap) ArbitrarySelect $+    map (\fg -> do { ArbitrarySelect q1 <- TQ.arbitrary+                   ; ArbitrarySelect q2 <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q1 q2)+                   })+    genSelectArrPoly+    +++    map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary+                   ; ArbitrarySelect q2 <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q1 q2)+                   })+    genSelectArrMapper2+    +++    map (\fg -> do { ArbitrarySelect q1 <- TQ.arbitrary+                   ; ArbitrarySelect q2 <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q1 q2)+                   })+    genSelectMapper2++arbitrarySelectArrRecurse0 :: [TQ.Gen ArbitrarySelectArr]+arbitrarySelectArrRecurse0 =+  (fmap . fmap) ArbitrarySelectArr $+     map (fmap ignoreArguments) genSelect+  ++ genSelectArr+  where ignoreArguments = P.lmap (const ())++arbitrarySelectArrRecurse1 :: [TQ.Gen ArbitrarySelectArr]+arbitrarySelectArrRecurse1 =+    (fmap . fmap) ArbitrarySelectArr $+    map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary+                   ; f <- fg+                   ; pure (O.laterally f q) })+        genSelectMapper+    +++    map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q) })+        genSelectArrMapper+    +++    map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary+                   ; f <- fg+                   ; pure (fmap (Choices . pure . Right) (f q)) })+        genSelectArrMaybeMapper+    +++    map (\fg -> do { ArbitraryKleisli q <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q) })+        [ pure O.lateral ]++arbitrarySelectArrRecurse2 :: [TQ.Gen ArbitrarySelectArr]+arbitrarySelectArrRecurse2 =+    (fmap . fmap) ArbitrarySelectArr $+    map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary+                   ; ArbitrarySelectArr q2 <- TQ.arbitrary+                   ; f <- fg+                   ; pure (O.bilaterally f q1 q2) })+        genSelectMapper2+    +++    (+    map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary+                   ; ArbitrarySelectArr q2 <- TQ.arbitrary+                   ; f <- fg+                   ; pure (f q1 q2)+                   }) $+    genSelectArrPoly+    +++    genSelectArrMapper2+    )++arbitraryKleisliRecurse0 :: [TQ.Gen ArbitraryKleisli]+arbitraryKleisliRecurse0 =+  (fmap . fmap) (ArbitraryKleisli . const) genSelect+  ++ [ pure (ArbitraryKleisli pure) ]++arbitraryKleisliRecurse1 :: [TQ.Gen ArbitraryKleisli]+arbitraryKleisliRecurse1 =+  map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary+                 ; f <- fg+                 ; return (ArbitraryKleisli (f q)) })+  [ pure O.viaLateral ]++arbitraryKleisliRecurse2 :: [TQ.Gen ArbitraryKleisli]+arbitraryKleisliRecurse2 =+  map (\fg -> do { ArbitraryKleisli q1 <- TQ.arbitrary+                 ; ArbitraryKleisli q2 <- TQ.arbitrary+                 ; f <- fg+                 ; return (ArbitraryKleisli (f q1 q2)) })+  [ pure (<=<) , pure (liftA2 (liftA2 appendChoices)) ]++genSelect :: [TQ.Gen (O.Select Fields)]+genSelect =+    [ do+        ArbitraryHaskells fields_ <- TQ.arbitrary+        return ((pure . fieldsOfHaskells) fields_)+    , return        (fmap (\(x,y) -> Choices [Left (CInt x), Left (CInt y)])+                          (O.selectTable table1))+    , do+        TQ.oneof [+            do+            ArbitraryHaskellsList l <- TQ.arbitrary+            return (fmap fieldsList (O.valuesSafe (fmap O.toFields l)))+          , -- We test empty lists of values separately, because we+            -- used to not support them+            do+              s <- TQ.choose (0, 5)+              l <- TQ.vectorOf s (pure ())+              return (fmap (const emptyChoices) (O.valuesSafe l))+          ]+    ]++genSelectArr :: [TQ.Gen (O.SelectArr Fields Fields)]+genSelectArr =+    [ do+        f                <- TQ.arbitrary+        return (Arrow.arr (unArbitraryFunction f))++    , do+        return restrictFirstBool+    ]++genSelectMapper :: [TQ.Gen (O.Select Fields -> O.Select Fields)]+genSelectMapper =+    [ do+        return (O.distinctExplicit distinctFields)+    , do+        l                <- TQ.choose (0, 100)+        return (O.limit l)+    , do+        l                <- TQ.choose (0, 100)+        return (O.offset l)+    , do+        o                <- TQ.arbitrary+        return (O.orderBy (arbitraryOrder o))++    , do+        return (O.aggregate aggregateFields)+    , do+        let q' q = P.dimap (\_ -> fst . firstBoolOrTrue (O.sqlBool True))+                           (fieldsList+                            . O.fromMaybeFields (0,+                                                 O.sqlBool True,+                                                 O.justFields (O.sqlString "field"))+                            . fmap listFields)+                           (O.optionalRestrictExplicit unpackFields q)+        return q'+    ]++genSelectMapper2 :: [TQ.Gen (O.Select Fields -> O.Select Fields+                                             -> O.Select Fields)]+genSelectMapper2 =+  [ do+      binaryOperation <- TQ.elements [ O.intersect+                                     , O.intersectAll+                                     , O.union+                                     , O.unionAll+                                     , O.except+                                     , O.exceptAll+                                     ]+      return (arbitraryBinary binaryOperation)+  ]+  where arbitraryBinary binaryOperation q1 q2 =+          (fmap fieldsList+            (binaryOperation+              (fmap listFields q1)+              (fmap listFields q2)))++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+                                    -> O.SelectArr a (O.MaybeFields Fields))]+genSelectArrMaybeMapper =+  [ do+      return (OJ.optionalExplicit unpackFields)+  ]++genSelectArrPoly :: [TQ.Gen (O.SelectArr a Fields+                             -> O.SelectArr a Fields+                             -> O.SelectArr a Fields)]+genSelectArrPoly =+    [ do+        pure (\q1 q2 -> appendChoices <$> q1 <*> q2)+    ]++genSelectArrMapper2 :: [TQ.Gen (O.SelectArr b c+                                -> O.SelectArr a b+                                -> O.SelectArr a c)]+genSelectArrMapper2 =+    [ do+        pure (<<<)+    ]++instance TQ.Arbitrary ArbitraryHaskells where+    arbitrary = arbitraryHaskells 6++-- Postgres strings cannot contain the zero codepoint.  See+--+-- https://www.postgresql.org/message-id/1171970019.3101.328.camel@coppola.muc.ecircle.de+arbitraryPGString :: TQ.Gen String+arbitraryPGString = filter (/= '\0') <$> TQ.arbitrary++arbitraryHaskells :: Int -> TQ.Gen ArbitraryHaskells+arbitraryHaskells size = do+      s <- TQ.choose (0, size)++      l <- TQ.vectorOf s (TQ.oneof+              [ Left  <$> CInt    <$> TQ.arbitrary+              , Left  <$> CBool   <$> TQ.arbitrary+              , Left  <$> CString <$> arbitraryPGString+              , pure (Right Nothing)+              , do+                  ArbitraryHaskells c <- arbitraryHaskells (size `div` 2)+                  return (Right (Just c))+              ])++      return (ArbitraryHaskells (Choices l))++instance TQ.Arbitrary ArbitraryHaskellsList where+  -- We don't want to choose very big lists because we take+  -- products of queries and so their sizes are going to end up+  -- multiplying.+  arbitrary = do+    k <- TQ.choose (0, 5)+    l <- TQ.vectorOf k $ do+      i <- TQ.arbitrary+      b <- TQ.arbitrary+      ms <- TQ.oneof [ pure Nothing+                     , Just <$> arbitraryPGString+                     ]+      pure (i, b, ms)+    return (ArbitraryHaskellsList l)++instance TQ.Arbitrary ArbitraryPositiveInt where+  arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100))++instance TQ.Arbitrary ArbitraryOrder where+  arbitrary = fmap ArbitraryOrder+                   (TQ.listOf ((,)+                               <$> TQ.oneof [return Asc, return Desc]+                               <*> TQ.choose (0, 100)))

@@ -0,0 +1,199 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Opaleye.Test.Fields where++import           Prelude hiding (compare)++import           Wrapped (constructor, asSumProfunctor,+                          constructorDecidable, asDecidable)++import qualified Opaleye as O+import qualified Opaleye.Internal.MaybeFields as OM+import qualified Opaleye.Internal.Values as OV++import           Control.Arrow ((>>>))+import           Control.Applicative (pure)+import qualified Data.Profunctor.Product.Default as D+import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import qualified Data.Functor.Contravariant.Divisible as Divisible+import qualified Data.Maybe as Maybe++data Choice i b s = CInt i | CBool b | CString s deriving (Show, Eq, Ord)++chooseChoice :: Divisible.Decidable f+             => (a -> Choice i b s) -> f i -> f b -> f s -> f a+chooseChoice choose fi fb fs = asDecidable $ proc a -> case choose a of+  CInt i    -> constructorDecidable fi -< i+  CBool b   -> constructorDecidable fb -< b+  CString s -> constructorDecidable fs -< s++newtype Choices m i b s =+  Choices { unChoices :: [Either (Choice i b s) (m (Choices m i b s))] }++deriving instance Show Haskells+deriving instance Eq Haskells+deriving instance Ord Haskells++type SimpleField = Choice (O.Field O.SqlInt4)+                          (O.Field O.SqlBool)+                          (O.Field O.SqlText)+type Fields = Choices O.MaybeFields (O.Field O.SqlInt4)+                                    (O.Field O.SqlBool)+                                    (O.Field O.SqlText)+type Haskells = Choices Maybe Int Bool String++emptyChoices :: Choices m i b s+emptyChoices = Choices []++appendChoices :: Choices m i b s -> Choices m i b s -> Choices m i b s+appendChoices c1 c2 = Choices (unChoices c1 ++ unChoices c2)++ppChoices :: (PP.SumProfunctor p, PP.ProductProfunctor p)+          => p (Choice i b s) (Choice i' b' s')+          -> (p (Choices m i b s) (Choices m' i' b' s')+             -> p (m (Choices m i b s)) (m' (Choices m' i' b' s')))+          -> p (Choices m i b s) (Choices m' i' b' s')+ppChoices p f = ps+  where ps = P.dimap unChoices Choices (PP.list (p PP.+++! f ps))++fieldsOfHaskells :: Haskells -> Fields+fieldsOfHaskells = O.toFieldsExplicit toFieldsFields++fieldsList :: Functor m => (a, b, m s) -> Choices m a b s+fieldsList (x, y, ms) =+  Choices [ Left (CInt x),+            Left (CBool y),+            Right (fmap (Choices . pure . Left . CString) ms)+          ]++type FieldsTuple = (O.Field O.SqlInt4,+                    O.Field O.SqlBool,+                    O.MaybeFields (O.Field O.SqlText))+type HaskellsTuple = (Int, Bool, Maybe String)++listFieldsG :: Functor m+            => Choices m i b s -> i -> b -> s -> m s -> (i, b, m s)+listFieldsG f i b s ms = (fst (firstIntOr i f),+                          fst (firstBoolOrTrue b f),+                          ms')+  where ms' = maybe ms (fmap (fst . firstStringOr s)) (firstMaybe f)++listFields :: Fields -> FieldsTuple+listFields f =+  listFieldsG f 1 (O.sqlBool True) (O.sqlString "xyz") O.nothingFields++listHaskells :: Haskells -> HaskellsTuple+listHaskells f = listFieldsG f 1 True "xyz" Nothing++fieldsToMaybeFields :: Applicative m => Choices m i b s -> m (Choices m i b s)+fieldsToMaybeFields fs = case Maybe.listToMaybe (subMaybeFields fs) of+  Nothing -> pure fs+  Just x  -> x++unpackFields :: O.Unpackspec Fields Fields+unpackFields = defChoicesPP O.unpackspecMaybeFields++distinctNullsFields :: OM.WithNulls O.Distinctspec Fields Fields+distinctNullsFields =+  ppChoices defChoicePP (OM.mapMaybeFieldsWithNulls D.def)++distinctFields :: O.Distinctspec Fields Fields+distinctFields = P.dimap unChoices Choices (PP.list+    (defChoicePP PP.+++! OM.unWithNulls D.def distinctNullsFields))++fromFieldsFields :: O.FromFields Fields Haskells+fromFieldsFields = defChoicesPP O.fromFieldsMaybeFields++toFieldsFields :: O.ToFields Haskells Fields+toFieldsFields =+  defChoicesPP (O.toFieldsMaybeFields (fmap Choices OV.nullspecList))++choicePP :: PP.SumProfunctor p+         => p i1 i2 -> p b1 b2 -> p s1 s2+         -> p (Choice i1 b1 s1) (Choice i2 b2 s2)+choicePP p1 p2 p3 = asSumProfunctor $ proc choice -> case choice of+  CInt i    -> constructor CInt    p1 -< i+  CBool b   -> constructor CBool   p2 -< b+  CString s -> constructor CString p3 -< s++defChoicesPP :: (D.Default p a a', D.Default p b b', D.Default p s s',+                 PP.SumProfunctor p, PP.ProductProfunctor p)+             => (p (Choices m a b s) (Choices m' a' b' s')+                -> p (m (Choices m a b s)) (m' (Choices m' a' b' s')))+             -> p (Choices m a b s) (Choices m' a' b' s')+defChoicesPP = ppChoices defChoicePP++defChoicePP :: (D.Default p a a', D.Default p b b', D.Default p s s',+                PP.SumProfunctor p, PP.ProductProfunctor p)+            => p (Choice a b s) (Choice a' b' s')+defChoicePP = choicePP D.def D.def D.def++-- We could try to be clever and look inside the MaybeFields, but this+-- will do for now.+firstBoolOrTrue :: b -> Choices m a b s -> (b, Choices m a b s)+firstBoolOrTrue true c = (b, c)+  where b = case Maybe.mapMaybe (either isBool (const Nothing)) (unChoices c) of+          []    -> true+          (x:_) -> x++-- We could try to be clever and look inside the MaybeFields, but this+-- will do for now.+firstIntOr :: a -> Choices m a b s -> (a, Choices m a b s)+firstIntOr else_ c = (b, c)+  where b = case Maybe.mapMaybe (either isInt (const Nothing)) (unChoices c) of+          []    -> else_+          (x:_) -> x++-- We could try to be clever and look inside the MaybeFields, but this+-- will do for now.+firstStringOr :: s -> Choices m a b s -> (s, Choices m a b s)+firstStringOr else_ c = (b, c)+  where b = case Maybe.mapMaybe (either isString (const Nothing)) (unChoices c) of+          []    -> else_+          (x:_) -> x++firstMaybe :: Choices m a b s+           -> Maybe (m (Choices m a b s))+firstMaybe c = case Maybe.mapMaybe (either (const Nothing) Just) (unChoices c) of+          []    -> Nothing+          (x:_) -> Just x++isBool :: Choice a b s -> Maybe b+isBool (CInt _)  = Nothing+isBool (CBool l) = Just l+isBool (CString _) = Nothing++isInt :: Choice a b s -> Maybe a+isInt (CInt a)  = Just a+isInt (CBool _) = Nothing+isInt (CString _) = Nothing++isString :: Choice a b s -> Maybe s+isString (CInt _)  = Nothing+isString (CBool _) = Nothing+isString (CString s) = Just s++pairColumns :: Choices m i b s -> (Choices m i b s, Choices m i b s)+pairColumns cs = (evens cs, odds cs)++unpairColums :: (Choices m i b s, Choices m i b s) -> Choices m i b s+unpairColums = uncurry appendChoices++odds :: Choices m i b s -> Choices m i b s+odds (Choices [])     = Choices []+odds (Choices (x:xs)) = Choices (x : unChoices (evens (Choices xs)))++evens :: Choices m i b s -> Choices m i b s+evens (Choices [])     = Choices []+evens (Choices (_:xs)) = odds (Choices xs)++subMaybeFields :: Choices m i b s -> [m (Choices m i b s)]+subMaybeFields = unChoices >>> Maybe.mapMaybe (\case Left _  -> Nothing+                                                     Right r -> Just r)

@@ -1,269 +1,288 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}  module QuickCheck where +import           Prelude hiding (compare, (.), id)++import           Connection (Connection, withConnection)+import           Opaleye.Test.Arbitrary+import           Opaleye.Test.Fields+ import qualified Opaleye as O+import qualified Opaleye.Join as OJ+ import qualified Database.PostgreSQL.Simple as PGS-import qualified Test.QuickCheck as TQ import           Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2)+import qualified Control.Arrow as Arrow+import           Control.Arrow ((<<<))+import           Control.Category (Category, (.), id)+import           Control.Monad (when, (<=<)) import qualified Data.Profunctor.Product.Default as D-import           Data.List (sort)+import qualified Data.Either import qualified Data.List as List import qualified Data.MultiSet as MultiSet+import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP-import qualified Data.Functor.Contravariant.Divisible as Divisible import qualified Data.Monoid as Monoid-import qualified Data.Ord as Ord+import qualified Data.Ord as Ord hiding (compare) import qualified Data.Set as Set import qualified Data.Maybe as Maybe-import qualified Control.Arrow as Arrow+import qualified Test.QuickCheck as TQ+import           Test.QuickCheck ((===), (.&&.)) -twoIntTable :: String-            -> O.Table (O.Column O.SqlInt4, O.Column O.SqlInt4)-                       (O.Column O.SqlInt4, O.Column O.SqlInt4)-twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2")) -table1 :: O.Table (O.Column O.SqlInt4, O.Column O.SqlInt4)-                  (O.Column O.SqlInt4, O.Column O.SqlInt4)-table1 = twoIntTable "table1"--data QueryDenotation a =-  QueryDenotation { unQueryDenotation :: PGS.Connection -> IO [a] }--onList :: ([a] -> [b]) -> QueryDenotation a -> QueryDenotation b-onList f = QueryDenotation . (fmap . fmap) f . unQueryDenotation--type Columns = [Either (O.Column O.SqlInt4) (O.Column O.SqlBool)]-type Haskells = [Either Int Bool]--columnsOfHaskells :: Haskells -> Columns-columnsOfHaskells = O.constantExplicit eitherPP--columnsList :: (a, b) -> [Either a b]-columnsList (x, y) = [Left x, Right y]+arbitraryOrdering :: ArbitraryOrder -> Haskells -> Haskells -> Ord.Ordering+arbitraryOrdering =+  Monoid.mconcat+  . map (\(direction, index) ->+            (case direction of+                Asc  -> id+                Desc -> flip)+            -- If the list is empty we have to conjure up an arbitrary+            -- value of type Field.  We don't know how to order+            -- MaybeFields (yet) so we do the same if we hit a+            -- MaybeFields.+            --+            -- Note that this one will compare CInt Int+            -- to CBool Bool, but it never gets asked to+            -- do so, so we don't care.+            (Ord.comparing (\c -> let l = unChoices c+                                      len = length l+                                  in if len > 0 then+                                       case l !! (index `mod` length l) of+                                         Left i  -> i+                                         Right _ -> CInt 0+                                  else+                                       CInt 0)))+  . unArbitraryOrder -newtype ArbitraryQuery   = ArbitraryQuery (O.Query Columns)-newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Haskells }-                        deriving Show-newtype ArbitraryColumnsList = ArbitraryColumnsList { unArbitraryColumnsList :: [(Int, Bool)] }-                             deriving Show-newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int-                            deriving Show-newtype ArbitraryOrder = ArbitraryOrder { unArbitraryOrder :: [(Order, Int)] }-                      deriving Show-newtype ArbitraryGarble =-  ArbitraryGarble { unArbitraryGarble :: forall a. [a] -> [a] }+newtype SelectArrDenotation a b =+  SelectArrDenotation { unSelectArrDenotation :: PGS.Connection -> [a] -> IO [b] } -data Order = Asc | Desc deriving Show+type SelectDenotation = SelectArrDenotation () -unpackColumns :: O.Unpackspec Columns Columns-unpackColumns = eitherPP+instance Functor (SelectArrDenotation a) where+  fmap f = SelectArrDenotation+           . (fmap . fmap . fmap . fmap) f+           . unSelectArrDenotation -instance Show ArbitraryQuery where-  show (ArbitraryQuery q) = maybe "Empty query" id-                              (O.showSqlForPostgresExplicit unpackColumns q)+instance Applicative (SelectArrDenotation a) where+  pure    = SelectArrDenotation . pure . pure . pure . pure+  f <*> x = SelectArrDenotation ((liftA2 . liftA2 . liftA2 . liftA2) ($)+                                   (unSelectArrDenotation f)+                                   (unSelectArrDenotation x)) -instance Show ArbitraryGarble where-  show = const "A permutation"+instance Category SelectArrDenotation where+  id = SelectArrDenotation (\_ -> pure)+  (.) = \(SelectArrDenotation f) (SelectArrDenotation g) ->+          SelectArrDenotation (\conn -> f conn <=< g conn) -instance TQ.Arbitrary ArbitraryQuery where-  arbitrary = TQ.oneof [-      (ArbitraryQuery . pure . columnsOfHaskells . unArbitraryColumns)-        <$> TQ.arbitrary-    , do-        ArbitraryQuery q1 <- TQ.arbitrary-        ArbitraryQuery q2 <- TQ.arbitrary-        aq ((++) <$> q1 <*> q2)-    , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1)))-    , do-        ArbitraryQuery q <- TQ.arbitrary-        aq (O.distinctExplicit eitherPP q)-    , do-        ArbitraryQuery q <- TQ.arbitrary-        l                <- TQ.choose (0, 100)-        aq (O.limit l q)-    , do-        ArbitraryQuery q <- TQ.arbitrary-        l                <- TQ.choose (0, 100)-        aq (O.offset l q)-    , do-        ArbitraryQuery q <- TQ.arbitrary-        o                <- TQ.arbitrary-        aq (O.orderBy (arbitraryOrder o) q)+runSelectArrDenotation :: SelectArrDenotation a b+                       -> a+                       -> PGS.Connection+                       -> IO [b]+runSelectArrDenotation sab a conn = unSelectArrDenotation sab conn [a] -    , do-        ArbitraryQuery q <- TQ.arbitrary-        f                <- TQ.arbitrary-        aq (fmap (unArbitraryGarble f) q)+onList :: ([a] -> [b]) -> SelectDenotation a -> SelectDenotation b+onList f = SelectArrDenotation . (fmap . fmap . fmap) f . unSelectArrDenotation -    , do-        ArbitraryQuery q <- TQ.arbitrary-        aq (restrictFirstBool Arrow.<<< q)-    , do-        ArbitraryColumnsList l <- TQ.arbitrary-        aq (fmap columnsList (O.values (fmap O.constant l)))-    ]-    where aq = return . ArbitraryQuery+-- This is taking liberties.  Firstly it errors out when two fields+-- are of different types.  It should probably return a Maybe or an+-- Either.  Secondly, it doesn't detect when lists are the same+-- length and it probably should.+--+-- We don't have the ability to aggregate MaybeFields, at least, not+-- yet.  Therefore we just replace them with Nothing.+aggregateDenotation :: [Haskells] -> [Haskells]+aggregateDenotation cs = if null cs+                         then []+                         else (pure+                              . List.foldl1' combine+                              . map emptyOutChoices+                              ) cs+  where combine h1 h2 = Choices (zipWith (curry (\case+          (Left l1, Left l2) -> Left $ case (l1, l2) of+            (CInt  i1, CInt i2)  -> CInt (i1 + i2)+            (CBool b1, CBool b2) -> CBool (b1 && b2)+            (CString s1, CString s2) -> CString (s1 ++ ", " ++ s2)+            _ -> error "Impossible"+          (Right _, Right _) -> Right Nothing+          _ -> error "Impossible")) (unChoices h1) (unChoices h2)) +        emptyOutChoices c = Choices $ flip map (unChoices c) $ \case+            Left l  -> Left l+            Right _ -> Right Nothing -instance TQ.Arbitrary ArbitraryColumns where-    arbitrary = do-      l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1]-                               ++ map (return . Right) [False, True]))-      return (ArbitraryColumns l)+optionalDenotation :: [Haskells] -> [Maybe Haskells]+optionalDenotation = \case+  [] -> [Nothing]+  xs -> map Just xs -instance TQ.Arbitrary ArbitraryColumnsList where-  -- We don't want to choose very big lists because we take-  -- products of queries and so their sizes are going to end up-  -- multiplying.-  arbitrary = do-    k <- TQ.choose (0, 5)-    l <- TQ.vectorOf k TQ.arbitrary-    return (ArbitraryColumnsList l)+optionalRestrictDenotation :: [Haskells] -> [Maybe Haskells]+optionalRestrictDenotation = optionalDenotation . restrictFirstBoolList -instance TQ.Arbitrary ArbitraryPositiveInt where-  arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100))+traverseDenotation :: SelectArrDenotation a Haskells+                   -> SelectDenotation (Maybe a)+                   -> SelectDenotation (Maybe Haskells)+traverseDenotation (SelectArrDenotation f) (SelectArrDenotation q) =+  (SelectArrDenotation (\conn l -> do+                           qr <- q conn l+                           let nothings :: [()]+                               (nothings, justs) =+                                 Data.Either.partitionEithers+                                   (map (\case+                                            Nothing -> Left ()+                                            Just j -> Right j)+                                        qr) -instance TQ.Arbitrary ArbitraryOrder where-  arbitrary = fmap ArbitraryOrder-                   (TQ.listOf ((,)-                               <$> TQ.oneof [return Asc, return Desc]-                               <*> TQ.choose (0, 100)))+                           justs' <- f conn justs+                           let _ = justs' :: [Haskells] -odds :: [a] -> [a]-odds []     = []-odds (x:xs) = x : evens xs+                           return ((Just <$> justs')+                                   ++ (Nothing <$ nothings)))) -evens :: [a] -> [a]-evens []     = []-evens (_:xs) = odds xs+lateralDenotation :: (a -> SelectDenotation r)+               -> SelectArrDenotation a r+lateralDenotation f = SelectArrDenotation (\conn l ->+  concatMapM (\r -> unSelectArrDenotation (f r) conn [()]) l) -instance TQ.Arbitrary ArbitraryGarble where-  arbitrary = do-    i <- TQ.choose (0 :: Int, 4)+pureList :: [a] -> SelectDenotation a+pureList = SelectArrDenotation . pure . pure . pure -    return (ArbitraryGarble (\xs ->-        if i == 0 then-          evens xs ++ odds xs-        else if i == 1 then-          evens xs ++ evens xs-        else if i == 2 then-          odds xs ++ odds xs-        else if i == 3 then-          evens xs-        else-          odds xs))+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f -arbitraryOrder :: ArbitraryOrder -> O.Order Columns-arbitraryOrder = Monoid.mconcat-                 . map (\(direction, index) ->-                         (case direction of-                             Asc  -> (\f -> Divisible.choose  f (O.asc id) (O.asc id))-                             Desc -> (\f -> Divisible.choose  f (O.desc id) (O.desc id)))-                         -- If the list is empty we have to conjure up-                         -- an arbitrary value of type Column-                         (\l -> let len = length l-                                in if len > 0 then-                                     l !! (index `mod` length l)-                                   else-                                     Left 0))-                 . unArbitraryOrder+denotationExplicit :: O.FromFields fields a+                   -> O.Select fields+                   -> SelectDenotation a+denotationExplicit qr q =+  SelectArrDenotation (\conn rs ->+    flip concatMapM rs (\() -> O.runSelectExplicit qr conn q)) -arbitraryOrdering :: ArbitraryOrder -> Haskells -> Haskells -> Ord.Ordering-arbitraryOrdering = Monoid.mconcat-                    . map (\(direction, index) ->-                            (case direction of-                                Asc  -> id-                                Desc -> flip)-                         -- If the list is empty we have to conjure up-                         -- an arbitrary value of type Column-                         ---                         -- Note that this one will compare Left Int-                         -- to Right Bool, but it never gets asked to-                         -- do so, so we don't care.-                            (Ord.comparing (\l -> let len = length l-                                                  in if len > 0 then-                                                        l !! (index `mod` length l)-                                                     else-                                                        Left 0)))-                    . unArbitraryOrder+denotation :: O.Select Fields -> SelectDenotation Haskells+denotation = denotationExplicit fromFieldsFields -instance Functor QueryDenotation where-  fmap f = QueryDenotation . (fmap . fmap . fmap) f .unQueryDenotation+denotationArr :: O.SelectArr FieldsTuple Fields+              -> SelectArrDenotation HaskellsTuple Haskells+denotationArr q =+  SelectArrDenotation (\conn hs ->+      let fs = O.valuesSafe (map O.toFields hs)+      in O.runSelectExplicit fromFieldsFields conn (q <<< fs)) -pureList :: [a] -> QueryDenotation a-pureList = QueryDenotation . pure . pure+denotation2 :: O.Select (Fields, Fields)+            -> SelectDenotation (Haskells, Haskells)+denotation2 = denotationExplicit (fromFieldsFields PP.***! fromFieldsFields) -instance Applicative QueryDenotation where-  pure    = QueryDenotation . pure . pure . pure-  f <*> x = QueryDenotation ((liftA2 . liftA2 . liftA2) ($)-                                (unQueryDenotation f) (unQueryDenotation x))+denotationMaybeFields :: O.Select (O.MaybeFields Fields)+                      -> SelectDenotation (Maybe Haskells)+denotationMaybeFields =+  denotationExplicit (O.fromFieldsMaybeFields fromFieldsFields) -denotation :: O.QueryRunner columns a -> O.Query columns -> QueryDenotation a-denotation qr q = QueryDenotation (\conn -> O.runQueryExplicit qr conn q)+unSelectDenotations :: Connection+                    -> SelectDenotation a+                    -> SelectDenotation b+                    -> ([a] -> [b] -> IO TQ.Property)+                    -> IO TQ.Property+unSelectDenotations conn one two k = unSelectArrDenotations conn one two () k -denotation' :: O.Query Columns -> QueryDenotation Haskells-denotation' = denotation eitherPP+unSelectArrDenotations :: Connection+                       -> SelectArrDenotation i a+                       -> SelectArrDenotation i b+                       -> i+                       -> ([a] -> [b] -> IO TQ.Property)+                       -> IO TQ.Property+unSelectArrDenotations conn one two i k = do+  withConnection conn (runSelectArrDenotation one i) >>= \case+    Left _ -> discard+    Right oner -> withConnection conn (runSelectArrDenotation two i) >>= \case+      Left _ -> discard+      Right twor -> k oner twor -denotation2 :: O.Query (Columns, Columns)-            -> QueryDenotation (Haskells, Haskells)-denotation2 = denotation (eitherPP PP.***! eitherPP)+  where discard = do+          putStrLn "A denotation failed to run but it was not our fault"+          pure (TQ.property TQ.Discard)  -- { Comparing the results --- compareNoSort is stronger than compare' so prefer to use it where possible-compareNoSort :: Eq a-              => PGS.Connection-              -> QueryDenotation a-              -> QueryDenotation a-              -> IO Bool-compareNoSort conn one two = do-  one' <- unQueryDenotation one conn-  two' <- unQueryDenotation two conn-  return (one' == two')+-- compareNoSort is stronger than compare so prefer to use it where+-- possible.  If the queries do not compare equal but do compare equal+-- sorted then switch to "compare".  That's no big deal.+compareNoSort :: (Ord a, Show a)+              => Connection+              -> SelectDenotation a+              -> SelectDenotation a+              -> IO TQ.Property+compareNoSort conn one two =+  unSelectDenotations conn one two $ \one' two' -> do+  when (one' /= two')+       (putStrLn $ if List.sort one' == List.sort two'+                   then "[but they are equal sorted]"+                   else "AND THEY'RE NOT EVEN EQUAL SORTED!") -compare' :: Ord a-         => PGS.Connection-         -> QueryDenotation a-         -> QueryDenotation a-         -> IO Bool-compare' conn one two = do-  one' <- unQueryDenotation one conn-  two' <- unQueryDenotation two conn-  return (sort one' == sort two')+  return (one' === two') -compareSortedBy :: Ord a+compare :: (Show a, Ord a)+         => Connection+         -> SelectDenotation a+         -> SelectDenotation a+         -> IO TQ.Property+compare conn one two = unSelectDenotations conn one two $ \one' two' ->+  return (List.sort one' === List.sort two')++compareSortedBy :: (Show a, Ord a)                 => (a -> a -> Ord.Ordering)-                -> PGS.Connection-                -> QueryDenotation a-                -> QueryDenotation a-                -> IO Bool-compareSortedBy o conn one two = do-  one' <- unQueryDenotation one conn-  two' <- unQueryDenotation two conn-  return ((sort one' == sort two')-          && isSortedBy o one')+                -> Connection+                -> SelectDenotation a+                -> SelectDenotation a+                -> IO TQ.Property+compareSortedBy o conn one two = unSelectDenotations conn one two $ \one' two' ->+  return ((List.sort one' === List.sort two')+          .&&. isSortedBy o one')  -- }  -- { The tests -columns :: PGS.Connection -> ArbitraryColumns -> IO Bool-columns conn (ArbitraryColumns c) =-  compareNoSort conn (denotation' (pure (columnsOfHaskells c)))+fields :: Connection -> ArbitraryHaskells -> IO TQ.Property+fields conn (ArbitraryHaskells c) =+  compareNoSort conn (denotation (pure (fieldsOfHaskells c)))                      (pure c) -fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool-fmap' conn f (ArbitraryQuery q) =-  compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q))-                     (onList (fmap (unArbitraryGarble f)) (denotation' q))+compose :: Connection+        -> ArbitrarySelectArr+        -> ArbitrarySelect+        -> IO TQ.Property+compose conn (ArbitrarySelectArr a) (ArbitrarySelect q) = do+  compare conn (denotation (a' . Arrow.arr listFields . q))+               (denotationArr a' . fmap listHaskells (denotation q))+    where a' = a . Arrow.arr fieldsList -apply :: PGS.Connection -> ArbitraryQuery -> ArbitraryQuery -> IO Bool-apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) =-  compare' conn (denotation2 ((,) <$> q1 <*> q2))-                ((,) <$> denotation' q1 <*> denotation' q2) +-- Would prefer to write 'compare conn (denotation id) id' but that+-- requires extending compare to compare SelectArrs.+identity :: Connection+         -> ArbitrarySelect+         -> IO TQ.Property+identity conn (ArbitrarySelect q) = do+  compare conn (denotation (id . q))+               (id . denotation q)++fmap' :: Connection -> ArbitraryFunction -> ArbitrarySelect -> IO TQ.Property+fmap' conn (ArbitraryFunction f) (ArbitrarySelect q) =+  compareNoSort conn (denotation (fmap f q))+                     (fmap f (denotation q))++apply :: Connection -> ArbitrarySelect -> ArbitrarySelect -> IO TQ.Property+apply conn (ArbitrarySelect q1) (ArbitrarySelect q2) =+  compare conn (denotation2 ((,) <$> q1 <*> q2))+                ((,) <$> denotation q1 <*> denotation q2)+ -- When combining arbitrary queries with the applicative product <*> -- the limit of the denotation is not always the denotation of the -- limit.  Without some ordering applied before the limit the returned@@ -272,77 +291,134 @@ -- the remainder under the applied ordering. -- -- Strangely the same caveat doesn't apply to offset.-limit :: PGS.Connection+limit :: Connection       -> ArbitraryPositiveInt-      -> ArbitraryQuery+      -> ArbitrarySelect       -> ArbitraryOrder-      -> IO Bool-limit conn (ArbitraryPositiveInt l) (ArbitraryQuery q) o = do+      -> IO TQ.Property+limit conn (ArbitraryPositiveInt l) (ArbitrarySelect q) o = do   let q' = O.limit l (O.orderBy (arbitraryOrder o) q) -  one' <- unQueryDenotation (denotation' q') conn-  two' <- unQueryDenotation (denotation' q) conn--  let remainder = MultiSet.fromList two'-                  `MultiSet.difference`-                  MultiSet.fromList one'-      maxChosen :: Maybe Haskells-      maxChosen = maximumBy (arbitraryOrdering o) one'-      minRemain :: Maybe Haskells-      minRemain = minimumBy (arbitraryOrdering o) (MultiSet.toList remainder)-      cond :: Maybe Bool-      cond = lteBy (arbitraryOrdering o) <$> maxChosen <*> minRemain-      condBool :: Bool-      condBool = Maybe.fromMaybe True cond+  unSelectDenotations conn (denotation q') (denotation q) $ \one' two' -> do+      let remainder = MultiSet.fromList two'+                      `MultiSet.difference`+                      MultiSet.fromList one'+          maxChosen :: Maybe Haskells+          maxChosen = maximumBy (arbitraryOrdering o) one'+          minRemain :: Maybe Haskells+          minRemain = minimumBy (arbitraryOrdering o) (MultiSet.toList remainder)+          cond :: Maybe Bool+          cond = lteBy (arbitraryOrdering o) <$> maxChosen <*> minRemain+          condBool :: Bool+          condBool = Maybe.fromMaybe True cond -  return ((length one' == min l (length two'))-          && condBool)+      return ((length one' === min l (length two'))+              .&&. condBool) -offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool-offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) =-  compareNoSort conn (denotation' (O.offset l q))-                     (onList (drop l) (denotation' q))+offset :: Connection -> ArbitraryPositiveInt -> ArbitrarySelect+       -> IO TQ.Property+offset conn (ArbitraryPositiveInt l) (ArbitrarySelect q) =+  compareNoSort conn (denotation (O.offset l q))+                     (onList (drop l) (denotation q)) -order :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool-order conn o (ArbitraryQuery q) =+order :: Connection -> ArbitraryOrder -> ArbitrarySelect -> IO TQ.Property+order conn o (ArbitrarySelect q) =   compareSortedBy (arbitraryOrdering o)                   conn-                  (denotation' (O.orderBy (arbitraryOrder o) q))-                  (denotation' q)+                  (denotation (O.orderBy (arbitraryOrder o) q))+                  (denotation q) -distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool-distinct conn (ArbitraryQuery q) =-  compare' conn (denotation' (O.distinctExplicit eitherPP q))-                (onList nub (denotation' q))+distinct :: Connection -> ArbitrarySelect -> IO TQ.Property+distinct conn (ArbitrarySelect q) =+  compare conn (denotation (O.distinctExplicit distinctFields q))+                (onList nub (denotation q))  -- When we added <*> to the arbitrary queries we started getting some -- consequences to do with the order of the returned rows and so -- restrict had to start being compared sorted.-restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool-restrict conn (ArbitraryQuery q) =-  compare' conn (denotation' (restrictFirstBool Arrow.<<< q))-                (onList restrictFirstBoolList (denotation' q))+restrict :: Connection -> ArbitrarySelect -> IO TQ.Property+restrict conn (ArbitrarySelect q) =+  compare conn (denotation (restrictFirstBool <<< q))+                (onList restrictFirstBoolList (denotation q)) -values :: PGS.Connection -> ArbitraryColumnsList -> IO Bool-values conn (ArbitraryColumnsList l) =-  compareNoSort conn (denotation' (fmap columnsList (O.values (fmap O.constant l))))-                     (pureList (fmap columnsList l))+values :: Connection -> ArbitraryHaskellsList -> IO TQ.Property+values conn (ArbitraryHaskellsList l) =+  compareNoSort conn+                (denotation (fmap fieldsList (O.valuesSafe (fmap O.toFields l))))+                (pureList (fmap fieldsList l)) +-- We test values entries of length two in values, and values entries+-- of length zero here.  Ideally we would find some way to merge them.+valuesEmpty :: Connection -> [()] -> IO TQ.Property+valuesEmpty conn l =+  compareNoSort conn+                (denotationExplicit D.def (O.valuesSafe l))+                (pureList l)++aggregate :: Connection -> ArbitrarySelect -> IO TQ.Property+aggregate conn (ArbitrarySelect q) =+  compareNoSort conn (denotation (O.aggregate aggregateFields q))+                     (onList aggregateDenotation (denotation q))+++label :: Connection -> String -> ArbitrarySelect -> IO TQ.Property+label conn comment (ArbitrarySelect q) =+  compareNoSort conn (denotation (O.label comment q))+                     (denotation q)++optional :: Connection -> ArbitrarySelect -> IO TQ.Property+optional conn (ArbitrarySelect q) =+  compare conn (denotationMaybeFields (OJ.optionalExplicit unpackFields q))+               (onList optionalDenotation (denotation q))++optionalRestrict :: Connection -> ArbitrarySelect -> IO TQ.Property+optionalRestrict conn (ArbitrarySelect q) =+  compare conn (denotationMaybeFields q1)+               (onList optionalRestrictDenotation (denotation q))+  where q1 = P.lmap (\() -> fst . firstBoolOrTrue (O.sqlBool True))+                    (O.optionalRestrictExplicit unpackFields q)++maybeFieldsToSelect :: Connection -> ArbitrarySelectMaybe -> IO TQ.Property+maybeFieldsToSelect conn (ArbitrarySelectMaybe q) =+  compare conn (denotation (O.maybeFieldsToSelect <<< q))+               (onList (Maybe.maybeToList =<<) (denotationMaybeFields q))++traverseMaybeFields :: Connection+                    -> ArbitrarySelectArr+                    -> ArbitrarySelectMaybe+                    -> IO TQ.Property+traverseMaybeFields conn (ArbitrarySelectArr q) (ArbitrarySelectMaybe qm) =+  compare conn+    (denotationMaybeFields (travMF q' . Arrow.arr (fmap listFields) . qm))+    (traverseDenotation (denotationArr q')+       ((fmap . fmap) listHaskells (denotationMaybeFields qm)))+  where u = unpackFields+        q' = q . Arrow.arr fieldsList+        travMF = O.traverseMaybeFieldsExplicit D.def u++lateral :: Connection+        -> ArbitraryKleisli+        -> ArbitrarySelect+        -> IO TQ.Property+lateral conn (ArbitraryKleisli f) (ArbitrarySelect q) =+  compare conn (lateralDenotation denotation_f . denotation_q)+               (denotationArr (O.lateral f') . denotation_q)+  where _ = f :: Fields -> O.Select Fields++        f' :: FieldsTuple -> O.Select Fields+        f' = f . Arrow.arr fieldsList++        denotation_q :: SelectDenotation HaskellsTuple+        denotation_q = fmap listHaskells (denotation q)++        denotation_f  :: HaskellsTuple -> SelectDenotation Haskells+        denotation_f = denotation . f' . O.toFields+ {- TODO -  * Aggregation-  * Binary operations-      * union-      * unionAll-      * intersect-      * intersectAll-      * except-      * exceptAll   * Nullability-  * Left join-  * Label (check it has no effect)   * Operators (mathematical, logical, etc.)-  * >>>?+  * Use traverseMaybeFields in generated queries  -} @@ -350,30 +426,39 @@  -- { Running the QuickCheck -run :: PGS.Connection -> IO ()+-- One way that the property tests can fail is because of LIMIT and+-- OFFSET.  It seems that a query returning LIMIT or OFFSET does not+-- always return the same result when it is part of a larger query.+-- This happens rarely.  We could sort before LIMIT or OFFSET to make+-- it even rarer.++run :: Connection -> IO () run conn = do   let prop1 p = fmap          TQ.ioProperty (p conn)       prop2 p = (fmap . fmap) TQ.ioProperty (p conn)       prop3 p = (fmap . fmap . fmap) TQ.ioProperty (p conn)        test1 :: (Show a, TQ.Arbitrary a, TQ.Testable prop)-               => (PGS.Connection -> a -> IO prop) -> IO ()+               => (Connection -> a -> IO prop) -> IO ()       test1 = t . prop1        test2 :: (Show a1, Show a2, TQ.Arbitrary a1, TQ.Arbitrary a2,                 TQ.Testable prop)-               => (PGS.Connection -> a1 -> a2 -> IO prop) -> IO ()+               => (Connection -> a1 -> a2 -> IO prop) -> IO ()       test2 = t . prop2        test3 :: (Show a1, Show a2, Show a3,                 TQ.Arbitrary a1, TQ.Arbitrary a2, TQ.Arbitrary a3,                 TQ.Testable prop)-               => (PGS.Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()+               => (Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()       test3 = t . prop3 -      t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p+      t p = errorIfNotSuccess+        =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p -  test1 columns+  test1 identity+  test2 compose+  test1 fields   test2 fmap'   test2 apply   test3 limit@@ -382,6 +467,14 @@   test1 distinct   test1 restrict   test1 values+  test1 valuesEmpty+  test1 aggregate+  test2 label+  test1 optional+  test1 optionalRestrict+  test1 maybeFieldsToSelect+  test2 traverseMaybeFields+  test2 lateral  -- } @@ -390,11 +483,6 @@ nub :: Ord a => [a] -> [a] nub = Set.toList . Set.fromList -eitherPP :: (D.Default p a a', D.Default p b b',-             PP.SumProfunctor p, PP.ProductProfunctor p)-         => p [Either a b] [Either a' b']-eitherPP = PP.list (D.def PP.+++! D.def)- -- Replace this with `isSuccess` when the following issue is fixed -- --     https://github.com/nick8325/quickcheck/issues/220@@ -402,22 +490,6 @@ errorIfNotSuccess r = case r of   TQ.Success {} -> return ()   _             -> error "Failed"--firstBoolOrTrue :: b -> [Either a b] -> (b, [Either a b])-firstBoolOrTrue true c = (b, c)-  where b = case Maybe.mapMaybe isBool c of-          []    -> true-          (x:_) -> x--isBool :: Either a b-       -> Maybe b-isBool (Left _)  = Nothing-isBool (Right l) = Just l--restrictFirstBool :: O.QueryArr Columns Columns-restrictFirstBool = Arrow.arr snd-      Arrow.<<< Arrow.first O.restrict-      Arrow.<<< Arrow.arr (firstBoolOrTrue (O.pgBool True))  restrictFirstBoolList :: [Haskells] -> [Haskells] restrictFirstBoolList = map snd

@@ -24,10 +24,13 @@ import qualified Database.PostgreSQL.Simple       as PGS import qualified Database.PostgreSQL.Simple.Range as R import           GHC.Int                          (Int64)-import           Opaleye                          (Column, Nullable, Query,-                                                   QueryArr, (.==), (.>))+import           Opaleye                          (Field, Nullable, Select,+                                                   SelectArr, (.==), (.>)) import qualified Opaleye                          as O import qualified Opaleye.Internal.Aggregate       as IA+import           Opaleye.Internal.RunQuery        (DefaultFromField)+import           Opaleye.Internal.MaybeFields     as OM+import qualified Connection import qualified QuickCheck import           System.Environment               (lookupEnv) import           Test.Hspec@@ -40,132 +43,121 @@ Status ====== -The tests here are very superficial and pretty much the bare mininmum-that needs to be tested.+The Hspec tests are very superficial and pretty much the bare mininmum+that needs to be tested.  The property tests are very thorough, but+could be made even more thorough.   Future ====== -The overall approach to testing should probably go as follows.--1. Test all individual units of functionality by running them on a-   table and checking that they produce the expected result.  This type-   of testing is amenable to the QuickCheck approach if we reimplement-   the individual units of functionality in Haskell.--2. Test that "the denotation is an arrow morphism" is correct.  I-   think in combination with 1. this is all that will be required to-   demonstrate that the library is correct.--   "The denotation is an arrow morphism" means that for each arrow-   operation, the denotation preserves the operation.  If we have--       f :: QueryArr wiresa wiresb--   then [f] should be something like--       [f] :: a -> IO [b]-       f as = runQuery (toValues as >>> f)--   For example, take the operation >>>.  We need to check that--       [f >>> g] = [f] >>> [g]+The property testing strategy is to define a denotation for SelectArrs+and to show that the denotation of two SelectArrs combined with an+operation is the same as using the operation to combine the+denotations.  The denotation that we will choose is roughly `Kleisli+[]` but we have to do IO operations over a Postgres connection so it's+slightly different in practice in a way that doesn't impinge on what I+am about to say. -   for all f and g, where [] means the denotation.  We would also want-   to check that+For example, using brackets "[.]" to stand for denotation, we want to+ensure the property -       [id] = id+* [f <<< g] = [f] <<< [g] -   and+That is, running `f <<< g` on some input should be the same as running+`g` on the input, followed by running `f` on the output of `g`.+Likewise we want to ensure typeclass-general properties like -       [first f] = first [f]+* [id] = id -   I think checking these operations is sufficient because all the-   other QueryArr operations are implemented in terms of them.+* [f <*> g] = [f] <*> [g] -   (Here I'm taking a slight liberty as `a -> IO [b]` is not directly-   an arrow, but it could be made one straightforwardly.  (For the laws-   to be satisfied, perhaps we have to assume that the IO actions-   commute.))+as well as Postgres-specific properties like -   I don't think this type of testing is amenable to QuickCheck.  It-   seems we have to check the properties for arbitrary arrows indexed by-   arbitrary types.  I don't think QuickCheck supports this sort of-   randomised testing.+* [restrict] = guard -Note-----+* [limit n q] = arr (take n) . [q] -This seems to be equivalent to just reimplementing Opaleye in-Haskell-side terms and comparing the results of queries run in both-ways.+The property tests are not written quite as neatly as this because+there is a lot of scaffolding to make things line up.  It's probably+possible to simplify the property tests though.  -}  twoIntTable :: String-            -> O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+            -> O.Table (Field O.SqlInt4, Field O.SqlInt4)+                       (Field O.SqlInt4, Field O.SqlInt4) twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2")) -table1 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+table1 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                  (Field O.SqlInt4, Field O.SqlInt4) table1 = twoIntTable "table1" -table1F :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+table1F :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                   (Field O.SqlInt4, Field O.SqlInt4) table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1 --- This is implicitly testing our ability to handle upper case letters in table names.-table2 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+-- This is implicitly testing our ability to handle upper case letters+-- in table names.+table2 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                  (Field O.SqlInt4, Field O.SqlInt4) table2 = twoIntTable "TABLE2" -table3 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+table3 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                  (Field O.SqlInt4, Field O.SqlInt4) table3 = twoIntTable "table3" -table4 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)+table4 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                  (Field O.SqlInt4, Field O.SqlInt4) table4 = twoIntTable "table4" -table5 :: O.Table (Maybe (Column O.SqlInt4), Maybe (Column  O.SqlInt4))-                  (Column O.SqlInt4, Column O.SqlInt4)-table5 = O.TableWithSchema "public" "table5" (PP.p2 (O.optional "column1", O.optional "column2"))+table5 :: O.Table (Maybe (Field O.SqlInt4), Maybe (Field  O.SqlInt4))+                  (Field O.SqlInt4, Field O.SqlInt4)+table5 = O.TableWithSchema "public" "table5"+  (PP.p2 (O.optional "column1", O.optional "column2")) -table6 :: O.Table (Column O.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText)+table6 :: O.Table (Field O.SqlText, Field O.SqlText)+                  (Field O.SqlText, Field O.SqlText) table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2")) -table7 :: O.Table (Column O.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText)+table7 :: O.Table (Field O.SqlText, Field O.SqlText)+                  (Field O.SqlText, Field O.SqlText) table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2")) -table8 :: O.Table (Column O.SqlJson) (Column O.SqlJson)+table8 :: O.Table (Field O.SqlJson) (Field O.SqlJson) table8 = O.Table "table8" (O.required "column1") -table9 :: O.Table (Column O.SqlJsonb) (Column O.SqlJsonb)+table9 :: O.Table (Field O.SqlJsonb) (Field O.SqlJsonb) table9 = O.Table "table9" (O.required "column1") -table10 :: O.Table (Column O.SqlInt4) (Column O.SqlInt4)+table10 :: O.Table (Field O.SqlInt4) (Field O.SqlInt4) table10 = O.Table "table10" (O.required "column1") -tableKeywordColNames :: O.Table (Column O.SqlInt4, Column O.SqlInt4)-                                (Column O.SqlInt4, Column O.SqlInt4)-tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where"))+tableKeywordColNames :: O.Table (Field O.SqlInt4, Field O.SqlInt4)+                                (Field O.SqlInt4, Field O.SqlInt4)+tableKeywordColNames = O.Table "keywordtable"+  (PP.p2 (O.required "column", O.required "where")) -table1Q :: Query (Column O.SqlInt4, Column O.SqlInt4)-table1Q = O.queryTable table1+table1Q :: Select (Field O.SqlInt4, Field O.SqlInt4)+table1Q = O.selectTable table1 -table2Q :: Query (Column O.SqlInt4, Column O.SqlInt4)-table2Q = O.queryTable table2+table2Q :: Select (Field O.SqlInt4, Field O.SqlInt4)+table2Q = O.selectTable table2 -table3Q :: Query (Column O.SqlInt4, Column O.SqlInt4)-table3Q = O.queryTable table3+table3Q :: Select (Field O.SqlInt4, Field O.SqlInt4)+table3Q = O.selectTable table3 -table6Q :: Query (Column O.SqlText, Column O.SqlText)-table6Q = O.queryTable table6+table6Q :: Select (Field O.SqlText, Field O.SqlText)+table6Q = O.selectTable table6 -table7Q :: Query (Column O.SqlText, Column O.SqlText)-table7Q = O.queryTable table7+table7Q :: Select (Field O.SqlText, Field O.SqlText)+table7Q = O.selectTable table7 -table8Q :: Query (Column O.SqlJson)-table8Q = O.queryTable table8+table8Q :: Select (Field O.SqlJson)+table8Q = O.selectTable table8 -table9Q :: Query (Column O.SqlJsonb)-table9Q = O.queryTable table9+table9Q :: Select (Field O.SqlJsonb)+table9Q = O.selectTable table9  table1dataG :: Num a => [(a, a)] table1dataG = [ (1, 100)@@ -176,8 +168,8 @@ table1data :: [(Int, Int)] table1data = table1dataG -table1columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]-table1columndata = table1dataG+table1fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]+table1fielddata = table1dataG  table2dataG :: Num a => [(a, a)] table2dataG = [ (1, 100)@@ -186,8 +178,8 @@ table2data :: [(Int, Int)] table2data = table2dataG -table2columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]-table2columndata = table2dataG+table2fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]+table2fielddata = table2dataG  table3dataG :: Num a => [(a, a)] table3dataG = [ (1, 50) ]@@ -195,8 +187,8 @@ table3data :: [(Int, Int)] table3data = table3dataG -table3columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]-table3columndata = table3dataG+table3fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]+table3fielddata = table3dataG  table4dataG :: Num a => [(a, a)] table4dataG = [ (1, 10)@@ -205,20 +197,21 @@ table4data :: [(Int, Int)] table4data = table4dataG -table4columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]-table4columndata = table4dataG+table4fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]+table4fielddata = table4dataG  table6data :: [(String, String)] table6data = [("xy", "a"), ("z", "a"), ("more text", "a")] -table6columndata :: [(Column O.SqlText, Column O.SqlText)]-table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data+table6fielddata :: [(Field O.SqlText, Field O.SqlText)]+table6fielddata = map (\(field1, field2) ->+  (O.sqlString field1, O.sqlString field2)) table6data  table7data :: [(String, String)] table7data = [("foo", "c"), ("bar", "a"), ("baz", "b")] -table7columndata :: [(Column O.SqlText, Column O.SqlText)]-table7columndata = map (O.pgString *** O.pgString) table7data+table7fielddata :: [(Field O.SqlText, Field O.SqlText)]+table7fielddata = map (O.sqlString *** O.sqlString) table7data  table8data :: [Json.Value] table8data = [ Json.object@@ -228,20 +221,20 @@                ]              ] -table8columndata :: [Column O.SqlJson]-table8columndata = map O.pgValueJSON table8data+table8fielddata :: [Field O.SqlJson]+table8fielddata = map O.sqlValueJSON table8data -table9columndata :: [Column O.SqlJsonb]-table9columndata = map O.pgValueJSONB table8data+table9fielddata :: [Field O.SqlJsonb]+table9fielddata = map O.sqlValueJSONB table8data  -- We have to quote the table names here because upper case letters in -- table names are treated as lower case unless the name is quoted! dropAndCreateTable :: String -> (String, [String]) -> PGS.Query-dropAndCreateTable columnType (t, cols) = String.fromString drop_+dropAndCreateTable fieldType (t, cols) = String.fromString drop_   where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"                 ++ "CREATE TABLE \"public\".\"" ++ t ++ "\""                 ++ " (" ++ commas cols ++ ");"-        integer c = "\"" ++ c ++ "\"" ++ " " ++ columnType+        integer c = "\"" ++ c ++ "\"" ++ " " ++ fieldType         commas = L.intercalate "," . map integer  dropAndCreateTableInt :: (String, [String]) -> PGS.Query@@ -270,28 +263,28 @@ dropAndCreateTablePk (t, cols) = String.fromString drop_   where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"                 ++ "CREATE TABLE \"public\".\"" ++ t ++ "\""-                ++ " (" ++ allColumns ++ ");"+                ++ " (" ++ allFields ++ ");"         pk c = "\"" ++ c ++ "\"" ++ " integer primary key"         integer c = "\"" ++ c ++ "\"" ++ " integer"         commas = L.intercalate ","-        allColumns = commas $ [pk $ head cols] ++ map integer (tail cols)+        allFields = commas $ [pk $ head cols] ++ map integer (tail cols)  type Table_ = (String, [String])  -- This should ideally be derived from the table definition above-columns2 :: String -> Table_-columns2 t = (t, ["column1", "column2"])+fields2 :: String -> Table_+fields2 t = (t, ["column1", "column2"])  -- This should ideally be derived from the table definition above tables :: [Table_]-tables = map columns2 ["table1", "TABLE2", "table3", "table4"]+tables = map fields2 ["table1", "TABLE2", "table3", "table4"]          ++ [("keywordtable", ["column", "where"])]  serialTables :: [Table_]-serialTables = map columns2 ["table5"]+serialTables = map fields2 ["table5"]  textTables :: [Table_]-textTables = map columns2 ["table6", "table7"]+textTables = map fields2 ["table6", "table7"]  jsonTables :: [Table_] jsonTables = [("table8", ["column1"])]@@ -319,77 +312,85 @@  type Test = SpecWith PGS.Connection -testH :: D.Default O.QueryRunner wires haskells =>-         Query wires+testH :: D.Default O.FromFields fields haskells =>+         Select fields          -> ([haskells] -> IO expectation)          -> PGS.Connection          -> IO expectation  testH q p conn = do-  result <- O.runQuery conn q+  result <- O.runSelect conn q   p result -queryShouldReturnSorted :: (D.Default O.QueryRunner wires haskells, Show haskells, Ord haskells) =>-         Query wires+selectShouldReturnSorted :: (D.Default O.FromFields fields haskells+                            , Show haskells, Ord haskells) =>+         Select fields          -> [haskells]          -> PGS.Connection          -> Expectation-queryShouldReturnSorted q expected = testH q (\res -> L.sort res `shouldBe` L.sort expected)+selectShouldReturnSorted q expected = testH q (\res ->+  L.sort res `shouldBe` L.sort expected)  testSelect :: Test-testSelect = it "selects" $ table1Q `queryShouldReturnSorted` table1data+testSelect = it "selects" $ table1Q `selectShouldReturnSorted` table1data  testProduct :: Test-testProduct = it "joins tables" $ query `queryShouldReturnSorted` (A.liftA2 (,) table1data table2data)-  where query = table1Q &&& table2Q+testProduct = it "joins tables" $+    select `selectShouldReturnSorted` A.liftA2 (,) table1data table2data+  where select = table1Q &&& table2Q  testRestrict :: Test-testRestrict = it "restricts the rows returned" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)-  where query = proc () -> do+testRestrict = it "restricts the rows returned" $+    select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)+  where select = proc () -> do           t <- table1Q -< ()           O.restrict -< fst t .== 1           Arr.returnA -< t  testExists :: Test-testExists = it "restricts the rows returned with EXISTS" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)-  where query = proc () -> do+testExists = it "restricts the rows returned with EXISTS" $+    select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)+  where select = proc () -> do           t <- table1Q -< ()-          () <- O.exists (proc t -> do+          () <- O.restrictExists (proc t -> do                             t' <- table1Q -< ()                             O.restrict -< fst t' .> fst t) -< t           Arr.returnA -< t  testNotExists :: Test-testNotExists = it "restricts the rows returned with NOT EXISTS" $ query `queryShouldReturnSorted` filter ((== 2) . fst)  (L.sort table1data)-  where query = proc () -> do+testNotExists = it "restricts the rows returned with NOT EXISTS" $+    select `selectShouldReturnSorted` filter ((== 2) . fst)  (L.sort table1data)+  where select = proc () -> do           t <- table1Q -< ()-          () <- O.notExists (proc t -> do+          () <- O.restrictNotExists (proc t -> do                                t' <- table1Q -< ()                                O.restrict -< fst t' .> fst t) -< t           Arr.returnA -< t  testIn :: Test-testIn = it "restricts values to a range" $ query `queryShouldReturnSorted` filter (flip elem [100, 200] . snd) (L.sort table1data)-  where query = proc () -> do+testIn = it "restricts values to a range" $+    select `selectShouldReturnSorted` filter (flip elem [100, 200] . snd)+                                             (L.sort table1data)+  where select = proc () -> do           t <- table1Q -< ()-          O.restrict -< O.in_ [O.pgInt4 100, O.pgInt4 200] (snd t)+          O.restrict -< O.in_ [O.sqlInt4 100, O.sqlInt4 200] (snd t)           O.restrict -< O.not (O.in_ [] (fst t)) -- Making sure empty lists work.           Arr.returnA -< t  testNum :: Test-testNum = it "" $ query `queryShouldReturnSorted` (map op table1data)-  where query :: Query (Column O.SqlInt4)-        query = proc () -> do+testNum = it "" $ select `selectShouldReturnSorted` map op table1data+  where select :: Select (Field O.SqlInt4)+        select = proc () -> do           t <- table1Q -< ()           Arr.returnA -< op t         op :: Num a => (a, a) -> a         op (x, y) = abs (x - 5) * signum (x - 4) * (y * y + 1)  testDiv :: Test-testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1data)-  where query :: Query (Column O.SqlFloat8)-        query = proc () -> do-          t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< ()+testDiv = it "" $ select `selectShouldReturnSorted` map (op . toDoubles) table1data+  where select :: Select (Field O.SqlFloat8)+        select = proc () -> do+          t <- Arr.arr (doubleOfInt *** doubleOfInt) <<< table1Q -< ()           Arr.returnA -< op t         op :: Fractional a => (a, a) -> a         -- Choosing 0.5 here as it should be exactly representable in@@ -398,10 +399,12 @@         toDoubles :: (Int, Int) -> (Double, Double)         toDoubles = fromIntegral *** fromIntegral +        doubleOfInt = O.unsafeCast "float8"+ -- TODO: need to implement and test case_ returning tuples testCase :: Test-testCase = it "" $ q `queryShouldReturnSorted` expected-  where q :: Query (Column O.SqlInt4)+testCase = it "" $ q `selectShouldReturnSorted` expected+  where q :: Select (Field O.SqlInt4)         q = table1Q >>> proc (i, j) -> do           Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33         expected :: [Int]@@ -410,15 +413,16 @@ -- This tests case_ with an empty list of cases, to make sure it generates valid -- SQL. testCaseEmpty :: Test-testCaseEmpty = it "" $ q `queryShouldReturnSorted` expected-  where q :: Query (Column O.SqlInt4)+testCaseEmpty = it "" $ q `selectShouldReturnSorted` expected+  where q :: Select (Field O.SqlInt4)         q = table1Q >>> proc _ ->           Arr.returnA -< O.case_ [] 33         expected :: [Int]         expected = [33, 33, 33, 33]  testDistinct :: Test-testDistinct = it "" $ O.distinct table1Q `queryShouldReturnSorted` (L.nub table1data)+testDistinct =+  it "" $ O.distinct table1Q `selectShouldReturnSorted` L.nub table1data   testDistinctOn :: Test@@ -459,8 +463,9 @@         testH q (\r -> L.sort r `shouldBe` L.sort expected) conn     where -        pgTriples :: [(O.Column O.PGInt8, O.Column O.PGInt8, O.Column O.PGText)]-        pgTriples = (\(x,y,z) -> (O.pgInt8 x, O.pgInt8 y, O.pgStrictText z)) <$> triples+        pgTriples :: [(O.Field O.SqlInt8, O.Field O.SqlInt8, O.Field O.SqlText)]+        pgTriples = (\(x,y,z) ->+                      (O.sqlInt8 x, O.sqlInt8 y, O.sqlStrictText z)) <$> triples          triples :: [(Int64, Int64, T.Text)]         triples =@@ -474,46 +479,54 @@             , (4, 100, "b")             ] --- FIXME: the unsafeCoerceColumn is currently needed because the type+-- FIXME: the unsafeCoerceField is currently needed because the type -- changes required for aggregation are not currently dealt with by -- Opaleye.-aggregateCoerceFIXME :: QueryArr (Column O.SqlInt4) (Column O.SqlInt8)+aggregateCoerceFIXME :: SelectArr (Field O.SqlInt4) (Field O.SqlInt8) aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME' -aggregateCoerceFIXME' :: Column a -> Column O.SqlInt8-aggregateCoerceFIXME' = O.unsafeCoerceColumn+aggregateCoerceFIXME' :: Field a -> Field O.SqlInt8+aggregateCoerceFIXME' = O.unsafeCoerceField  testAggregate :: Test testAggregate = it "" $ (Arr.second aggregateCoerceFIXME                         <<< O.aggregate (PP.p2 (O.groupBy, O.sum))-                                           table1Q) `queryShouldReturnSorted` [(1, 400) :: (Int, Int64), (2, 300)]+                                           table1Q)+                      `selectShouldReturnSorted` [ (1, 400) :: (Int, Int64)+                                                 , (2, 300) ]  testAggregate0 :: Test testAggregate0 = it "" $ (Arr.second aggregateCoerceFIXME                         <<< O.aggregate (PP.p2 (O.sum, O.sum))-                                        (O.keepWhen (const (O.pgBool False))-                                         <<< table1Q)) `queryShouldReturnSorted` ([] :: [(Int, Int64)])+                                        (O.keepWhen (const (O.sqlBool False))+                                         <<< table1Q))+                         `selectShouldReturnSorted` ([] :: [(Int, Int64)])  testAggregateFunction :: Test testAggregateFunction = it "" $ (Arr.second aggregateCoerceFIXME                         <<< O.aggregate (PP.p2 (O.groupBy, O.sum))                                         (fmap (\(x, y) -> (x + 1, y)) table1Q))-                      `queryShouldReturnSorted` [(2, 400) :: (Int, Int64), (3, 300)]+                      `selectShouldReturnSorted` [ (2, 400) :: (Int, Int64)+                                                 , (3, 300) ]  testAggregateProfunctor :: Test-testAggregateProfunctor = it "" $ q `queryShouldReturnSorted` [(1, 1200) :: (Int, Int64), (2, 300)]+testAggregateProfunctor = it "" $+    q `selectShouldReturnSorted` [ (1, 1200) :: (Int, Int64), (2, 300)]   where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q         countsum = P.dimap (\x -> (x,x))                            (\(x, y) -> aggregateCoerceFIXME' x * y)                            (PP.p2 (O.sum, O.count))  testStringArrayAggregate :: Test-testStringArrayAggregate = it "" $ q `queryShouldReturnSorted` [(map fst table6data, minimum (map snd table6data))]+testStringArrayAggregate = it "" $+    q `selectShouldReturnSorted` [(map fst table6data,+                                   minimum (map snd table6data))]   where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q  testStringAggregate :: Test-testStringAggregate = it "" $ q `queryShouldReturnSorted` expected-  where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q+testStringAggregate = it "" $ q `selectShouldReturnSorted` expected+  where q = O.aggregate (PP.p2 ((O.stringAgg . O.sqlString) "_", O.groupBy))+                        table6Q         expected = [(           (foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data ,           head (map snd table6data))]@@ -521,8 +534,9 @@ -- | Using aggregateOrdered applies the ordering to all aggregates.  testStringArrayAggregateOrdered :: Test-testStringArrayAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected-  where q = O.aggregateOrdered (O.asc snd) (PP.p2 (O.arrayAgg, O.stringAgg . O.pgString $ ",")) table7Q+testStringArrayAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected+  where q = O.aggregateOrdered (O.asc snd)+                               (PP.p2 (O.arrayAgg, O.stringAgg . O.sqlString $ ",")) table7Q         expected = [( map fst sortedData                       , L.intercalate "," . map snd $ sortedData                       )@@ -533,14 +547,16 @@ -- different aggregates.  testMultipleAggregateOrdered :: Test-testMultipleAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected+testMultipleAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected   where q = O.aggregate ((,) <$> IA.orderAggregate (O.asc snd)                                                    (P.lmap fst O.arrayAgg)                              <*> IA.orderAggregate (O.desc snd)-                                                   (P.lmap snd (O.stringAgg . O.pgString $ ","))+                                                   (P.lmap snd (O.stringAgg . O.sqlString $ ","))                         ) table7Q         expected = [( map fst . L.sortBy (Ord.comparing snd) $ table7data-                      , L.intercalate "," . map snd . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data+                      , L.intercalate ","+                        . map snd+                        . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data                       )                      ] @@ -548,7 +564,7 @@ -- order, just like with ordered queries. -- testOverwriteAggregateOrdered :: Test-testOverwriteAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected+testOverwriteAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected   where q = O.aggregate ( IA.orderAggregate (O.asc snd)                         . IA.orderAggregate (O.desc snd)                         $ PP.p2 (O.arrayAgg, O.max)@@ -559,42 +575,45 @@                      ]  testCountRows0 :: Test-testCountRows0 = it "" $ q `queryShouldReturnSorted` [0 :: Int64]-  where q        = O.countRows (O.keepWhen (const (O.pgBool False)) <<< table7Q)+testCountRows0 = it "" $ q `selectShouldReturnSorted` [0 :: Int64]+  where q        = O.countRows (O.keepWhen (const (O.sqlBool False)) <<< table7Q)  testCountRows3 :: Test-testCountRows3 = it "" $ q `queryShouldReturnSorted` [3 :: Int64]+testCountRows3 = it "" $ q `selectShouldReturnSorted` [3 :: Int64]   where q        = O.countRows table7Q -queryShouldReturnSortBy :: O.Order (Column O.SqlInt4, Column O.SqlInt4)+selectShouldReturnSortBy :: O.Order (Field O.SqlInt4, Field O.SqlInt4)                 -> ((Int, Int) -> (Int, Int) -> Ordering)                 -> (PGS.Connection -> Expectation)-queryShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q)+selectShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q)                                   (L.sortBy order table1data `shouldBe`)  testOrderBy :: Test-testOrderBy = it "" $ queryShouldReturnSortBy (O.desc snd)+testOrderBy = it "" $ selectShouldReturnSortBy (O.desc snd)                            (flip (Ord.comparing snd))  testOrderBy2 :: Test-testOrderBy2 = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc snd)+testOrderBy2 = it "" $ selectShouldReturnSortBy (O.desc fst <> O.asc snd)                             (flip (Ord.comparing fst) <> Ord.comparing snd)  testOrderBySame :: Test-testOrderBySame = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc fst)+testOrderBySame = it "" $ selectShouldReturnSortBy (O.desc fst <> O.asc fst)                                (flip (Ord.comparing fst) <> Ord.comparing fst)  testOrderExact :: Test-testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q) (result `shouldBe`)-  where cols   = map O.constant [300,200::Int]+testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q)+                               (result `shouldBe`)+  where cols   = map O.toFields [300,200::Int]         result = [ (2::Int, 300::Int)                  , (1, 200)                  , (1, 100)                  , (1, 100)                  ] -limitOrderShouldMatch :: (Query (Column O.SqlInt4, Column O.SqlInt4) -> Query (Column O.SqlInt4, Column O.SqlInt4))-           -> ([(Int, Int)] -> [(Int, Int)]) -> (PGS.Connection -> Expectation)+limitOrderShouldMatch :: (Select (Field O.SqlInt4, Field O.SqlInt4)+                          -> Select (Field O.SqlInt4, Field O.SqlInt4))+                      -> ([(Int, Int)] -> [(Int, Int)])+                      -> (PGS.Connection -> Expectation) limitOrderShouldMatch olQ ol = testH (olQ (orderQ table1Q))                        (ol (order table1data) `shouldBe`)   where orderQ = O.orderBy (O.desc snd)@@ -613,21 +632,21 @@ testOffsetLimit = it "" $ limitOrderShouldMatch (O.offset 2 . O.limit 2) (drop 2 . take 2)  testDistinctAndAggregate :: Test-testDistinctAndAggregate = it "" $ q `queryShouldReturnSorted` expectedResult+testDistinctAndAggregate = it "" $ q `selectShouldReturnSorted` expectedResult   where q = O.distinct table1Q             &&& (Arr.second aggregateCoerceFIXME                  <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q)         expectedResult = A.liftA2 (,) (L.nub table1data)                                       [(1 :: Int, 400 :: Int64), (2, 300)] -one :: Query (Column O.SqlInt4)-one = Arr.arr (const (1 :: Column O.SqlInt4))+one :: Select (Field O.SqlInt4)+one = Arr.arr (const (1 :: Field O.SqlInt4))  -- The point of the "double" tests is to ensure that we do not--- introduce name clashes in the operations which create new column names-testDoubleH :: (Show haskells, Eq haskells, D.Default O.QueryRunner columns haskells) =>-               (QueryArr () (Column O.SqlInt4) -> QueryArr () columns) -> [haskells]-               -> (PGS.Connection -> Expectation)+-- introduce name clashes in the operations which create new field names+testDoubleH :: (Show haskells, Eq haskells, D.Default O.FromFields fields haskells)+            => (SelectArr () (Field O.SqlInt4) -> SelectArr () fields) -> [haskells]+            -> (PGS.Connection -> Expectation) testDoubleH q expected1 = testH (q one &&& q one) (`shouldBe` expected2)   where expected2 = A.liftA2 (,) expected1 expected1 @@ -639,21 +658,21 @@  testDoubleLeftJoin :: Test testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))]-  where lj :: Query (Column O.SqlInt4)-          -> Query (Column O.SqlInt4, Column (Nullable O.SqlInt4))+  where lj :: Select (Field O.SqlInt4)+          -> Select (Field O.SqlInt4, Field (Nullable O.SqlInt4))         lj q = O.leftJoin q q (uncurry (.==))  testDoubleValues :: Test testDoubleValues = it "" $ testDoubleH v [1 :: Int]-  where v :: Query (Column O.SqlInt4) -> Query (Column O.SqlInt4)+  where v :: Select (Field O.SqlInt4) -> Select (Field O.SqlInt4)         v _ = O.values [1]  testDoubleUnionAll :: Test testDoubleUnionAll = it "" $ testDoubleH u [1 :: Int, 1]   where u q = q `O.unionAll` q -aLeftJoin :: Query ((Column O.SqlInt4, Column O.SqlInt4),-                    (Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4)))+aLeftJoin :: Select ((Field O.SqlInt4, Field O.SqlInt4),+                    (Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4))) aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r)  testLeftJoin :: Test@@ -666,10 +685,10 @@  testLeftJoinNullable :: Test testLeftJoinNullable = it "" $ testH q (`shouldBe` expected)-  where q :: Query ((Column O.SqlInt4, Column O.SqlInt4),-                    ((Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4)),-                     (Column (Nullable O.SqlInt4),-                      Column (Nullable O.SqlInt4))))+  where q :: Select ((Field O.SqlInt4, Field O.SqlInt4),+                    ((Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4)),+                     (Field (Nullable O.SqlInt4),+                      Field (Nullable O.SqlInt4))))         q = O.leftJoin table3Q aLeftJoin cond          cond (x, y) = fst x .== fst (fst y)@@ -700,7 +719,7 @@  testValues :: Test testValues = it "" $ testH (O.values values) (values' `shouldBe`)-  where values :: [(Column O.SqlInt4, Column O.SqlInt4)]+  where values :: [(Field O.SqlInt4, Field O.SqlInt4)]         values = [ (1, 10)                  , (2, 100) ]         values' :: [(Int, Int)]@@ -710,7 +729,7 @@ {- FIXME: does not yet work testValuesDouble :: Test testValuesDouble = testG (O.values values) (values' ==)-  where values :: [(Column O.SqlInt4, Column O.SqlFloat8)]+  where values :: [(Field O.SqlInt4, Field O.SqlFloat8)]         values = [ (1, 10.0)                  , (2, 100.0) ]         values' :: [(Int, Double)]@@ -720,32 +739,44 @@  testValuesEmpty :: Test testValuesEmpty = it "" $ testH (O.values values) (values' `shouldBe`)-  where values :: [Column O.SqlInt4]+  where values :: [Field O.SqlInt4]         values = []         values' :: [Int]         values' = []  testUnionAll :: Test-testUnionAll = it "" $  (table1Q `O.unionAll` table2Q) `queryShouldReturnSorted` (table1data ++ table2data)+testUnionAll = it "" $ (table1Q `O.unionAll` table2Q)+                       `selectShouldReturnSorted` (table1data ++ table2data)  testTableFunctor :: Test-testTableFunctor = it "" $ testH (O.queryTable table1F) (result `shouldBe`)+testTableFunctor = it "" $ testH (O.selectTable table1F) (result `shouldBe`)   where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data  -- TODO: This is getting too complicated testUpdate :: Test testUpdate = it "" $ \conn -> do-  _ <- O.runUpdate conn table4 update cond-  result <- runQueryTable4 conn+  _ <- O.runUpdate_ conn O.Update { O.uTable = table4+                                  , O.uUpdateWith = update+                                  , O.uWhere = cond+                                  , O.uReturning = O.rCount }+  result <- runSelectTable4 conn   result `shouldBe` expected -  _ <- O.runDelete conn table4 condD-  resultD <- runQueryTable4 conn+  _ <- O.runDelete_ conn O.Delete { O.dTable = table4+                                  , O.dWhere = condD+                                  , O.dReturning = O.rCount }+  resultD <- runSelectTable4 conn   resultD `shouldBe` expectedD -  returned <- O.runInsertManyReturning conn table4 insertT returning-  _ <- O.runInsertMany conn table4 insertTMany-  resultI <- runQueryTable4 conn+  returned <- O.runInsert_ conn O.Insert { O.iTable = table4+                                         , O.iRows = insertT+                                         , O.iReturning = O.rReturning returning+                                         , O.iOnConflict = Nothing }+  _ <- O.runInsert_ conn O.Insert { O.iTable = table4+                                  , O.iRows = insertTMany+                                  , O.iReturning = O.rCount+                                  , O.iOnConflict = Nothing }+  resultI <- runSelectTable4 conn    resultI `shouldBe` expectedI   returned `shouldBe` expectedR@@ -758,12 +789,12 @@                    , (22, -18)]         expectedD :: [(Int, Int)]         expectedD = [(1, 10)]-        runQueryTable4 conn = O.runQuery conn (O.queryTable table4)+        runSelectTable4 conn = O.runSelect conn (O.selectTable table4) -        insertT :: [(Column O.SqlInt4, Column O.SqlInt4)]+        insertT :: [(Field O.SqlInt4, Field O.SqlInt4)]         insertT = [(1, 2), (3, 5)] -        insertTMany :: [(Column O.SqlInt4, Column O.SqlInt4)]+        insertTMany :: [(Field O.SqlInt4, Field O.SqlInt4)]         insertTMany = [(20, 30), (40, 50)]          expectedI :: [(Int, Int)]@@ -775,7 +806,11 @@ testDeleteReturning :: Test testDeleteReturning = it "" $ \conn -> do   result <- O.runDelete_ conn delete-  _ <- O.runInsertMany conn table4 ([(40,50)] :: [(Column O.SqlInt4, Column O.SqlInt4)]) :: IO Int64+  _ <- O.runInsert_ conn O.Insert { O.iTable = table4+                                  , O.iRows = [(40,50)]+                                    :: [(Field O.SqlInt4, Field O.SqlInt4)]+                                  , O.iReturning = O.rCount+                                  , O.iOnConflict = Nothing } :: IO Int64   result `shouldBe` expected   where delete = Delete table cond returning         table = table4@@ -785,25 +820,40 @@  testInsertConflict :: Test testInsertConflict = it "inserts with conflicts" $ \conn -> do-  _ <- O.runDelete conn table10 (const $ O.constant True)-  returned <- O.runInsertManyReturning conn table10 insertT id-  extras <- O.runInsertManyReturningOnConflictDoNothing conn table10 conflictsT id-  moreExtras <- O.runInsertManyOnConflictDoNothing conn table10 moreConflictsT+  _ <- O.runDelete_ conn O.Delete { O.dTable = table10+                                  , O.dWhere = const $ O.toFields True+                                  , O.dReturning = O.rCount }+  returned <- O.runInsert_ conn O.Insert { O.iTable = table10+                                         , O.iRows = insertT+                                         , O.iReturning = O.rReturning id+                                         , O.iOnConflict = Nothing }+  extras <- O.runInsert_ conn O.Insert { O.iTable = table10+                                       , O.iRows = conflictsT+                                       , O.iReturning = O.rReturning id+                                       , O.iOnConflict = Just O.DoNothing }+  moreExtras <- O.runInsert_ conn O.Insert { O.iTable = table10+                                           , O.iRows = moreConflictsT+                                           , O.iReturning = O.rCount+                                           , O.iOnConflict = Just O.DoNothing }    returned `shouldBe` afterInsert   extras `shouldBe` afterConflicts   moreExtras `shouldBe` 1-  runQueryTable10 conn `shouldReturn` allRows+  runSelectTable10 conn `shouldReturn` allRows -  O.runInsertMany conn table10 insertT `shouldThrow` (\ (_ :: PGS.SqlError) -> True)+  O.runInsert_ conn O.Insert { O.iTable = table10+                             , O.iRows = insertT+                             , O.iReturning = O.rCount+                             , O.iOnConflict = Nothing }+    `shouldThrow` (\ (_ :: PGS.SqlError) -> True) -  where insertT :: [Column O.SqlInt4]+  where insertT :: [Field O.SqlInt4]         insertT = [1, 2] -        conflictsT :: [Column O.SqlInt4]+        conflictsT :: [Field O.SqlInt4]         conflictsT = [1, 3] -        moreConflictsT :: [Column O.SqlInt4]+        moreConflictsT :: [Field O.SqlInt4]         moreConflictsT = [3, 4]          afterInsert :: [Int]@@ -815,12 +865,12 @@         allRows :: [Int]         allRows = [1, 2, 3, 4] -        runQueryTable10 conn = O.runQuery conn (O.queryTable table10)+        runSelectTable10 conn = O.runSelect conn (O.selectTable table10)  testKeywordColNames :: Test testKeywordColNames = it "" $ \conn -> do   let q :: IO [(Int, Int)]-      q = O.runQuery conn (O.queryTable tableKeywordColNames)+      q = O.runSelect conn (O.selectTable tableKeywordColNames)   _ <- q   True `shouldBe` True @@ -831,7 +881,7 @@   _ <- runInsert conn table5 (Nothing, Nothing)   _ <- runInsert conn table5 (Nothing, Just 40) -  resultI <- O.runQuery conn (O.queryTable table5)+  resultI <- O.runSelect conn (O.selectTable table5)    resultI `shouldBe` expected @@ -840,11 +890,15 @@                    , (30, 1)                    , (1, 2)                    , (2, 40) ]-        runInsert conn table row = O.runInsertMany conn table [row]+        runInsert conn table row =+          O.runInsert_ conn O.Insert { O.iTable = table+                                     , O.iRows = [row]+                                     , O.iReturning = O.rCount+                                     , O.iOnConflict = Nothing } -testInQuery :: Test-testInQuery = it "" $ \conn -> do-  let q (x, e) = testH (O.inQuery x (O.queryTable table1)) (`shouldBe` [e]) conn+testInSelect :: Test+testInSelect = it "" $ \conn -> do+  let q (x, e) = testH (O.inSelect x (O.selectTable table1)) (`shouldBe` [e]) conn    mapM_ (q . (\x ->      (x,        True)))  table1dataG   mapM_ (q . (\(x, y) -> ((x, y+1), False))) table1dataG@@ -852,112 +906,123 @@   -- and r && and s `shouldBe` True  testAtTimeZone :: Test-testAtTimeZone = it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (`shouldBe` [t'])-  where t = O.pgUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))+testAtTimeZone =+  it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.sqlString "CET")))+                (`shouldBe` [t'])+  where t = O.sqlUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))         t' = Time.LocalTime d (Time.TimeOfDay 2 0 0)         d = Time.fromGregorian 2015 1 1  testArrayLiterals :: Test-testArrayLiterals = it "" $ testH (A.pure $ O.pgArray O.pgInt4 vals) (`shouldBe` [vals])+testArrayLiterals = it "" $ testH (A.pure $ O.sqlArray O.sqlInt4 vals)+                                  (`shouldBe` [vals])   where vals = [1,2,3]  -- This test fails without the explicit cast in pgArray since postgres -- can't determine the type of the array.  testEmptyArray :: Test-testEmptyArray = it "" $ testH (A.pure $ O.pgArray O.pgInt4 []) (`shouldBe` [[] :: [Int]])+testEmptyArray = it "" $ testH (A.pure $ O.sqlArray O.sqlInt4 [])+                               (`shouldBe` [[] :: [Int]])  -- This test fails without the explicit cast in pgArray since postgres -- defaults the numbers to 'integer' but postgresql-simple expects 'float8'.  testFloatArray :: Test-testFloatArray = it "" $ testH (A.pure $ O.pgArray O.pgDouble doubles) (`shouldBe` [doubles])+testFloatArray = it "" $ testH (A.pure $ O.sqlArray O.sqlDouble doubles)+                               (`shouldBe` [doubles])   where     doubles = [1 :: Double, 2]  testArrayIndex :: Test testArrayIndex = it "correctly indexes an array" $-  testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 3)+  testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7] `O.index` O.sqlInt4 3)         (`shouldBe` ([Just 7] :: [Maybe Int]))  testArrayIndexOOB :: Test testArrayIndexOOB = it "returns Nothing when the index is out of bounds" $-  testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 8)+  testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7] `O.index` O.sqlInt4 8)         (`shouldBe` ([Nothing] :: [Maybe Int]))  testSingletonArray :: Test testSingletonArray = it "constructs a singleton PGInt8 array" $-  testH (A.pure $ O.singletonArray (O.pgInt8 1))+  testH (A.pure $ O.singletonArray (O.sqlInt8 1))         (`shouldBe` ([[1]] :: [[Int64]]))  testArrayAppend :: Test testArrayAppend = it "appends two arrays" $-  testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.arrayAppend` O.pgArray O.pgInt4 [1,2,3])+  testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7]+                  `O.arrayAppend` O.sqlArray O.sqlInt4 [1,2,3])         (`shouldBe` ([[5,6,7,1,2,3]] :: [[Int]])) -type JsonTest a = SpecWith (Query (Column a) -> PGS.Connection -> Expectation)+type JsonTest a = SpecWith (Select (Field a) -> PGS.Connection -> Expectation) -- Test opaleye's equivalent of c1->'c'-testJsonGetFieldValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test-testJsonGetFieldValue dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-            Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c"+testJsonGetFieldValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)+                      => Select (Field a) -> Test+testJsonGetFieldValue dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+            Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "c"         expected :: [Maybe Json.Value]-        expected = [Just $ Json.Number $ fromInteger 21]+        expected = [Just $ Json.Number 21]  -- Test opaleye's equivalent of c1->>'c'-testJsonGetFieldText :: (O.SqlIsJson a) => Query (Column a) -> Test-testJsonGetFieldText dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-            Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c"+testJsonGetFieldText :: (O.SqlIsJson a) => Select (Field a) -> Test+testJsonGetFieldText dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+            Arr.returnA -< O.toNullable c1 O..->> O.sqlStrictText "c"         expected :: [Maybe T.Text]         expected = [Just "21"] --- Special Test for Github Issue #350 : https://github.com/tomjaguarpaw/haskell-opaleye/issues/350-testRestrictWithJsonOp :: (O.SqlIsJson a) => Query (Column a) -> Test-testRestrictWithJsonOp dataQuery = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH query (`shouldBe` table8data)-  where query = dataQuery >>> proc col1 -> do+-- Special Test for Github Issue #350 :+-- https://github.com/tomjaguarpaw/haskell-opaleye/issues/350+testRestrictWithJsonOp :: (O.SqlIsJson a) => Select (Field a) -> Test+testRestrictWithJsonOp dataSelect = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH select (`shouldBe` table8data)+  where select = dataSelect >>> proc col1 -> do           t <- table8Q -< ()-          O.restrict -< (O.toNullable col1 O..->> O.pgStrictText "c") .== O.toNullable (O.pgStrictText "21")+          O.restrict -< (O.toNullable col1 O..->> O.sqlStrictText "c")+                         .== O.toNullable (O.sqlStrictText "21")           Arr.returnA -< t  -- Test opaleye's equivalent of c1->'a'->2-testJsonGetArrayValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test-testJsonGetArrayValue dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-            Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..-> O.pgInt4 2+testJsonGetArrayValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)+                      => Select (Field a) -> Test+testJsonGetArrayValue dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+            Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "a" O..-> O.sqlInt4 2         expected :: [Maybe Json.Value]-        expected = [Just $ Json.Number $ fromInteger 30]+        expected = [Just $ Json.Number 30]  -- Test opaleye's equivalent of c1->'a'->>2-testJsonGetArrayText :: (O.SqlIsJson a) => Query (Column a) -> Test-testJsonGetArrayText dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-            Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..->> O.pgInt4 2+testJsonGetArrayText :: (O.SqlIsJson a) => Select (Field a) -> Test+testJsonGetArrayText dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+            Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "a" O..->> O.sqlInt4 2         expected :: [Maybe T.Text]         expected = [Just "30"]  -- Test opaleye's equivalent of c1->>'missing' -- Note that the missing field does not exist.-testJsonGetMissingField :: (O.SqlIsJson a) => Query (Column a) -> Test-testJsonGetMissingField dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-            Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing"+testJsonGetMissingField :: (O.SqlIsJson a) => Select (Field a) -> Test+testJsonGetMissingField dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+            Arr.returnA -< O.toNullable c1 O..->> O.sqlStrictText "missing"         expected :: [Maybe T.Text]         expected = [Nothing]  -- Test opaleye's equivalent of c1#>'{b,x}'-testJsonGetPathValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test-testJsonGetPathValue dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-              Arr.returnA -< O.toNullable c1 O..#> O.pgArray O.pgStrictText ["b", "x"]+testJsonGetPathValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)+                     => Select (Field a) -> Test+testJsonGetPathValue dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+              Arr.returnA -< O.toNullable c1 O..#> O.sqlArray O.sqlStrictText ["b", "x"]         expected :: [Maybe Json.Value]-        expected = [Just $ Json.Number $ fromInteger 42]+        expected = [Just $ Json.Number 42]  -- Test opaleye's equivalent of c1#>>'{b,x}'-testJsonGetPathText :: (O.SqlIsJson a) => Query (Column a) -> Test-testJsonGetPathText dataQuery = it "" $ testH q (`shouldBe` expected)-  where q = dataQuery >>> proc c1 -> do-              Arr.returnA -< O.toNullable c1 O..#>> O.pgArray O.pgStrictText ["b", "x"]+testJsonGetPathText :: (O.SqlIsJson a) => Select (Field a) -> Test+testJsonGetPathText dataSelect = it "" $ testH q (`shouldBe` expected)+  where q = dataSelect >>> proc c1 -> do+              Arr.returnA -< O.toNullable c1 O..#>> O.sqlArray O.sqlStrictText ["b", "x"]         expected :: [Maybe T.Text]         expected = [Just "42"] @@ -965,96 +1030,99 @@ testJsonbRightInLeft :: Test testJsonbRightInLeft = it "" $ testH q (`shouldBe` [True])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< c1 O..@> O.pgJSONB "{\"c\":21}"+              Arr.returnA -< c1 O..@> O.sqlJSONB "{\"c\":21}"  -- Test opaleye's equivalent of '{"c":21}'::jsonb <@ c1 testJsonbLeftInRight :: Test testJsonbLeftInRight = it "" $ testH q (`shouldBe` [True])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< O.pgJSONB "{\"c\":21}" O..<@ c1+              Arr.returnA -< O.sqlJSONB "{\"c\":21}" O..<@ c1  -- Test opaleye's equivalent of c1 ? 'b' testJsonbContains :: Test testJsonbContains = it "" $ testH q (`shouldBe` [True])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< c1 O..? O.pgStrictText "c"+              Arr.returnA -< c1 O..? O.sqlStrictText "c"  -- Test opaleye's equivalent of c1 ? 'missing' -- Note that the missing field does not exist. testJsonbContainsMissing :: Test testJsonbContainsMissing = it "" $ testH q (`shouldBe` [False])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< c1 O..? O.pgStrictText "missing"+              Arr.returnA -< c1 O..? O.sqlStrictText "missing"  -- Test opaleye's equivalent of c1 ?| array['b', 'missing'] testJsonbContainsAny :: Test testJsonbContainsAny = it "" $ testH q (`shouldBe` [True])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< c1 O..?| O.pgArray O.pgStrictText ["b", "missing"]+              Arr.returnA -< c1 O..?| O.sqlArray O.sqlStrictText ["b", "missing"]  -- Test opaleye's equivalent of c1 ?& array['a', 'b', 'c'] testJsonbContainsAll :: Test testJsonbContainsAll = it "" $ testH q (`shouldBe` [True])   where q = table9Q >>> proc c1 -> do-              Arr.returnA -< c1 O..?& O.pgArray O.pgStrictText ["a", "b", "c"]+              Arr.returnA -< c1 O..?& O.sqlArray O.sqlStrictText ["a", "b", "c"]  testRangeOverlap :: Test testRangeOverlap = it "generates overlap" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)-        q = A.pure $ (range 3 7) `O.overlap` (range 4 12)+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)+        q = A.pure (range 3 7 `O.overlap` range 4 12)  testRangeDateOverlap :: Test testRangeDateOverlap = it "generates time overlap" $ \conn -> do     let date       = Time.fromGregorian 2015 1 1         now        = Time.UTCTime date (Time.secondsToDiffTime 3600)         later      = Time.addUTCTime 10 now-        range1     = O.pgRange O.pgUTCTime (R.Inclusive now) (R.Exclusive later)-        range2     = O.pgRange O.pgUTCTime R.NegInfinity R.PosInfinity-        rangeNow   = O.pgRange O.pgUTCTime (R.Inclusive now) (R.Inclusive now)+        range1     = O.sqlRange O.sqlUTCTime (R.Inclusive now) (R.Exclusive later)+        range2     = O.sqlRange O.sqlUTCTime R.NegInfinity R.PosInfinity+        rangeNow   = O.sqlRange O.sqlUTCTime (R.Inclusive now) (R.Inclusive now)         qOverlap r = A.pure $ r `O.overlap` rangeNow     testH (qOverlap range1) (`shouldBe` [True]) conn     testH (qOverlap range2) (`shouldBe` [True]) conn-    testH (A.pure $ O.pgUTCTime now   `O.liesWithin` range1) (`shouldBe` [True]) conn-    testH (A.pure $ O.pgUTCTime later `O.liesWithin` range1) (`shouldBe` [False]) conn+    testH (A.pure $ O.sqlUTCTime now   `O.liesWithin` range1) (`shouldBe` [True]) conn+    testH (A.pure $ O.sqlUTCTime later `O.liesWithin` range1) (`shouldBe` [False]) conn  testRangeLeftOf :: Test testRangeLeftOf = it "generates 'left of'" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)-        q = A.pure $ (range 1 10) O..<< (range 100 110)+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)+        q = A.pure (range 1 10 O..<< range 100 110)  testRangeRightOf :: Test testRangeRightOf = it "generates 'right of'" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)-        q = A.pure $ (range 50 60) O..>> (range 20 30)+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)+        q = A.pure (range 50 60 O..>> range 20 30)  testRangeRightExtension :: Test-testRangeRightExtension = it "generates right extension" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)-        q = A.pure $ (range 1 20) O..&< (range 18 20)+testRangeRightExtension = it "generates right extension" $+    testH q (`shouldBe` [True])+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)+        q = A.pure (range 1 20 O..&< range 18 20)  testRangeLeftExtension :: Test-testRangeLeftExtension = it "generates left extension" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)-        q = A.pure $ (range 7 20) O..&> (range 5 10)+testRangeLeftExtension = it "generates left extension" $+    testH q (`shouldBe` [True])+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)+        q = A.pure (range 7 20 O..&> range 5 10)  testRangeAdjacency :: Test testRangeAdjacency = it "generates adjacency" $ testH q (`shouldBe` [True])-  where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)-        range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b)-        q = A.pure $ (range 1 2) O..-|- (range 2 3)+  where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)+        range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Exclusive b)+        q = A.pure (range 1 2 O..-|- range 2 3)  testRangeBoundsEnum :: forall a b.     ( Show a, Eq a, Enum a, O.IsRangeType b-    , O.QueryRunnerColumnDefault (Nullable b) (Maybe a))-        => String -> (a -> Column b) -> a -> a -> Test+    , DefaultFromField b a )+        => String -> (a -> Field b) -> a -> a -> Test testRangeBoundsEnum msg mkCol x y = it msg $ \conn -> do-    -- bound functions for discrete range types return fields as from the form [x,y)-    let pgr = O.pgRange mkCol+    -- bound functions for discrete range types return fields as from+    -- the form [x,y)+    let pgr = O.sqlRange mkCol         ranges_expecteds =           [ (pgr (R.Inclusive x) R.PosInfinity,   (Just x, Nothing))           , (pgr R.NegInfinity   (R.Inclusive y), (Nothing, Just $ succ y))@@ -1063,11 +1131,11 @@         ranges    = map fst ranges_expecteds         expecteds = map ((:[]) . snd) ranges_expecteds -    r <- mapM (O.runQuery conn . pure . (O.lowerBound &&& O.upperBound)) ranges+    r <- mapM (O.runSelect conn . pure . (O.lowerBound &&& O.upperBound)) ranges     r `shouldBe` expecteds -jsonTests :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value)-          => Query (Column a) -> Test+jsonTests :: (O.SqlIsJson a, DefaultFromField a Json.Value)+          => Select (Field a) -> Test jsonTests t = do   testJsonGetFieldValue   t   testJsonGetFieldText    t@@ -1099,6 +1167,21 @@     testH (pure (O.sqlZonedTime value))           (\r -> map Time.zonedTimeToUTC r `shouldBe` [Time.zonedTimeToUTC value]) +-- Check that MaybeFields's "Nothings" are not distinct, even if we+-- fmap different values over their inner fields.+testMaybeFieldsDistinct :: Test+testMaybeFieldsDistinct = do+  it "MaybeFields distinct" $ testH query (`shouldBe` [Nothing :: Maybe Int])+  it "MaybeFields equality" $ testH query2 (`shouldBe` [True])+  where nothing_ = OM.nothingFields :: MaybeFields ()+        query :: Select (MaybeFields (Field O.SqlInt4))+        query = O.distinct (O.valuesSafe [ fmap (const 0) nothing_+                                         , fmap (const 1) nothing_ ])+        query2 :: Select (Field O.SqlBool)+        query2 = pure ((fmap (const (0 :: Field O.SqlInt4)) nothing_)+                       O..=== fmap (const (1 :: Field O.SqlInt4)) nothing_)++ main :: IO () main = do   let envVarName = "POSTGRES_CONNSTRING"@@ -1110,33 +1193,45 @@                          `Dotenv.onMissingFile`                          return Nothing -  let connectString = connectStringEnvVar <|> connectStringDotEnv+  let mconnectString = connectStringEnvVar <|> connectStringDotEnv -  conn <- maybe+  connectString <- maybe     (fail ("Set " ++ envVarName ++ " environment variable\n"            ++ "For example " ++ envVarName ++ "='user=tom dbname=opaleye_test "            ++ "host=localhost port=25433 password=tom'"))-    (PGS.connectPostgreSQL . String.fromString)-    connectString+    (pure . String.fromString)+    mconnectString +  conn <- PGS.connectPostgreSQL connectString+   dropAndCreateDB conn -  let insert (t, d) = do { _ <- O.runInsertMany conn t d; return () }+  let insert (t, d) = do {+     _ <- O.runInsert_ conn O.Insert { O.iTable = t+                                     , O.iRows = d+                                     , O.iReturning = O.rCount+                                     , O.iOnConflict = Nothing }+   ; return () } -  mapM_ insert [ (table1, table1columndata)-               , (table2, table2columndata)-               , (table3, table3columndata)-               , (table4, table4columndata) ]-  insert (table6, table6columndata)-  insert (table7, table7columndata)-  insert (table8, table8columndata)-  insert (table9, table9columndata)+  mapM_ insert [ (table1, table1fielddata)+               , (table2, table2fielddata)+               , (table3, table3fielddata)+               , (table4, table4fielddata) ]+  insert (table6, table6fielddata)+  insert (table7, table7fielddata)+  insert (table8, table8fielddata)+  insert (table9, table9fielddata) +  PGS.close conn++  conn2 <- Connection.connectPostgreSQL connectString   -- Need to run quickcheck after table data has been inserted-  QuickCheck.run conn+  QuickCheck.run conn2+  Connection.close conn2 +  conn3 <- PGS.connectPostgreSQL connectString   hspec $ do-    before (return conn) $ do+    before (return conn3) $ do       describe "core dsl?" $ do         testSelect         testProduct@@ -1208,7 +1303,7 @@       describe "uncat" $ do         testKeywordColNames         testInsertSerial-        testInQuery+        testInSelect         testAtTimeZone         testUnionAll         testTableFunctor@@ -1226,8 +1321,10 @@         testRangeLeftExtension         testRangeAdjacency         testRangeBoundsEnum "can access bounds from an Int8 range"-            O.pgInt8 10 26+            O.sqlInt8 10 26         testRangeBoundsEnum "can access bounds from a date range"-            O.pgDay (read "2018-01-01") (read "2018-01-12")+            O.sqlDay (read "2018-01-01") (read "2018-01-12")       describe "literals" $ do         testLiterals+      describe "MaybeFields" $ do+        testMaybeFieldsDistinct

@@ -18,4 +18,4 @@                       :~ (((->) :<$> Pure a :<*> Pure b) :<| c)         _ = Eq :: Maybe a :~ ((Maybe :<$> Pure a) :<| b)         _ = Eq :: Maybe a :~ ((Maybe :<$> Id) :<| a)-        _ = Eq :: a :~ ((Pure a) :<| b)+        _ = Eq :: a :~ (Pure a :<| b)

@@ -0,0 +1,87 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}++module Wrapped where++import           Control.Arrow (arr, (<<<))+import qualified Control.Arrow as Arrow+import qualified Control.Category+import           Control.Category (Category)+import qualified Data.Functor.Contravariant as C+import qualified Data.Functor.Contravariant.Divisible as D+import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP++data WrappedSumProfunctor p a b where+  WrappedSumProfunctor        :: p a b -> WrappedSumProfunctor p a b+  WrappedSumProfunctorId      :: WrappedSumProfunctor p a a+  WrappedSumProfunctorArr     :: (a -> b) -> WrappedSumProfunctor p a b+  WrappedSumProfunctorCompose :: WrappedSumProfunctor p b c+                              -> WrappedSumProfunctor p a b+                              -> WrappedSumProfunctor p a c+  WrappedSumProfunctorChoice  ::+       WrappedSumProfunctor p a a'+    -> WrappedSumProfunctor p b b'+    -> WrappedSumProfunctor p (Either a b) (Either a' b')++newtype WrappedDecidable f a b =+  WrappedDecidable { unWrappedDecidable :: f a }++instance C.Contravariant f => P.Profunctor (WrappedDecidable f) where+  dimap f _ = WrappedDecidable . C.contramap f . unWrappedDecidable++instance D.Decidable f => PP.SumProfunctor (WrappedDecidable f) where+  f1 +++! f2 =+    WrappedDecidable (D.choose id (unWrappedDecidable f1)+                                  (unWrappedDecidable f2))++constructor :: P.Profunctor p+            => (b -> c) -> p a b -> WrappedSumProfunctor p a c+constructor c p = P.rmap c (WrappedSumProfunctor p)++constructorDecidable :: D.Decidable f+                     => f a+                     -> WrappedSumProfunctor (WrappedDecidable f) a c+constructorDecidable f = WrappedSumProfunctor (WrappedDecidable f)++asSumProfunctor :: PP.SumProfunctor p+                => WrappedSumProfunctor p a b -> p a b+asSumProfunctor w = case unWrappedSumProfunctorE w of+  Left p  -> p+  Right _ -> error "unWrappedSumProfunctor was function"++asDecidable :: D.Decidable f+            => WrappedSumProfunctor (WrappedDecidable f) a b -> f a+asDecidable = unWrappedDecidable . asSumProfunctor++unWrappedSumProfunctorE :: PP.SumProfunctor p+                        => WrappedSumProfunctor p a b -> Either (p a b) (a -> b)+unWrappedSumProfunctorE = \case+  WrappedSumProfunctor p    -> Left p+  WrappedSumProfunctorId    -> Right id+  WrappedSumProfunctorArr f -> Right f+  WrappedSumProfunctorCompose w1 w2 ->+    case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of+      (Left _, Left _)     -> error "Composing two profunctors"+      (Right f, Left p)    -> Left (P.rmap f p)+      (Left p, Right f)    -> Left (P.lmap f p)+      (Right f1, Right f2) -> Right (f1 . f2)++  WrappedSumProfunctorChoice w1 w2 ->+    case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of+      (Left p1, Left p2) -> Left (p1 PP.+++! p2)+      _ -> error "WrappedSumProfunctorChoice"++instance Category (WrappedSumProfunctor p) where+  id  = WrappedSumProfunctorId+  (.) = WrappedSumProfunctorCompose++instance Arrow.Arrow (WrappedSumProfunctor p) where+  arr   = WrappedSumProfunctorArr+  first = error "WrappedSumProfunctor first"++instance PP.SumProfunctor p => Arrow.ArrowChoice (WrappedSumProfunctor p) where+  (+++) = WrappedSumProfunctorChoice++instance P.Profunctor p => P.Profunctor (WrappedSumProfunctor p) where+  dimap f g w = arr g <<< w <<< arr f

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis-version:         0.6.7004.2+version:         0.6.7005.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@@ -28,7 +28,7 @@   default-language: Haskell2010   hs-source-dirs: src   build-depends:-      aeson               >= 0.6     && < 1.5+      aeson               >= 0.6     && < 1.6     , base                >= 4.9     && < 5     , base16-bytestring   >= 0.1.1.6 && < 0.2     , case-insensitive    >= 1.2     && < 1.3@@ -36,7 +36,7 @@     , contravariant       >= 1.2     && < 1.6     , postgresql-simple   >= 0.5.3   && < 0.7     , pretty              >= 1.1.1.0 && < 1.2-    , product-profunctors >= 0.6.2   && < 0.11+    , product-profunctors >= 0.8.0.0 && < 0.11     , profunctors         >= 4.0     && < 5.6     , scientific          >= 0.3     && < 0.4     , semigroups          >= 0.13    && < 0.20@@ -47,6 +47,7 @@     , uuid                >= 1.3     && < 1.4     , void                >= 0.4     && < 0.8   exposed-modules: Opaleye,+                   Opaleye.Adaptors,                    Opaleye.Aggregate,                    Opaleye.Binary,                    Opaleye.Column,@@ -56,8 +57,10 @@                    Opaleye.FunctionalJoin,                    Opaleye.Join,                    Opaleye.Label,+                   Opaleye.Lateral,                    Opaleye.Manipulation,                    Opaleye.Map,+                   Opaleye.MaybeFields,                    Opaleye.Operators,                    Opaleye.Order,                    Opaleye.PGTypes,@@ -78,7 +81,9 @@                    Opaleye.Internal.Helpers,                    Opaleye.Internal.Join,                    Opaleye.Internal.Label,+                   Opaleye.Internal.Lateral,                    Opaleye.Internal.Manipulation,+                   Opaleye.Internal.MaybeFields,                    Opaleye.Internal.Order,                    Opaleye.Internal.Operators,                    Opaleye.Internal.Optimize,@@ -106,12 +111,17 @@   default-language: Haskell2010   type: exitcode-stdio-1.0   main-is: Test.hs-  other-modules: QuickCheck,-                 TypeFamilies+  other-modules: Connection,+                 Opaleye.Test.Arbitrary,+                 Opaleye.Test.Fields,+                 QuickCheck,+                 TypeFamilies,+                 Wrapped   hs-source-dirs: Test   build-depends:-    aeson >= 0.6 && < 1.5,+    aeson >= 0.6 && < 1.6,     base >= 4 && < 5,+    bytestring,     containers,     contravariant,     dotenv >= 0.3.1,

@@ -13,7 +13,8 @@ -- * If you are confused about the @Default@ typeclass, then -- the <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/DefaultExplanation.lhs Default explanation> -module Opaleye ( module Opaleye.Aggregate+module Opaleye ( module Opaleye.Adaptors+               , module Opaleye.Aggregate                , module Opaleye.Binary                , module Opaleye.Column                , module Opaleye.Constant@@ -22,7 +23,9 @@                , module Opaleye.FunctionalJoin                , module Opaleye.Join                , module Opaleye.Label+               , module Opaleye.Lateral                , module Opaleye.Manipulation+               , module Opaleye.MaybeFields                , module Opaleye.Operators                , module Opaleye.Order                , module Opaleye.PGTypes@@ -33,9 +36,11 @@                , module Opaleye.Select                , module Opaleye.SqlTypes                , module Opaleye.Table+               , module Opaleye.ToFields                , module Opaleye.Values                ) where +import Opaleye.Adaptors import Opaleye.Aggregate import Opaleye.Binary import Opaleye.Column@@ -50,8 +55,12 @@           maybeToNullable) import Opaleye.FunctionalJoin import Opaleye.Join+  hiding (optional) import Opaleye.Label+import Opaleye.Lateral import Opaleye.Manipulation+import Opaleye.MaybeFields+  hiding (optional) import Opaleye.Operators import Opaleye.Order import Opaleye.PGTypes@@ -66,4 +75,5 @@ import Opaleye.Sql import Opaleye.SqlTypes import Opaleye.Table+import Opaleye.ToFields import Opaleye.Values

@@ -0,0 +1,84 @@+-- We have the following groups. Groups could be merged into one.+--+-- - p (Column a) (Column a)+--   Not SumProfunctor+--   Not SqlType a+--   - Binaryspec+--   - IfPP+--+-- - p (Column a) (Column a)+--   Not SumProfunctor+--   Is SqlType a+--   - Valuesspec+--+-- - p (Column a) (Column a)+--   Is SumProfunctor+--   Not SqlType a+--   - Distinctspec+--   - Unpackspec+--+-- - p (Column a) b+--   - EqPP+--+-- - p a (Column b)+--   Is SqlType b+--   - Nullspec++module Opaleye.Adaptors+  (+    -- * Binaryspec+    Binaryspec,+    binaryspecField,+    binaryspecMaybeFields,+    -- * Distinctspec+    Distinctspec,+    distinctspecField,+    distinctspecMaybeFields,+    -- * EqPP+    EqPP,+    eqPPField,+    eqPPMaybeFields,+    -- * IfPP+    IfPP,+    ifPPField,+    ifPPMaybeFields,+    -- * FromFields+    FromFields,+    fromFieldsMaybeFields,+    -- * Nullspec+    Nullspec,+    nullspecField,+    nullspecMaybeFields,+    nullspecList,+    nullspecEitherLeft,+    nullspecEitherRight,+    -- * ToFields+    ToFields,+    toFieldsMaybeFields,+    -- * Unpackspec+    Unpackspec,+    unpackspecField,+    unpackspecMaybeFields,+    -- * Updater+    Updater,+    -- * Valuesspec+    ValuesspecSafe,+    valuesspecField,+    valuesspecMaybeFields,+    -- * WithNulls+    WithNulls,+  )+where++import Opaleye.Internal.Unpackspec+import Opaleye.Internal.Binary+import Opaleye.Internal.Manipulation+import Opaleye.Internal.Operators+import Opaleye.Internal.MaybeFields++import Opaleye.Binary+import Opaleye.Distinct+import Opaleye.ToFields+import Opaleye.MaybeFields+import Opaleye.RunSelect+import Opaleye.Values

@@ -53,15 +53,18 @@  {-| Given a 'S.Select' producing rows of type @a@ and an 'Aggregator' accepting rows of-type @a@, apply the aggregator to the query.+type @a@, apply the aggregator to the select.  If you simply want to count the number of rows in a query you might find the 'countRows' function more convenient. -By design there is no aggregation function of type @Aggregator b b' ->-'S.SelectArr' a b -> 'S.SelectArr' a b'@.  Such a function would allow violation-of SQL's scoping rules and lead to invalid queries.+If you want to use 'aggregate' with 'S.SelectArr's then you should+compose it with 'Opaleye.Lateral.laterally': +@+'Opaleye.Lateral.laterally' . 'aggregate' :: 'Aggregator' a b -> 'S.SelectArr' a b -> 'S.SelectArr' a b+@+ Please note that when aggregating an empty query with no @GROUP BY@ clause, Opaleye's behaviour differs from Postgres's behaviour. Postgres returns a single row whereas Opaleye returns zero rows.@@ -72,7 +75,7 @@  -} aggregate :: Aggregator a b -> S.Select a -> S.Select b-aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)+aggregate agg q = Q.productQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)  -- | Order the values within each aggregation in `Aggregator` using -- the given ordering. This is only relevant for aggregations that@@ -129,7 +132,8 @@ arrayAgg :: Aggregator (C.Column a) (C.Column (T.SqlArray a)) arrayAgg = A.makeAggr HPQ.AggrArr -stringAgg :: C.Column T.SqlText -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText)+stringAgg :: C.Column T.SqlText+          -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText) stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn  -- | Count the number of rows in a query.  This is different from

@@ -18,11 +18,16 @@ --          -> S.Select (Foo (Field a) (Field b) (Field c)) -- @ ----- Please note that by design there are no binary relational functions--- of type @S.SelectArr a b -> S.SelectArr a b -> S.SelectArr a b@.  Such--- functions would allow violation of SQL's scoping rules and lead to--- invalid queries.+-- If you want to run a binary relational operator on+-- 'Select.SelectArr's you should apply 'Opaleye.Lateral.bilaterally'+-- to it, for example --+-- @+-- 'Opaleye.Lateral.bilaterally' 'union'+--   :: 'Data.Profunctor.Product.Default' 'B.Binaryspec' fields fields+--   => 'S.SelectArr' i fields -> 'S.SelectArr' i fields -> 'S.SelectArr' i fields+-- @+-- -- `unionAll` is very close to being the @\<|\>@ operator of a -- @Control.Applicative.Alternative@ instance but it fails to work -- only because of the typeclass constraint it has.@@ -32,6 +37,7 @@ module Opaleye.Binary where  import qualified Opaleye.Internal.Binary as B+import qualified Opaleye.Internal.Column import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Select             as S @@ -43,7 +49,7 @@             S.Select fields -> S.Select fields -> S.Select fields unionAll = unionAllExplicit def --- | The same as unionAll, except that it additionally removes any+-- | The same as 'unionAll', except that it additionally removes any --   duplicate rows. union :: Default B.Binaryspec fields fields =>          S.Select fields -> S.Select fields -> S.Select fields@@ -53,7 +59,7 @@             S.Select fields -> S.Select fields -> S.Select fields intersectAll = intersectAllExplicit def --- | The same as intersectAll, except that it additionally removes any+-- | The same as 'intersectAll', except that it additionally removes any --   duplicate rows. intersect :: Default B.Binaryspec fields fields =>          S.Select fields -> S.Select fields -> S.Select fields@@ -63,7 +69,7 @@             S.Select fields -> S.Select fields -> S.Select fields exceptAll = exceptAllExplicit def --- | The same as exceptAll, except that it additionally removes any+-- | The same as 'exceptAll', except that it additionally removes any --   duplicate rows. except :: Default B.Binaryspec fields fields =>          S.Select fields -> S.Select fields -> S.Select fields@@ -94,3 +100,10 @@ exceptExplicit :: B.Binaryspec fields fields'               -> S.Select fields -> S.Select fields -> S.Select fields' exceptExplicit = B.sameTypeBinOpHelper PQ.Except++-- * Adaptors++binaryspecField :: (B.Binaryspec+                        (Opaleye.Internal.Column.Column a)+                        (Opaleye.Internal.Column.Column a))+binaryspecField = B.binaryspecColumn

@@ -1,10 +1,13 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}--- | Functions for working directly with 'Column's.+-- | Do not use.  Will be deprecated in version 0.7.  Use+-- "Opaleye.Field" instead. --+-- Functions for working directly with 'Column's.+-- -- Please note that numeric 'Column' types are instances of 'Num', so -- you can use '*', '/', '+', '-' on them. ----- 'Column' will be renamed to "Opaelye.Field.Field_" in version 0.7,+-- 'Column' will be renamed to 'Opaleye.Field.Field_' in version 0.7, -- so you might want to use the latter as much as you can.  module Opaleye.Column (-- * 'Column'

@@ -1,10 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} -module Opaleye.Distinct (module Opaleye.Distinct, distinctExplicit)+module Opaleye.Distinct (module Opaleye.Distinct, Distinctspec,+                         -- * Explicit versions+                         distinctExplicit,+                         -- * Adaptors+                         distinctspecField,+                         distinctspecMaybeFields,+                        )        where  import           Opaleye.Select (Select)-import           Opaleye.Internal.Distinct (distinctExplicit, Distinctspec)+import           Opaleye.Internal.Distinct  import qualified Data.Profunctor.Product.Default as D @@ -22,9 +28,12 @@ -- distinct :: Select (Foo (Field a) (Field b) (Field c)) -> Select (Foo (Field a) (Field b) (Field c)) -- @ ----- By design there is no @distinct@ function of type @SelectArr a b ->--- SelectArr a b@.  Such a function would allow violation of SQL's--- scoping rules and lead to invalid queries.+-- If you want to run 'distinct' on 'Select.SelectArr's you should+-- apply 'Opaleye.Lateral.laterally' to it:+--+-- @+-- 'Opaleye.Lateral.laterally' 'distinct' :: 'Data.Profunctor.Product.Default' 'Distinctspec' fields fields => 'Opaleye.Select.SelectArr' i fields -> 'Opaleye.Select.SelectArr' i fields+-- @ distinct :: D.Default Distinctspec fields fields =>             Select fields -> Select fields distinct = distinctExplicit D.def

@@ -80,3 +80,6 @@ maybeToNullable :: Maybe (Field_ 'NonNullable a)                 -> Field_ 'Nullable a maybeToNullable = C.maybeToNullable++unsafeCoerceField :: C.Column a -> C.Column b+unsafeCoerceField = C.unsafeCoerceColumn

@@ -1,8 +1,6 @@--- | Left, right, and full outer joins.------ The interface in this module is much nicer than the standard \"make--- missing rows NULL\" interface that SQL provides.  If you really--- want the standard interface then use "Opaleye.Join".+-- | Alternative APIs to inner, left, right, and full outer joins.+-- See "Opaleye.Join" for details on the best way to do joins in+-- Opaleye.  {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}

@@ -27,14 +27,15 @@ type @a@ to a single row of type @b@, a 'Control.Foldl.Fold' @a@ @b@ takes a list of @a@ and returns a single value of type @b@. -}-newtype Aggregator a b = Aggregator-                         (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr],HPQ.AggrDistinct), HPQ.PrimExpr)-                                     HPQ.PrimExpr-                                     a b)+newtype Aggregator a b =+  Aggregator (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),+                          HPQ.PrimExpr)+                         HPQ.PrimExpr+                         a b)  makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)-makeAggr' m = Aggregator (PM.PackMap-                          (\f (C.Column e) -> fmap C.Column (f (fmap (,[],HPQ.AggrAll) m, e))))+makeAggr' mAggrOp = Aggregator (PM.PackMap+  (\f (C.Column e) -> fmap C.Column (f (fmap (, [], HPQ.AggrAll) mAggrOp, e))))  makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b) makeAggr = makeAggr' . Just@@ -73,26 +74,61 @@ -- @  orderAggregate :: O.Order a -> Aggregator a b -> Aggregator a b-orderAggregate o (Aggregator (PM.PackMap pm)) =-  Aggregator (PM.PackMap (\f c -> pm (f . P.first' (fmap ((\f' (a,b,c') -> (a,f' b,c')) (const $ O.orderExprs c o)))) c))+orderAggregate o (Aggregator (PM.PackMap pm)) = Aggregator (PM.PackMap+  (\f c -> pm (f . P.first' (fmap ((\f' (a,b,c') -> (a,f' b,c')) (const $ O.orderExprs c o)))) c)) -runAggregator :: Applicative f => Aggregator a b-              -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> f HPQ.PrimExpr)-              -> a -> f b+runAggregator+  :: Applicative f+  => Aggregator a b+  -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)+     -> f HPQ.PrimExpr)+  -> a -> f b runAggregator (Aggregator a) = PM.traversePM a +-- In Postgres (and, I believe, standard SQL) "aggregate functions are+-- not allowed in FROM clause of their own query level".  There+-- doesn't seem to be any fundamental reason for this, but we are+-- stuck with it.  That means that in a lateral subquery containing an+-- aggregation over a field C from a previous subquery we have to+-- create a new field name for C before we are allowed to aggregate it!+-- For more information see+--+--     https://www.postgresql.org/message-id/20200513110251.GC24083%40cloudinit-builder+--+--     https://github.com/tomjaguarpaw/haskell-opaleye/pull/460#issuecomment-626716160+--+-- Instead of detecting when we are aggregating over a field from a+-- previous query we just create new names for all field before we+-- 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)-  where (c1, projPEs) =+  where (c1, projPEs_inners) =           PM.run (runAggregator agg (extractAggregateFields t0) c0) -        primQ' = PQ.Aggregate projPEs primQ+        projPEs = map fst projPEs_inners+        inners  = map snd projPEs_inners -extractAggregateFields :: T.Tag -> (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)-      -> PM.PM [(HPQ.Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))] HPQ.PrimExpr-extractAggregateFields = PM.extractAttr "result"+        primQ' = PQ.Aggregate projPEs (PQ.Rebind True inners primQ) +extractAggregateFields+  :: T.Tag+  -> (m, HPQ.PrimExpr)+  -> PM.PM [((HPQ.Symbol,+              (m, HPQ.Symbol)),+              (HPQ.Symbol, HPQ.PrimExpr))]+           HPQ.PrimExpr+extractAggregateFields tag (m, pe) = do+  i <- PM.new++  let souter = HPQ.Symbol ("result" ++ i) tag+      sinner = HPQ.Symbol ("inner" ++ i) tag++  PM.write ((souter, (m, sinner)), (sinner, pe))++  pure (HPQ.AttrExpr souter)+ -- { Boilerplate instances  instance Functor (Aggregator a) where@@ -106,8 +142,8 @@   dimap f g (Aggregator q) = Aggregator (P.dimap f g q)  instance PP.ProductProfunctor Aggregator where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance PP.SumProfunctor Aggregator where   Aggregator x1 +++! Aggregator x2 = Aggregator (x1 PP.+++! x2)

@@ -11,7 +11,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ  import           Data.Profunctor (Profunctor, dimap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import           Data.Profunctor.Product.Default (Default, def) @@ -38,7 +38,7 @@  sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'                     -> Q.Query columns -> Q.Query columns -> Q.Query columns'-sameTypeBinOpHelper binop binaryspec q1 q2 = Q.simpleQueryArr q where+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)@@ -47,7 +47,10 @@             PM.run (runBinaryspec binaryspec (extractBinaryFields endTag)                                     (columns1, columns2)) -          newPrimQuery = PQ.Binary binop pes (primQuery1, primQuery2)+          newPrimQuery = PQ.Binary binop+            ( PQ.Rebind False (map (fmap fst) pes) primQuery1+            , PQ.Rebind False (map (fmap snd) pes) primQuery2+            )  instance Default Binaryspec (Column a) (Column a) where   def = binaryspecColumn@@ -67,7 +70,7 @@   dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b)  instance ProductProfunctor Binaryspec where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  -- }

@@ -1,8 +1,10 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Opaleye.Internal.Distinct where -import           Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.MaybeFields as M+import           Opaleye.Select (Select) import           Opaleye.Column (Column) import           Opaleye.Aggregate (Aggregator, groupBy, aggregate) @@ -17,7 +19,7 @@ -- of something else that we already have is easier at this point.  distinctExplicit :: Distinctspec fields fields'-                 -> Query fields -> Query fields'+                 -> Select fields -> Select fields' distinctExplicit (Distinctspec agg) = aggregate agg  newtype Distinctspec a b = Distinctspec (Aggregator a b)@@ -25,6 +27,17 @@ instance Default Distinctspec (Column a) (Column a) where   def = Distinctspec groupBy +distinctspecField :: Distinctspec (Column a) (Column a)+distinctspecField = def++distinctspecMaybeFields :: M.WithNulls Distinctspec a b+                        -> Distinctspec (M.MaybeFields a) (M.MaybeFields b)+distinctspecMaybeFields = M.unWithNulls def++instance Default (M.WithNulls Distinctspec) a b+  => Default Distinctspec (M.MaybeFields a) (M.MaybeFields b) where+  def = distinctspecMaybeFields def+ -- { Boilerplate instances  instance Functor (Distinctspec a) where@@ -38,8 +51,8 @@   dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q)  instance PP.ProductProfunctor Distinctspec where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance PP.SumProfunctor Distinctspec where   Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2)

@@ -15,10 +15,12 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Base16 as Base16+import qualified Data.Char import qualified Data.List.NonEmpty as NEL import qualified Data.Text.Lazy.Builder.Scientific as Sci import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT+import qualified Text.Printf   mkSqlGenerator :: SqlGenerator -> SqlGenerator@@ -267,7 +269,9 @@ escape '\r' = "\\r" escape '\t' = "\\t" escape '\\' = "\\\\"-escape c = [c]+escape c = if Data.Char.isPrint c+           then [c]+           else Text.Printf.printf "\\U%0.8x" (Data.Char.ord c)   -- | Quote binary literals using Postgresql's hex format.

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Arrows #-}  module Opaleye.Internal.Join where @@ -9,13 +10,20 @@ import qualified Opaleye.Internal.Unpackspec          as U import           Opaleye.Internal.Column (Column(Column), Nullable) import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Operators as Op import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.PGTypes as T+import qualified Opaleye.SqlTypes as T import qualified Opaleye.Column as C+import           Opaleye.Field   (Field) import qualified Opaleye.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  import           Data.Profunctor (Profunctor, dimap) import qualified Data.Profunctor.Product as PP@@ -41,7 +49,7 @@              -> ((columnsA, columnsB) -> Column T.PGBool)              -> Q.Query (returnedColumnsA, returnedColumnsB) joinExplicit uA uB returnColumnsA returnColumnsB joinType-             qA qB cond = Q.simpleQueryArr q where+             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)@@ -87,6 +95,36 @@            primQueryR        , T.next t2) +optionalRestrict :: D.Default U.Unpackspec a a+                 => S.Select a+                 -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)+optionalRestrict = optionalRestrictExplicit D.def++optionalRestrictExplicit :: U.Unpackspec a a+                         -> S.Select a+                         -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)+optionalRestrictExplicit uA q =+  dimap (. snd) (\(nonNullIfPresent, rest) ->+      let present = Op.not (C.isNull (C.unsafeCoerceColumn nonNullIfPresent))+      in MaybeFields { mfPresent = present+                     , mfFields  = rest+                     }) $+  leftJoinAExplicit (PP.p2 (U.unpackspecColumn, uA))+                    (Opaleye.Internal.Join.NullMaker id)+                    (fmap (\x -> (T.sqlBool True, x)) q)++-- | An example to demonstrate how the functionality of @LEFT JOIN@+-- can be recovered using 'optionalRestrict'.+leftJoinInTermsOfOptionalRestrict :: D.Default U.Unpackspec fieldsR fieldsR+                                  => S.Select fieldsL+                                  -> S.Select fieldsR+                                  -> ((fieldsL, fieldsR) -> Field T.SqlBool)+                                  -> S.Select (fieldsL, MaybeFields fieldsR)+leftJoinInTermsOfOptionalRestrict qL qR cond = proc () -> do+  fieldsL <- qL -< ()+  maybeFieldsR <- optionalRestrict qR -< curry cond fieldsL+  Control.Arrow.returnA -< (fieldsL, maybeFieldsR)+ extractLeftJoinFields :: Int                       -> T.Tag                       -> HPQ.PrimExpr@@ -106,11 +144,12 @@   dimap f g (NullMaker h) = NullMaker (dimap f g h)  instance PP.ProductProfunctor NullMaker where-  empty  = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  -- +-- | Do not use.  Nulled will be deprecated in 0.7. data Nulled  type instance TF.IMap Nulled TF.OT     = TF.NullsT

@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}++module Opaleye.Internal.Lateral+  ( lateral+  , viaLateral+  , laterally+  , bilaterally+  , bind+  , arrowApply+  )+where++import           Opaleye.Internal.QueryArr++-- | Lifts operations like 'Opaleye.Aggregate.aggregate',+-- 'Opaleye.Order.orderBy' and 'Opaleye.Order.limit', which are restricted to+-- 'Select' normally, to operate on 'SelectArr's taking arbitrary inputs.+laterally :: (Select a -> Select b) -> SelectArr i a -> SelectArr i b+laterally f as = lateral (\i -> f (viaLateral as i))+++-- | Lifts operations like 'Opaleye.Binary.union', 'Opaleye.Binary.intersect'+-- and 'Opaleye.Binary.except', which are restricted to 'Select' normally, to+-- operate on 'SelectArr's taking arbitrary inputs.+bilaterally :: (Select a -> Select b -> Select c)+            -> SelectArr i a -> SelectArr i b -> SelectArr i c+bilaterally f as bs = lateral (\i -> f (viaLateral as i) (viaLateral bs i))

@@ -118,8 +118,8 @@   dimap f g (Updater h) = Updater (dimap f g h)  instance PP.ProductProfunctor Updater where-  empty  = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  -- 

@@ -0,0 +1,316 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-}++module Opaleye.Internal.MaybeFields where++import           Control.Applicative hiding (optional)+import           Control.Arrow (returnA, (<<<), (>>>))++import qualified Opaleye.Internal.Binary as B+import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Constant as Constant+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.QueryArr as IQ+import qualified Opaleye.Internal.RunQuery as RQ+import qualified Opaleye.Internal.Tag as Tag+import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Values as V+import           Opaleye.Select (Select, SelectArr)+import qualified Opaleye.Column+import qualified Opaleye.Field+import           Opaleye.Field (Field)+import           Opaleye.Internal.Operators ((.&&), (.||), (.==), restrict, not,+                                             ifExplict, IfPP, EqPP(EqPP))+import qualified Opaleye.Internal.Lateral+import qualified Opaleye.SqlTypes+import           Opaleye.SqlTypes (SqlBool, IsSqlType)++import           Control.Monad (replicateM_)++import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import qualified Data.Profunctor.Product.Default as PP++import qualified Database.PostgreSQL.Simple.FromRow as PGSR++-- | The Opaleye analogue of 'Data.Maybe.Maybe'+data MaybeFields fields =+  MaybeFields {+    mfPresent :: Opaleye.Column.Column Opaleye.SqlTypes.SqlBool+  , mfFields  :: fields+  }+  deriving Functor++instance Applicative MaybeFields where+  pure fields = MaybeFields { mfPresent = Opaleye.SqlTypes.sqlBool True+                            , mfFields  = fields+                            }+  MaybeFields t f <*> MaybeFields t' a =+    MaybeFields {+      mfPresent = t .&& t'+    , mfFields  = f a+    }++instance Monad MaybeFields where+  return = pure+  MaybeFields t a >>= f = case f a of+    MaybeFields t' b -> MaybeFields (t .&& t') b++-- | The Opaleye analogue of 'Data.Maybe.Nothing'.+nothingFields :: PP.Default V.Nullspec a a => MaybeFields a+nothingFields = nothingFieldsExplicit def+  where def :: PP.Default V.Nullspec a a => V.Nullspec a a+        def = PP.def++-- | The Opaleye analogue of @'Prelude.const' 'Data.Maybe.Nothing'@.+-- Can be useful to avoid type inference problems, because it doesn't+-- pick up a type class constraint.+nothingFieldsOfTypeOf :: a -> MaybeFields a+nothingFieldsOfTypeOf a = MaybeFields {+    mfPresent = Opaleye.SqlTypes.sqlBool False+  , mfFields  = a+  }++-- | The Opaleye analogue of 'Data.Maybe.Just'.  Equivalent to+-- 'Control.Applicative.pure'.+justFields :: a -> MaybeFields a+justFields = pure++-- | The Opaleye analogue of 'Data.Maybe.maybe'+maybeFields :: PP.Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b+maybeFields = maybeFieldsExplicit PP.def++-- | The Opaleye analogue of 'Data.Maybe.fromMaybe'+fromMaybeFields :: PP.Default IfPP b b => b -> MaybeFields b -> b+fromMaybeFields = fromMaybeFieldsExplicit PP.def++-- | The Opaleye analogue of 'Data.Maybe.maybeToList'+maybeFieldsToSelect :: SelectArr (MaybeFields a) a+maybeFieldsToSelect = proc mf -> do+  restrict -< mfPresent mf+  returnA -< mfFields mf++-- | The Opaleye analogue of 'Data.Maybe.catMaybes'+catMaybeFields :: SelectArr i (MaybeFields a) -> SelectArr i a+catMaybeFields = (>>> maybeFieldsToSelect)++maybeFieldsExplicit :: IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'+maybeFieldsExplicit ifpp b f mf =+  ifExplict ifpp (mfPresent mf) (f (mfFields mf)) b++fromMaybeFieldsExplicit :: IfPP b b -> b -> MaybeFields b -> b+fromMaybeFieldsExplicit ifpp = flip (maybeFieldsExplicit ifpp) id++nothingFieldsExplicit :: V.Nullspec a b -> MaybeFields b+nothingFieldsExplicit = nothingFieldsOfTypeOf . V.nullFields++traverseMaybeFields :: SelectArr a b -> SelectArr (MaybeFields a) (MaybeFields b)+traverseMaybeFields query = proc mfInput -> do+  mfOutput <- optional (query <<< maybeFieldsToSelect) -< mfInput+  restrict -< mfPresent mfInput `implies` mfPresent mfOutput+  returnA -< MaybeFields (mfPresent mfInput) (mfFields mfOutput)++  where a `implies` b = Opaleye.Internal.Operators.not a .|| b++optional :: SelectArr i a -> SelectArr i (MaybeFields a)+optional = Opaleye.Internal.Lateral.laterally optionalSelect+  where+    -- This is basically a left join on TRUE, but Shane (@duairc)+    -- wrote it to ensure that we don't need an Unpackspec a a.+    optionalSelect :: Select a -> Select (MaybeFields a)+    optionalSelect = IQ.QueryArr . go++    go query ((), left, tag) = (MaybeFields present a, join, Tag.next tag')+      where+        (MaybeFields t a, right, tag') =+          IQ.runSimpleQueryArr (justFields <$> query) ((), tag)++        present = isNotNull (IC.unsafeCoerceColumn t')++        (t', bindings) =+          PM.run (U.runUnpackspec U.unpackspecColumn (PM.extractAttr "maybe" tag') t)+        join = PQ.Join PQ.LeftJoin true [] bindings left right+    true = HPQ.ConstExpr (HPQ.BoolLit True)+    isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull+++-- | An example to demonstrate how the functionality of (lateral)+-- @LEFT JOIN@ can be recovered using 'optional'.+lateralLeftJoinOptional :: SelectArr i a+                        -> SelectArr i b+                        -> ((a, b) -> Opaleye.Field.Field Opaleye.SqlTypes.SqlBool)+                        -> SelectArr i (a, MaybeFields b)+lateralLeftJoinOptional fieldsL fieldsR cond = proc i -> do+  fieldsL' <- fieldsL -< i+  maybeFieldsR' <- optional (proc (fieldsL', i) -> do+                                fieldsR' <- fieldsR -< i+                                restrict -< cond (fieldsL', fieldsR')+                                returnA -< fieldsR'+                                ) -< (fieldsL', i)+  returnA -< (fieldsL', maybeFieldsR')++-- | An example to demonstrate how the functionality of+-- 'Opaleye.Join.optionalRestrict' can be recovered using 'optional'.+optionalRestrictOptional :: Select a+                         -> SelectArr (a -> Field SqlBool) (MaybeFields a)+optionalRestrictOptional q = optional $ proc cond -> do+  a <- q -< ()+  restrict -< cond a+  returnA -< a++fromFieldsMaybeFields :: RQ.FromFields fields haskells+                      -> RQ.FromFields (MaybeFields fields) (Maybe haskells)+fromFieldsMaybeFields (RQ.QueryRunner u p c) = RQ.QueryRunner u' p' c'+  where u' = () <$ productProfunctorMaybeFields U.unpackspecColumn u++        p' = \mf -> do+          hIsPresent <- PGSR.field++          case hIsPresent of+            True  -> Just <$> p (mfFields mf)+            False -> Nothing <$ replicateM_ (c (mfFields mf))+                                            (PGSR.fieldWith (\_ _ -> pure ()))++        c' = \mf -> c (mfFields mf) + 1++-- | This is not safe in general because it relies on p not doing+-- anything observable with the @a@s if @mfPresent@ is false.  In+-- particular, it won't work for+-- 'Opaleye.Internal.Distinct.Distinctspec' because it does indeed+-- look at the @mfFields@ to check distinctness.+productProfunctorMaybeFields :: PP.ProductProfunctor p+                             => p (Field SqlBool) (Field SqlBool)+                             -> p a b+                             -> p (MaybeFields a) (MaybeFields b)+productProfunctorMaybeFields b p = MaybeFields PP.***$ P.lmap mfPresent b+                                               PP.**** P.lmap mfFields p++nullspecMaybeFields :: V.Nullspec a b+                    -> V.Nullspec (MaybeFields a) (MaybeFields b)+nullspecMaybeFields = productProfunctorMaybeFields V.nullspecField++unpackspecMaybeFields :: U.Unpackspec a b+                      -> U.Unpackspec (MaybeFields a) (MaybeFields b)+unpackspecMaybeFields = productProfunctorMaybeFields U.unpackspecField++valuesspecMaybeFields :: V.ValuesspecSafe a b+                      -> V.ValuesspecSafe (MaybeFields a) (MaybeFields b)+valuesspecMaybeFields = productProfunctorMaybeFields V.valuesspecField++toFieldsMaybeFields :: V.Nullspec a b+                    -> Constant.ToFields a b+                    -> Constant.ToFields (Maybe a) (MaybeFields b)+toFieldsMaybeFields n p = Constant.Constant $ \case+  Nothing -> nothingFieldsExplicit n+  Just a  -> justFields (Constant.constantExplicit p a)++ifPPMaybeFields :: IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)+ifPPMaybeFields = productProfunctorMaybeFields PP.def++-- I'd rather not crack open EqPP to implement this but the+-- alternative is adding an operation eqPPOr :: EqPP a b -> EqPP a' b+-- -> EqPP (a, a') b, and possibly even more than that, so I can't be+-- bothered right now.+eqPPMaybeFields :: EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)+eqPPMaybeFields (EqPP eqFields) = EqPP (\m1 m2 ->+    (mfPresent m1 .== mfPresent m2)+    .&& (mfPresent m1 `implies` eqFields (mfFields m1) (mfFields m2)))+  where a `implies` b = Opaleye.Internal.Operators.not a .|| b++-- | This is only safe if d is OK with having nulls passed through it+-- when they claim to be non-null.+unWithNulls :: PP.ProductProfunctor p+            => p (Field SqlBool) (Field SqlBool)+            -> WithNulls p a b+            -> p (MaybeFields a) (MaybeFields b)+unWithNulls b (WithNulls d) =+    MaybeFields PP.***$ P.lmap mfPresent b+                PP.**** d++newtype WithNulls p a b =+  WithNulls (p (MaybeFields a) b)++-- | This is only safe if d is OK with having nulls passed through it+-- when they claim to be non-null.+mapMaybeFieldsWithNulls :: PP.ProductProfunctor p+                        => p (Field SqlBool) (Field SqlBool)+                        -> WithNulls p a b+                        -> WithNulls p (MaybeFields a) (MaybeFields b)+mapMaybeFieldsWithNulls b d =+  MaybeFields <$> P.lmap mfPresent (withNullsField b)+              <*> P.lmap mfFields d++-- | This is only safe if d is OK with having nulls passed through it+-- when they claim to be non-null.+withNullsField :: (IsSqlType a, P.Profunctor p)+               => p (IC.Column a) (IC.Column a)+               -> WithNulls p (IC.Column a) (IC.Column a)+withNullsField col = result+  where result = WithNulls (P.lmap (\(MaybeFields b c) ->+                                      ifExplict PP.def b c nullC) col)+        nullC = IC.Column (V.nullPE (columnProxy result))++        columnProxy :: f (IC.Column sqlType) -> Maybe sqlType+        columnProxy _ = Nothing++binaryspecMaybeFields+  :: WithNulls B.Binaryspec a b+  -> B.Binaryspec (MaybeFields a) (MaybeFields b)+binaryspecMaybeFields = unWithNulls PP.def++instance P.Profunctor p => P.Profunctor (WithNulls p) where+  dimap f g (WithNulls d) = WithNulls (P.dimap (fmap f) g d)++instance P.Profunctor p => Functor (WithNulls p a) where+  fmap = P.rmap++instance PP.ProductProfunctor p => Applicative (WithNulls p a) where+  pure = WithNulls . PP.purePP+  WithNulls fd <*> WithNulls xd = WithNulls (fd PP.**** xd)++instance PP.ProductProfunctor p => PP.ProductProfunctor (WithNulls p) where+  purePP = pure+  (****) = (<*>)++instance PP.SumProfunctor p => PP.SumProfunctor (WithNulls p) where+  WithNulls ff +++! WithNulls xf =+    WithNulls (flip P.lmap (ff PP.+++! xf) $ \case+                  MaybeFields b (Left l)  -> Left  (MaybeFields b l)+                  MaybeFields b (Right r) -> Right (MaybeFields b r))++instance PP.Default RQ.QueryRunner fields haskells+  => PP.Default RQ.QueryRunner (MaybeFields fields) (Maybe haskells) where+  def = fromFieldsMaybeFields PP.def++instance PP.Default U.Unpackspec a b+  => PP.Default U.Unpackspec (MaybeFields a) (MaybeFields b) where+  def = unpackspecMaybeFields PP.def++instance PP.Default V.ValuesspecSafe a b+  => PP.Default V.ValuesspecSafe (MaybeFields a) (MaybeFields b) where+  def = valuesspecMaybeFields PP.def++instance (PP.Default Constant.Constant a b, PP.Default V.Nullspec a b)+  => PP.Default Constant.Constant (Maybe a) (MaybeFields b) where+  def = toFieldsMaybeFields PP.def PP.def++instance PP.Default IfPP a b+  => PP.Default IfPP (MaybeFields a) (MaybeFields b) where+  def = ifPPMaybeFields PP.def++instance PP.Default EqPP a b+  => PP.Default EqPP (MaybeFields a) (MaybeFields b) where+  def = eqPPMaybeFields PP.def++instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Column a) (IC.Column a))+  => PP.Default (WithNulls p) (IC.Column a) (IC.Column a) where+  def = withNullsField PP.def++instance PP.Default (WithNulls B.Binaryspec) a b+  => PP.Default B.Binaryspec (MaybeFields a) (MaybeFields b) where+  def = binaryspecMaybeFields PP.def

@@ -4,7 +4,7 @@  module Opaleye.Internal.Operators where -import           Opaleye.Internal.Column (Column)+import           Opaleye.Internal.Column (Column(Column)) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ@@ -14,29 +14,47 @@ import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.PGTypes as T+import qualified Opaleye.SqlTypes as T+import qualified Opaleye.Field as F+import qualified Opaleye.Select as S  import           Data.Profunctor (Profunctor, dimap, lmap, rmap) import           Data.Profunctor.Product (ProductProfunctor, empty, (***!)) 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)+ infix 4 .== (.==) :: forall columns. D.Default EqPP columns columns       => columns -> columns -> Column T.PGBool (.==) = eqExplicit (D.def :: EqPP columns columns) +infixr 2 .||++(.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool+(.||) = C.binOp HPQ.OpOr+ infixr 3 .&&  -- | Boolean and (.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool (.&&) = C.binOp HPQ.OpAnd +not :: F.Field T.SqlBool -> F.Field T.SqlBool+not = C.unOp HPQ.OpNot+ newtype EqPP a b = EqPP (a -> a -> Column T.PGBool) +eqPPField :: EqPP (Column a) ignored+eqPPField = EqPP C.unsafeEq+ eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool eqExplicit (EqPP f) = f  instance D.Default EqPP (Column a) (Column a) where-  def = EqPP C.unsafeEq+  def = eqPPField   newtype IfPP a b = IfPP (Column T.PGBool -> a -> a -> b)@@ -48,6 +66,9 @@           -> columns' ifExplict (IfPP f) = f +ifPPField :: IfPP (Column a) (Column a)+ifPPField = D.def+ instance D.Default IfPP (Column a) (Column a) where   def = IfPP C.unsafeIfThenElse @@ -78,7 +99,7 @@                            -> (a -> HPQ.PrimExpr)                            -> QA.QueryArr a columns relationValuedExprExplicit rem_ strings pe =-  QA.simpleQueryArr $ \(a, tag) ->+  QA.productQueryArr $ \(a, tag) ->     let (primExprs, projcols) = runRelExprMaker rem_ tag strings         primQ :: PQ.PrimQuery         primQ = PQ.RelExpr (pe a) projcols

@@ -8,28 +8,29 @@ import           Opaleye.Internal.Helpers   ((.:))  import qualified Data.List.NonEmpty as NEL+import           Data.Semigroup ((<>))  import           Control.Applicative ((<$>), (<*>), pure)-import qualified Data.Traversable    as T+import           Control.Arrow (first)  optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a optimize = mergeProduct . removeUnit  removeUnit :: PQ.PrimQuery' a -> PQ.PrimQuery' a removeUnit = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product   = product }-  where product pqs pes = PQ.Product pqs' pes-          where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit) pqs) of-                         Nothing -> return PQ.Unit+  where product pqs = PQ.Product pqs'+          where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit . snd) pqs) of+                         Nothing -> return (pure PQ.Unit)                          Just xs -> xs  mergeProduct :: PQ.PrimQuery' a -> PQ.PrimQuery' a mergeProduct = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product   = product }   where product pqs pes = PQ.Product pqs' (pes ++ pes')           where pqs' = pqs >>= queries-                queries (PQ.Product qs _) = qs+                queries (lat, PQ.Product qs _) = fmap (first (lat <>)) qs                 queries q = return q                 pes' = NEL.toList pqs >>= conds-                conds (PQ.Product _ cs) = cs+                conds (_lat, PQ.Product _ cs) = cs                 conds _ = []  removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b)@@ -37,7 +38,11 @@     PQ.unit      = return PQ.Unit   , PQ.empty     = const Nothing   , PQ.baseTable = return .: PQ.BaseTable-  , PQ.product   = \x y -> PQ.Product <$> T.sequence x+  , PQ.product   = let sequenceOf l = traverseOf l id+                       traverseOf = id+                       _2 = traverse+                   in+                   \x y -> PQ.Product <$> sequenceOf (traverse._2) x                                       <*> pure y   , PQ.aggregate = fmap . PQ.Aggregate   , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns@@ -56,11 +61,12 @@       PQ.IntersectAll -> binary (const Nothing) (const Nothing) PQ.IntersectAll   , PQ.label     = fmap . PQ.Label   , PQ.relExpr   = return .: PQ.RelExpr+  , PQ.rebind    = \b -> fmap . PQ.Rebind b   }   where -- If only the first argument is Just, do n1 on it         -- If only the second argument is Just, do n2 on it-        binary n1 n2 jj exprs = \case+        binary n1 n2 jj = \case           (Nothing, Nothing)   -> Nothing           (Nothing, Just pq2)  -> n2 pq2           (Just pq1, Nothing)  -> n1 pq1-          (Just pq1, Just pq2) -> Just (PQ.Binary jj exprs (pq1, pq2))+          (Just pq1, Just pq2) -> Just (PQ.Binary jj (pq1, pq2))

@@ -9,7 +9,7 @@ import           Control.Applicative (Applicative, pure, (<*>), liftA2) import qualified Control.Monad.Trans.State as State import           Data.Profunctor (Profunctor, dimap, rmap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import qualified Data.Functor.Identity as I @@ -40,7 +40,8 @@ -- 'ProductProfunctor') in @s@ and @t@.  It is unclear at this point -- whether we want the same @Traversal@ laws to hold or not.  Our use -- cases may be much more general.-newtype PackMap a b s t = PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)+newtype PackMap a b s t =+  PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)  -- | Replaces the targeted occurences of @a@ in @s@ with @b@ (changing -- the @s@ to a @t@ in the process).  This can be done via an@@ -91,8 +92,10 @@ -- -- Add the fresh name and the input value it refers to to the list in -- the state parameter.-extractAttrPE :: (primExpr -> String -> String) -> T.Tag -> primExpr-               -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr+extractAttrPE :: (primExpr -> String -> String)+              -> T.Tag+              -> primExpr+              -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr extractAttrPE mkName t pe = do   i <- new   let s = HPQ.Symbol (mkName pe i) t@@ -101,8 +104,10 @@  -- | As 'extractAttrPE' but ignores the 'primExpr' when making the -- fresh column name and just uses the supplied 'String' and 'T.Tag'.-extractAttr :: String -> T.Tag -> primExpr-               -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr+extractAttr :: String+            -> T.Tag+            -> primExpr+            -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr extractAttr s = extractAttrPE (const (s ++))  -- }@@ -134,8 +139,8 @@   dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q)  instance ProductProfunctor (PackMap a b) where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance PP.SumProfunctor (PackMap a b) where   PackMap f +++! PackMap g = PackMap (\x -> eitherFunction (f x) (g x))

@@ -3,6 +3,7 @@ import           Prelude hiding (product)  import qualified Data.List.NonEmpty as NEL+import           Data.Semigroup (Semigroup, (<>)) import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import           Opaleye.Internal.HaskellDB.PrimQuery (Symbol)@@ -18,7 +19,7 @@            | IntersectAll              deriving Show -data JoinType = LeftJoin | RightJoin | FullJoin | LeftJoinLateral deriving Show+data JoinType = LeftJoin | RightJoin | FullJoin deriving Show  data TableIdentifier = TableIdentifier   { tiSchemaName :: Maybe String@@ -31,6 +32,17 @@  type Bindings a = [(Symbol, a)] +data Lateral = NonLateral | Lateral+  deriving Show++instance Semigroup Lateral where+  NonLateral <> NonLateral = NonLateral+  _ <> _ = Lateral++instance Monoid Lateral where+  mappend = (<>)+  mempty = NonLateral+ -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check -- for emptiness explicity in the SQL generation phase. @@ -42,14 +54,21 @@ data PrimQuery' a = Unit                   | Empty     a                   | BaseTable TableIdentifier (Bindings HPQ.PrimExpr)-                  | Product   (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr]-                  | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))+                  | Product   (NEL.NonEmpty (Lateral, PrimQuery' a)) [HPQ.PrimExpr]+                  | Aggregate (Bindings (Maybe (HPQ.AggrOp,+                                                [HPQ.OrderExpr],+                                                HPQ.AggrDistinct),+                                          HPQ.Symbol))                               (PrimQuery' a)-                  -- | Represents both @DISTINCT ON@ and @ORDER BY@ clauses. In order to represent valid-                  --   SQL only, @DISTINCT ON@ expressions are always interpreted as the first @ORDER BY@s-                  --   when present, preceding any in the provided list.+                  -- | Represents both @DISTINCT ON@ and @ORDER BY@+                  --   clauses. In order to represent valid SQL only,+                  --   @DISTINCT ON@ expressions are always+                  --   interpreted as the first @ORDER BY@s when+                  --   present, preceding any in the provided list.                   --   See 'Opaleye.Internal.Sql.distinctOnOrderBy'.-                  | DistinctOnOrderBy (Maybe (NEL.NonEmpty HPQ.PrimExpr)) [HPQ.OrderExpr] (PrimQuery' a)+                  | DistinctOnOrderBy (Maybe (NEL.NonEmpty HPQ.PrimExpr))+                                      [HPQ.OrderExpr]+                                      (PrimQuery' a)                   | Limit     LimitOp (PrimQuery' a)                   | Join      JoinType                               HPQ.PrimExpr@@ -60,10 +79,12 @@                   | Exists    Bool (PrimQuery' a) (PrimQuery' a)                   | Values    [Symbol] (NEL.NonEmpty [HPQ.PrimExpr])                   | Binary    BinOp-                              (Bindings (HPQ.PrimExpr, HPQ.PrimExpr))                               (PrimQuery' a, PrimQuery' a)                   | Label     String (PrimQuery' a)                   | RelExpr   HPQ.PrimExpr (Bindings HPQ.PrimExpr)+                  | Rebind    Bool+                              (Bindings HPQ.PrimExpr)+                              (PrimQuery' a)                  deriving Show  type PrimQuery = PrimQuery' ()@@ -73,9 +94,16 @@   { unit              :: p   , empty             :: a -> p   , baseTable         :: TableIdentifier -> Bindings HPQ.PrimExpr -> p-  , product           :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p-  , aggregate         :: Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> p -> p-  , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> p -> p+  , product           :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p+  , aggregate         :: Bindings (Maybe+                             (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),+                                   HPQ.Symbol)+                      -> p+                      -> p+  , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr)+                      -> [HPQ.OrderExpr]+                      -> p+                      -> p   , limit             :: LimitOp -> p -> p   , join              :: JoinType                       -> HPQ.PrimExpr@@ -86,10 +114,13 @@                       -> p   , existsf           :: Bool -> p -> p -> p   , values            :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p-  , binary            :: BinOp -> Bindings (HPQ.PrimExpr, HPQ.PrimExpr) -> (p, p) -> p+  , binary            :: BinOp+                      -> (p, p)+                      -> p   , label             :: String -> p -> p   , relExpr           :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p     -- ^ A relation-valued expression+  , rebind            :: Bool -> Bindings HPQ.PrimExpr -> p -> p   }  @@ -108,6 +139,7 @@   , label             = Label   , relExpr           = RelExpr   , existsf           = Exists+  , rebind            = Rebind   }  foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p@@ -116,23 +148,24 @@           Unit                        -> unit              f           Empty a                     -> empty             f a           BaseTable ti syms           -> baseTable         f ti syms-          Product qs pes              -> product           f (fmap self qs) pes+          Product qs pes              -> product           f (fmap (fmap self) qs) pes           Aggregate aggrs q           -> aggregate         f aggrs (self q)           DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs (self q)           Limit op q                  -> limit             f op (self q)           Join j cond pe1 pe2 q1 q2   -> join              f j cond pe1 pe2 (self q1) (self q2)           Values ss pes               -> values            f ss pes-          Binary binop pes (q1, q2)   -> binary            f binop pes (self q1, self q2)+          Binary binop (q1, q2)       -> binary            f binop (self q1, self q2)           Label l pq                  -> label             f l (self pq)           RelExpr pe syms             -> relExpr           f pe syms           Exists b q1 q2              -> existsf           f b (self q1) (self q2)+          Rebind star pes q           -> rebind            f star pes (self q)         fix g = let x = g x in x  times :: PrimQuery -> PrimQuery -> PrimQuery-times q q' = Product (q NEL.:| [q']) []+times q q' = Product (pure q NEL.:| [pure q']) []  restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery-restrict cond primQ = Product (return primQ) [cond]+restrict cond primQ = Product (return (pure primQ)) [cond]  exists :: PrimQuery -> PrimQuery -> PrimQuery exists = Exists True

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ module Opaleye.Internal.Print where  import           Prelude hiding (product)@@ -18,6 +20,7 @@  import           Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,                                             parens)+import qualified Data.Char import qualified Data.List.NonEmpty as NEL import qualified Data.Text          as ST @@ -72,9 +75,10 @@                    $$ ppSql (Sql.bSelect2 b)  ppSelectLabel :: Label -> Doc-ppSelectLabel l = text "/*" <+> text (defuseComments (Sql.lLabel l)) <+> text "*/"+ppSelectLabel l = text "/*" <+> text (preprocess (Sql.lLabel l)) <+> text "*/"                   $$ ppSql (Sql.lSelect l)   where+    preprocess = defuseComments . filter Data.Char.isPrint     defuseComments = ST.unpack                    . ST.replace (ST.pack "--") (ST.pack " - - ")                    . ST.replace (ST.pack "/*") (ST.pack " / * ")@@ -95,7 +99,6 @@ ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" ppJoinType Sql.RightJoin = text "RIGHT OUTER JOIN" ppJoinType Sql.FullJoin = text "FULL OUTER JOIN"-ppJoinType Sql.LeftJoinLateral = text "LEFT OUTER JOIN LATERAL"  ppAttrs :: Sql.SelectAttrs -> Doc ppAttrs Sql.Star                 = text "*"@@ -108,9 +111,15 @@ nameAs (expr, name) = HPrint.ppAs (fmap unColumn name) (HPrint.ppSqlExpr expr)   where unColumn (HSql.SqlColumn s) = s -ppTables :: [Select] -> Doc+ppTables :: [(Sql.Lateral, Select)] -> Doc ppTables [] = empty-ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts)+ppTables ts = text "FROM" <+> HPrint.commaV ppTable_tableAlias (zip [1..] ts)+  where ppTable_tableAlias :: (Int, (Sql.Lateral, Select)) -> Doc+        ppTable_tableAlias (i, (lat, select)) =+          lateral lat $ ppTable (tableAlias i select)+        lateral = \case+            Sql.NonLateral -> id+            Sql.Lateral -> (text "LATERAL" $$)  tableAlias :: Int -> Select -> (TableAlias, Select) tableAlias i select = ("T" ++ show i, select)

@@ -1,3 +1,5 @@+{-# LANGUAGE Arrows #-}+ module Opaleye.Internal.QueryArr where  import           Prelude hiding (id)@@ -10,10 +12,11 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ  import qualified Control.Arrow as Arr-import           Control.Arrow ((&&&), (***), arr)+import           Control.Arrow ((&&&), (***), arr, returnA) import qualified Control.Category as C import           Control.Category ((<<<), id) import           Control.Applicative (Applicative, pure, (<*>))+import           Data.List.NonEmpty ( NonEmpty((:|)) ) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP @@ -23,11 +26,15 @@  type Query = QueryArr () -simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b-simpleQueryArr f = QueryArr g+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 (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 @@ -46,6 +53,48 @@ 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.+--+-- @Select a@ is analogous to a Haskell value @[a]@.+type Select = SelectArr ()++-- | A parametrised 'Select'.  A @SelectArr a b@ accepts an argument+-- of type @a@.+--+-- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.+type SelectArr = QueryArr++-- | Implements @LATERAL@ subqueries.+--+-- You might find it easier to use 'Opaleye.Lateral.laterally' (if you+-- want to apply 'Opaleye.Aggregate.aggregate',+-- 'Opaleye.Order.orderBy' or 'Opaleye.Order.limit' to a 'SelectArr')+-- or 'Opaleye.Lateral.bilaterally' (if you want to apply+-- '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, primQueryL, tag) = (a, primQueryJoin, tag')+      where+        (a, primQueryR, tag') = runSimpleQueryArr (f i) ((), tag)+        primQueryJoin = PQ.Product ((PQ.NonLateral, primQueryL)+                                    :| [(PQ.Lateral, primQueryR)])+                                   []++viaLateral :: SelectArr i a -> i -> Select a+viaLateral s i = s <<< pure i++bind :: SelectArr i a -> (a -> SelectArr i b) -> SelectArr i b+bind s f = proc i -> do+  a <- s -< i+  b <- lateral (\(a, i) -> viaLateral (f a) i) -< (a, i)+  returnA -< b++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)@@ -62,12 +111,19 @@             Left a -> first3 Left (runQueryArr f (a, primQ, t0))             Right b -> (Right b, primQ, t0) +instance Arr.ArrowApply QueryArr where+  app = arrowApply+ instance Functor (QueryArr a) where   fmap f = (arr f <<<)  instance Applicative (QueryArr a) where   pure = arr . const   f <*> g = arr (uncurry ($)) <<< (f &&& g)++instance Monad (QueryArr a) where+  return = pure+  (>>=) = bind  instance P.Profunctor QueryArr where   dimap f g a = arr g <<< a <<< arr f

@@ -3,7 +3,8 @@  module Opaleye.Internal.RunQuery where -import           Control.Applicative (Applicative, pure, (*>), (<*>), liftA2)+import           Control.Applicative+  (Applicative, pure, (<$>), (*>), (<*>), liftA2)  import qualified Database.PostgreSQL.Simple.Cursor  as PGSC (Cursor) import           Database.PostgreSQL.Simple.Internal (RowParser)@@ -24,7 +25,6 @@ import qualified Data.Profunctor as P import           Data.Profunctor (dimap) import qualified Data.Profunctor.Product as PP-import           Data.Profunctor.Product (empty, (***!)) import qualified Data.Profunctor.Product.Default as D  import qualified Data.Aeson as Ae@@ -41,7 +41,6 @@  -- { Only needed for postgresql-simple FieldParsers -import           Control.Applicative ((<$>)) import           Database.PostgreSQL.Simple.FromField   (ResultError(UnexpectedNull, Incompatible), typeInfo, returnError) import qualified Database.PostgreSQL.Simple.TypeInfo as TI@@ -92,8 +91,8 @@               (columns -> RowParser haskells)               -- We never actually look at the columns except to see               -- its "type" in the case of a sum profunctor-              (columns -> Bool)-              -- Have we actually requested any columns?  If we+              (columns -> Int)+              -- How many columns have we requested?  If we               -- asked for zero columns then the SQL generator will               -- have to put a dummy 0 into the SELECT statement,               -- since we can't select zero columns.  In that case we@@ -121,7 +120,7 @@ fromPGSFieldParser = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn)  queryRunner :: FromField a b -> FromFields (Column a) b-queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True)+queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const 1)     where QueryRunnerColumn u fp = qrc  queryRunnerColumnNullable :: FromField a b@@ -288,19 +287,19 @@  -- TODO: Seems like this one should be simpler! instance Applicative (FromFields c) where-  pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const False)+  pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const 0)          . pure          . pure   QueryRunner uf rf bf <*> QueryRunner ux rx bx =-    QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (||) bf bx)+    QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (+) bf bx)  instance P.Profunctor FromFields where   dimap f g (QueryRunner u r b) =     QueryRunner (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b)  instance PP.ProductProfunctor FromFields where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance PP.SumProfunctor FromFields where   f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu))@@ -337,8 +336,8 @@ -- }  prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells-prepareRowParser (QueryRunner _ rowParser nonZeroColumns) cols =-  if nonZeroColumns cols+prepareRowParser (QueryRunner _ rowParser numColumns) cols =+  if numColumns cols > 0   then rowParser cols   else (fromRow :: RowParser (Only Int)) *> rowParser cols      -- If we are selecting zero columns then the SQL

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ module Opaleye.Internal.Sql where  import           Prelude hiding (product)@@ -37,7 +39,7 @@  data From = From {   attrs      :: SelectAttrs,-  tables     :: [Select],+  tables     :: [(Lateral, Select)],   criteria   :: [HSql.SqlExpr],   groupBy    :: Maybe (NEL.NonEmpty HSql.SqlExpr),   orderBy    :: [(HSql.SqlExpr, HSql.SqlOrder)],@@ -65,8 +67,9 @@   bSelect2 :: Select } deriving Show -data JoinType = LeftJoin | RightJoin | FullJoin | LeftJoinLateral deriving Show+data JoinType = LeftJoin | RightJoin | FullJoin deriving Show data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show+data Lateral = Lateral | NonLateral deriving Show  data Label = Label {   lLabel  :: String,@@ -96,6 +99,7 @@   , PQ.label             = label   , PQ.relExpr           = relExpr   , PQ.existsf           = exists+  , PQ.rebind            = rebind   }  exists :: Bool -> Select -> Select -> Select@@ -103,7 +107,7 @@  sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes))-                                          , tables = [pqSelect] }+                                          , tables = oneTable pqSelect }   where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq         makeAttrs = flip (zipWith makeAttr) [1..]         makeAttr pe i = sqlBinding (Symbol ("result" ++ show (i :: Int)) t, pe)@@ -114,32 +118,58 @@ empty :: V.Void -> select empty = V.absurd +oneTable :: t -> [(Lateral, t)]+oneTable t = [(NonLateral, t)]+ baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select baseTable ti columns = SelectFrom $     newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))-              , tables = [Table (HSql.SqlTable (PQ.tiSchemaName ti) (PQ.tiTableName ti))] }+              , tables = oneTable (Table (HSql.SqlTable (PQ.tiSchemaName ti) (PQ.tiTableName ti))) } -product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select+product :: NEL.NonEmpty (PQ.Lateral, Select) -> [HPQ.PrimExpr] -> Select product ss pes = SelectFrom $-    newSelect { tables = NEL.toList ss+    newSelect { tables = NEL.toList ss'               , criteria = map sqlExpr pes }+  where ss' = flip fmap ss $ Arr.first $ \case+          PQ.Lateral    -> Lateral+          PQ.NonLateral -> NonLateral -aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))] -> Select -> Select-aggregate aggrs s = SelectFrom $ newSelect { attrs = SelectAttrs-                                               (ensureColumns (map attr aggrs))-                                           , tables = [s]-                                           , groupBy = (Just . groupBy') aggrs }-  where --- Grouping by an empty list is not the identity function!-        --- In fact it forms one single group.  Syntactically one-        --- cannot group by nothing in SQL, so we just group by a-        --- constant instead.  Because "GROUP BY 0" means group by the-        --- zeroth column, we instead use an expression rather than a-        --- constant.+aggregate :: [(Symbol,+               (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),+                HPQ.Symbol))]+          -> Select+          -> Select+aggregate aggrs' s =+  SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (map attr aggrs))+                         , tables = oneTable s+                         , groupBy = (Just . groupBy') aggrs }+  where --- Although in the presence of an aggregation function,+        --- grouping by an empty list is equivalent to omitting group+        --- by, the equivalence does not hold in the absence of an+        --- aggregation function.  In the absence of an aggregation+        --- function, group by of an empty list will return a single+        --- row (if there are any and zero rows otherwise).  A query+        --- without group by will return all rows.  This is a weakness+        --- of SQL.  Really there ought to be a separate SELECT+        --- AGGREGATE operation.+        ---+        --- Syntactically one cannot group by an empty list in SQL.+        --- We take the conservative approach of explicitly grouping+        --- by a constant if we are provided with an empty list of+        --- group bys.  This yields a single group.  (Alternatively,+        --- we could check whether any aggregation functions have been+        --- applied and only group by a constant in the case where+        --- none have.  That would make the generated SQL less noisy.)+        ---+        --- "GROUP BY 0" means group by the zeroth column so we+        --- instead use an expression rather than a constant.         handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr         handleEmpty =           M.fromMaybe (return (SP.deliteral (HSql.ConstSqlExpr "0")))           . NEL.nonEmpty +        aggrs = (map . Arr.second . Arr.second) HPQ.AttrExpr aggrs'+         groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]                  -> NEL.NonEmpty HSql.SqlExpr         groupBy' = handleEmpty@@ -156,7 +186,7 @@  distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect-    { tables     = [s]+    { tables     = oneTable s     , distinctOn = fmap (SG.sqlExpr SD.defaultSqlGenerator) <$> distinctExprs     , orderBy    = map (SD.toSqlOrder SD.defaultSqlGenerator) $         -- Postgres requires all 'DISTINCT ON' expressions to appear before any other@@ -169,7 +199,7 @@             , HPQ.orderNulls     = HPQ.NullsLast }  limit_ :: PQ.LimitOp -> Select -> Select-limit_ lo s = SelectFrom $ newSelect { tables = [s]+limit_ lo s = SelectFrom $ newSelect { tables = oneTable s                                      , limit = limit'                                      , offset = offset' }   where (limit', offset') = case lo of@@ -190,7 +220,7 @@                   , jCond     = sqlExpr cond }   where selectFrom pes s = SelectFrom $ newSelect {             attrs  = SelectAttrsStar (ensureColumns (map sqlBinding pes))-          , tables = [s]+          , tables = oneTable s           }  -- Postgres seems to name columns of VALUES clauses "column1",@@ -202,24 +232,17 @@   where mkColumns = ensureColumns . zipWith (flip (curry (sqlBinding . Arr.second mkColumn))) [1..]         mkColumn i = (HPQ.BaseTableAttrExpr . ("column" ++) . show) (i::Int) -binary :: PQ.BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]-       -> (Select, Select) -> Select-binary op pes (select1, select2) = SelectBinary Binary {+binary :: PQ.BinOp -> (Select, Select) -> Select+binary op (select1, select2) = SelectBinary Binary {   bOp = binOp op,-  bSelect1 = SelectFrom newSelect { attrs = SelectAttrs-                                      (ensureColumns (map (mkColumn fst) pes)),-                                    tables = [select1] },-  bSelect2 = SelectFrom newSelect { attrs = SelectAttrs-                                      (ensureColumns (map (mkColumn snd) pes)),-                                    tables = [select2] }+  bSelect1 = select1,+  bSelect2 = select2   }-  where mkColumn e = sqlBinding . Arr.second e  joinType :: PQ.JoinType -> JoinType joinType PQ.LeftJoin = LeftJoin joinType PQ.RightJoin = RightJoin joinType PQ.FullJoin = FullJoin-joinType PQ.LeftJoinLateral = LeftJoinLateral  binOp :: PQ.BinOp -> BinOp binOp o = case o of@@ -267,5 +290,14 @@ relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> Select relExpr pe columns = SelectFrom $     newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))-              , tables = [RelExpr (sqlExpr pe)]+              , tables = oneTable (RelExpr (sqlExpr pe))               }++rebind :: Bool -> [(Symbol, HPQ.PrimExpr)] -> Select -> Select+rebind star pes select = SelectFrom newSelect+  { attrs = selectAttrs (ensureColumns (map sqlBinding pes))+  , tables = oneTable select+  }+  where selectAttrs = case star of+          True  -> SelectAttrsStar+          False -> SelectAttrs

@@ -15,7 +15,7 @@  import qualified Data.Functor.Identity as I import           Data.Profunctor (Profunctor, dimap, lmap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import qualified Data.List.NonEmpty as NEL import           Data.Monoid (Monoid, mempty, mappend)@@ -24,7 +24,7 @@ import qualified Control.Arrow as Arr  -- | Define a table as follows, where \"id\", \"color\", \"location\",--- \"quantity\" and \"radius\" are the tables columns in Postgres and+-- \"quantity\" and \"radius\" are the table's fields in Postgres and -- the types are given in the type signature.  The @id@ field is an -- autoincrementing field (i.e. optional for writes). --@@ -35,18 +35,18 @@ --                                , quantity :: d --                                , radius   :: e } ----- $('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)+-- \$('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget) ----- widgetTable :: Table (Widget (Maybe (Column PGInt4)) (Column PGText) (Column PGText)---                              (Column PGInt4) (Column PGFloat8))---                      (Widget (Column PGText) (Column PGText) (Column PGText)---                              (Column PGInt4) (Column PGFloat8))+-- widgetTable :: Table (Widget (Maybe (Field SqlInt4)) (Field SqlText) (Field SqlText)+--                              (Field SqlInt4) (Field SqlFloat8))+--                      (Widget (Field SqlText) (Field SqlText) (Field SqlText)+--                              (Field SqlInt4) (Field SqlFloat8)) -- widgetTable = table \"widgetTable\"---                      (pWidget Widget { wid      = tableColumn \"id\"---                                      , color    = tableColumn \"color\"---                                      , location = tableColumn \"location\"---                                      , quantity = tableColumn \"quantity\"---                                      , radius   = tableColumn \"radius\" })+--                      (pWidget Widget { wid      = tableField \"id\"+--                                      , color    = tableField \"color\"+--                                      , location = tableField \"location\"+--                                      , quantity = tableField \"quantity\"+--                                      , radius   = tableField \"radius\" }) -- @ -- -- The constructors of Table are internal only and will be@@ -95,7 +95,7 @@  -- | Internal only.  Do not use.  'View' will be deprecated in version -- 0.7.-data View columns = View columns+newtype View columns = View columns  -- | Internal only.  Do not use.  'Writer' will be deprecated in -- version 0.7.@@ -113,41 +113,57 @@   Writer (forall f. Functor f =>           PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ()) --- | 'required' is for fields which are not 'optional'.  You must--- provide them on writes.-required :: String -> TableFields (Column a) (Column a)-required columnName = TableProperties+-- | 'requiredTableField' is for fields which are not optional.  You+-- must provide them on writes.+requiredTableField :: String -> TableFields (Column a) (Column a)+requiredTableField columnName = TableProperties   (requiredW columnName)   (View (Column (HPQ.BaseTableAttrExpr columnName))) --- | 'optional' is for fields that you can omit on writes, such as---  columns which have defaults or which are SERIAL.-optional :: String -> TableFields (Maybe (Column a)) (Column a)-optional columnName = TableProperties+-- | 'optionalTableField' is for fields that you can omit on writes, such as+--  fields which have defaults or which are SERIAL.+optionalTableField :: String -> TableFields (Maybe (Column a)) (Column a)+optionalTableField columnName = TableProperties   (optionalW columnName)   (View (Column (HPQ.BaseTableAttrExpr columnName))) --- | 'readOnly' is for fields that you must omit on writes, such as---  SERIAL columns intended to auto-increment only.+-- | 'readOnlyTableField' is for fields that you must omit on writes, such as+--  SERIAL fields intended to auto-increment only.+readOnlyTableField :: String -> TableFields () (Column a)+readOnlyTableField = lmap (const Nothing) . optionalTableField++-- | Use 'requiredTableField' instead.  'required' will be deprecated+-- in 0.7.+required :: String -> TableFields (Column a) (Column a)+required = requiredTableField++-- | Use 'optionalTableField' instead.  'optional' will be deprecated+-- in 0.7.+optional :: String -> TableFields (Maybe (Column a)) (Column a)+optional = optionalTableField++-- | Use 'readOnlyTableField' instead.  'readOnly' will be deprecated+-- in 0.7. readOnly :: String -> TableFields () (Column a)-readOnly = lmap (const Nothing) . optional+readOnly = readOnlyTableField  class TableColumn writeType sqlType | writeType -> sqlType where     -- | Do not use.  Use 'tableField' instead.  Will be deprecated in     -- 0.7.     tableColumn :: String -> TableFields writeType (Column sqlType)     tableColumn = tableField-    -- | Infer either a 'required' or 'optional' column depending on+    -- | Infer either a required ('requiredTableField') or optional+    -- ('optionalTableField') field depending on     -- the write type.  It's generally more convenient to use this     -- than 'required' or 'optional' but you do have to provide a type     -- signature instead.     tableField  :: String -> TableFields writeType (Column sqlType)  instance TableColumn (Column a) a where-    tableField = required+    tableField = requiredTableField  instance TableColumn (Maybe (Column a)) a where-    tableField = optional+    tableField = optionalTableField  queryTable :: U.Unpackspec viewColumns columns             -> Table writeColumns viewColumns@@ -217,15 +233,15 @@   fmap _ (Writer g) = Writer g  instance Applicative (Writer a) where-  pure x = Writer (fmap (const ()) (pure x))+  pure _ = Writer (pure ())   Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)  instance Profunctor Writer where   dimap f _ (Writer h) = Writer (lmap (fmap f) h)  instance ProductProfunctor Writer where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance Functor (TableProperties a) where   fmap f (TableProperties w (View v)) = TableProperties (fmap f w) (View (f v))@@ -239,8 +255,8 @@   dimap f g (TableProperties w (View v)) = TableProperties (dimap f g w)                                                             (View (g v)) instance ProductProfunctor TableProperties where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance Functor (Table a) where   fmap f (Table t tp) = Table t (fmap f tp)

@@ -8,7 +8,7 @@ import qualified Opaleye.Internal.Unpackspec as U  import           Data.Profunctor (Profunctor, dimap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import           Data.Profunctor.Product.Default (Default, def) @@ -64,7 +64,7 @@   dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q)  instance ProductProfunctor ViewColumnMaker where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  --}

@@ -8,7 +8,7 @@  import           Control.Applicative (Applicative, pure, (<*>)) import           Data.Profunctor (Profunctor, dimap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import qualified Data.Profunctor.Product.Default as D @@ -35,10 +35,15 @@   -- 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' operations.   Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') --- | Target the single 'HPQ.PrimExpr' inside a 'C.Column'+-- | Use 'unpackspecField' instead.  @unpackspecColumn@ will be+-- deprecated in version 0.7. unpackspecColumn :: Unpackspec (C.Column a) (C.Column a) unpackspecColumn = Unpackspec (PM.iso IC.unColumn IC.Column) +-- | Target the single 'HPQ.PrimExpr' inside a 'C.Column'+unpackspecField :: Unpackspec (C.Column a) (C.Column a)+unpackspecField = Unpackspec (PM.iso IC.unColumn IC.Column)+ -- | Modify all the targeted 'HPQ.PrimExpr's runUnpackspec :: Applicative f                  => Unpackspec columns b@@ -69,8 +74,8 @@   dimap f g (Unpackspec q) = Unpackspec (dimap f g q)  instance ProductProfunctor Unpackspec where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)  instance PP.SumProfunctor Unpackspec where   Unpackspec x1 +++! Unpackspec x2 = Unpackspec (x1 PP.+++! x2)

@@ -8,10 +8,13 @@ import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.PGTypes+import qualified Opaleye.SqlTypes +import           Data.Functor.Identity (runIdentity) import qualified Data.List.NonEmpty as NEL-import           Data.Profunctor (Profunctor, dimap, rmap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import           Data.Profunctor (Profunctor, dimap, rmap, lmap)+import           Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import           Data.Profunctor.Product.Default (Default, def) @@ -59,9 +62,105 @@               -> (() -> f HPQ.PrimExpr) -> f columns' runValuesspec (Valuesspec v) f = PM.traversePM v f () +-- For 0.7 put an `IsSqlType a` constraint on here, so that we can+-- later use it without breaking the API instance Default Valuesspec (Column a) (Column a) where   def = Valuesspec (PM.iso id Column) +valuesUSafe :: ValuesspecSafe columns columns'+            -> [columns]+            -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)+valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =+  (newColumns, primQ', T.next t)+  where runRow row =+          case PM.run (U.runUnpackspec unpack extractValuesEntry row) of+            (_, []) -> [zero]+            (_, xs) -> xs++        (newColumns, valuesPEs_nulls) =+          PM.run (runValuesspecSafe valuesspec (extractValuesField t))++        valuesPEs = map fst valuesPEs_nulls+        nulls = case map snd valuesPEs_nulls of+          []     -> [nullInt]+          nulls' -> nulls'++        yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery+        yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))++        zero = HPQ.ConstExpr (HPQ.IntegerLit 0)+        nullInt = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType+                                  (Nothing :: Maybe Opaleye.SqlTypes.SqlInt4))+                               (HPQ.ConstExpr HPQ.NullLit)++        (values, wrap) = case NEL.nonEmpty rows of+          Nothing    -> (pure nulls, yieldNoRows)+          Just rows' -> (fmap runRow rows', id)++        primQ' = wrap (PQ.Values valuesPEs values)++data ValuesspecSafe columns columns' =+  ValuesspecSafe (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')+                 (U.Unpackspec columns columns')++runValuesspecSafe :: Applicative f+                  => ValuesspecSafe columns columns'+                  -> (HPQ.PrimExpr -> f HPQ.PrimExpr)+                  -> f columns'+runValuesspecSafe (ValuesspecSafe v _) f = PM.traversePM v f ()++valuesspecField :: Opaleye.SqlTypes.IsSqlType a+                => ValuesspecSafe (Column a) (Column a)+valuesspecField = def++instance Opaleye.Internal.PGTypes.IsSqlType a+  => Default ValuesspecSafe (Column a) (Column a) where+  def = def_+    where def_ = ValuesspecSafe (PM.PackMap (\f () -> fmap Column (f null_)))+                                U.unpackspecColumn+          null_ = nullPE sqlType++          sqlType = columnProxy def_+          columnProxy :: f (Column sqlType) -> Maybe sqlType+          columnProxy _ = Nothing++nullPE :: Opaleye.SqlTypes.IsSqlType a => proxy a -> HPQ.PrimExpr+nullPE sqlType = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType sqlType)+                              (HPQ.ConstExpr HPQ.NullLit)++-- Implementing this in terms of Valuesspec for convenience+newtype Nullspec fields fields' = Nullspec (ValuesspecSafe fields fields')++nullspecField :: Opaleye.SqlTypes.IsSqlType b+              => Nullspec a (Column b)+nullspecField = Nullspec (lmap e valuesspecField)+  where e = error (concat [ "We looked at the argument of a Nullspec when we "+                          , "expected that we never would!  This is a bug in "+                          , "Opaleye.  Please report it, if you can reproduce "+                          , "it."+                          ])++nullspecList :: Nullspec a [b]+nullspecList = pure []++nullspecEitherLeft :: Nullspec a b+                   -> Nullspec a (Either b b')+nullspecEitherLeft = fmap Left++nullspecEitherRight :: Nullspec a b'+                    -> Nullspec a (Either b b')+nullspecEitherRight = fmap Right++instance Opaleye.SqlTypes.IsSqlType b+  => Default Nullspec a (Column b) where+  def = nullspecField++-- | All fields @NULL@, even though technically the type may forbid+-- that!  Used to create such fields when we know we will never look+-- at them expecting to find something non-NULL.+nullFields :: Nullspec a fields -> fields+nullFields (Nullspec v) = runIdentity (runValuesspecSafe v pure)+ -- {  -- Boilerplate instance definitions.  Theoretically, these are derivable.@@ -77,7 +176,36 @@   dimap _ g (Valuesspec q) = Valuesspec (rmap g q)  instance ProductProfunctor Valuesspec where-  empty = PP.defaultEmpty-  (***!) = PP.defaultProfunctorProduct+  purePP = pure+  (****) = (<*>)++instance Functor (ValuesspecSafe a) where+  fmap f (ValuesspecSafe g h) = ValuesspecSafe (fmap f g) (fmap f h)++instance Applicative (ValuesspecSafe a) where+  pure a = ValuesspecSafe (pure a) (pure a)+  ValuesspecSafe f f' <*> ValuesspecSafe x x' =+    ValuesspecSafe (f <*> x) (f' <*> x')++instance Profunctor ValuesspecSafe where+  dimap f g (ValuesspecSafe q q') = ValuesspecSafe (rmap g q) (dimap f g q')++instance ProductProfunctor ValuesspecSafe where+  purePP = pure+  (****) = (<*>)++instance Functor (Nullspec a) where+  fmap f (Nullspec g) = Nullspec (fmap f g)++instance Applicative (Nullspec a) where+  pure = Nullspec . pure+  Nullspec f <*> Nullspec x = Nullspec (f <*> x)++instance Profunctor Nullspec where+  dimap f g (Nullspec q) = Nullspec (dimap f g q)++instance ProductProfunctor Nullspec where+  purePP = pure+  (****) = (<*>)  -- }

@@ -1,23 +1,4 @@ -- | Left, right, and full outer joins.------ "Opaleye.FunctionalJoin" provides a much nicer, Haskelly, interface--- to joins than this module, which sticks to the (horrible) standard--- \"make missing rows NULL\" interface that SQL provides.------ If you want inner joins, just use 'restrict' instead.------ The use of the 'D.Default' typeclass means that the compiler will--- have trouble inferring types.  It is strongly recommended that you--- provide full type signatures when using the join functions.------ Example specialization:------ @--- leftJoin :: Select (Field a, Field b)---          -> Select (Field c, FieldNullable d)---          -> (((Field a, Field b), (Field c, FieldNullable d)) -> Field 'Opaleye.SqlTypes.SqlBool')---          -> Select ((Field a, Field b), (FieldNullable c, FieldNullable d))--- @  {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -29,6 +10,7 @@ import qualified Opaleye.Field               as F import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Join as J+import qualified Opaleye.Internal.MaybeFields as M import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Map as Map import qualified Opaleye.Select   as S@@ -36,8 +18,144 @@  import qualified Data.Profunctor.Product.Default as D --- * Joins+-- * The recommended way of performing joins in Opaleye +-- $ref+--+-- Opaleye supports inner joins, left/right joins and full outer+-- joins.  Instead of using them directly we recommend the following,+-- which provide APIs that are more familiar to a Haskell programmer+-- and more composable:+--+-- - Inner joins: use 'Opaleye.Operators.restrict' directly (along+--   with 'Control.Applicative.<*>' or arrow notation)+--+-- - Left/right joins: use 'optionalRestrict'+--+-- - Lateral left/right joins: use 'optional'+--+-- - Full outer joins: use 'Opaleye.FunctionalJoin.fullJoinF' (If you+--   have a real-world use case for full outer joins then we'd love to+--   hear about it. Please [open a new issue on the Opaleye+--   project](http://github.com/tomjaguarpaw/haskell-opaleye/issues/new)+--   and tell us about it.)++-- | Convenient access to left/right join functionality.  Performs a+-- @LEFT JOIN@ under the hood and has behaviour equivalent to the+-- following Haskell function:+--+-- @+-- optionalRestrict :: [a] -> (a -> Bool) -> [Maybe a]+-- optionalRestrict xs p =+--    case filter p xs of []  -> [Nothing]+--                        xs' -> map Just xs'+-- @+--+-- For example,+--+-- @+-- > let l = [1, 10, 100, 1000] :: [Field SqlInt4]+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 100000)) :: IO [Maybe Int]+-- [Nothing]+--+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 15)) :: IO [Maybe Int]+-- [Just 100,Just 1000]+-- @+--+-- See the documentation of 'leftJoin' for how to use+-- 'optionalRestrict' to replace 'leftJoin' (and by symmetry,+-- 'rightJoin').+optionalRestrict :: D.Default U.Unpackspec a a+                 => S.Select a+                 -- ^ Input query+                 -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)+                 -- ^ If any rows of the input query satisfy the+                 -- condition then return them (wrapped in \"Just\").+                 -- If none of them satisfy the condition then return a+                 -- single row of \"Nothing\"+optionalRestrict = J.optionalRestrict++-- | NB Opaleye exports @Opaleye.Table.'Opaleye.Table.optional'@ from+-- the top level.  If you want this @optional@ you will have to import+-- it from this module.+--+-- Convenient access to lateral left/right join+-- functionality. Performs a @LATERAL LEFT JOIN@ under the hood and+-- has behaviour equivalent to the following Haskell function:+--+-- @+-- optional :: [a] -> [Maybe a]+-- optional q = case q of+--     [] -> [Nothing]+--     xs -> map Just xs+-- @+--+-- That is, if @q :: 'SelectArr' i a@ returns no rows, @'optional' q+-- :: 'SelectArr' i ('MaybeFields' a)@ returns exactly one \"Nothing\"+-- row.  Otherwise, @'optional' q@ returns exactly the rows of @q@+-- wrapped in \"Just\".  For example,+--+-- @+-- > let l1 = ["one", "two", "three"] :: [Field SqlText]+-- > 'Opaleye.RunSelect.runSelect' conn ('optional' ('Opaleye.Values.valuesSafe' l1)) :: IO [Maybe String]+-- [Just "one", Just "two", Just "three"]+--+-- > let l2 = [] :: [Field SqlText]+-- > 'Opaleye.RunSelect.runSelect' conn ('optional' ('Opaleye.Values.valuesSafe' l2)) :: IO [Maybe String]+-- [Nothing]+-- @+--+-- 'optionalRestrict' is a special case of @optional@ and could be+-- written in terms of @optional@ as follows (except that+-- 'optionalRestrict' doesn't use @LATERAL@ under the hood and+-- @optional@ does).+--+-- @+-- optionalRestrict q = optional $ proc cond -> do+--   a <- q -< ()+--   restrict -< cond a+--   returnA -< a+-- @+optional :: D.Default U.Unpackspec a a+         => S.SelectArr i a+         -- ^ Input query+         -> S.SelectArr i (M.MaybeFields a)+         -- ^ The rows of the input query wrapped in \"Just\", unless+         -- the input query has no rows in which case a single row of+         -- \"Nothing\"+optional = M.optional++-- * Direct access to joins (not recommended)++-- $ref2+--+-- You probably want use the alternatives listed at the top of this+-- module instead of these.+-- The use of the @'D.Default' 'NullMaker'@ typeclass means that the compiler will+-- have trouble inferring types.  It is strongly recommended that you+-- provide full type signatures when using the join functions.+-- Example specialization:+--+-- @+-- leftJoin :: Select (Field a, Field b)+--          -> Select (Field c, FieldNullable d)+--          -> (((Field a, Field b), (Field c, FieldNullable d)) -> Field 'Opaleye.SqlTypes.SqlBool')+--          -> Select ((Field a, Field b), (FieldNullable c, FieldNullable d))+-- @++-- | We suggest you use 'optionalRestrict' instead.  Instead of writing+-- \"@'Opaleye.Join.leftJoin' qL qR cond@\" you can write+--+-- @+-- proc () -> do+--   fieldsL <- qL -< ()+--   maybeFieldsR \<- 'optionalRestrict' qR -\< 'Prelude.curry' cond fieldsL+--   'Control.Arrow.returnA' -< (fieldsL, maybeFieldsR)+-- @+--+-- Typically everything except the 'optionalRestrict' line can be+-- inlined in surrounding arrow notation.  In such cases, readability+-- and maintainibility increase dramatically. leftJoin  :: (D.Default U.Unpackspec fieldsL fieldsL,               D.Default U.Unpackspec fieldsR fieldsR,               D.Default J.NullMaker fieldsR nullableFieldsR)@@ -47,8 +165,11 @@           -> S.Select (fieldsL, nullableFieldsR) -- ^ Left join leftJoin = leftJoinExplicit D.def D.def D.def --- | 'leftJoinA' is a convenient way of using left joins within arrow--- notation+-- | We suggest you don't use this.  'optionalRestrict' is probably+-- better for your use case.  'Opaleye.Join.leftJoinA' is the same as+-- except 'optionalRestrict' without the return type wrapped in+-- 'Opaleye.Internal.MaybeFields.MaybeFields'.+ leftJoinA :: (D.Default U.Unpackspec fieldsR fieldsR,               D.Default J.NullMaker fieldsR nullableFieldsR)           => S.Select fieldsR@@ -58,6 +179,8 @@           -- result comes out leftJoinA = leftJoinAExplict D.def D.def +-- | We suggest you use 'optionalRestrict' instead.  See 'leftJoin'+-- for more details. rightJoin  :: (D.Default U.Unpackspec fieldsL fieldsL,                D.Default U.Unpackspec fieldsR fieldsR,                D.Default J.NullMaker fieldsL nullableFieldsL)@@ -115,8 +238,22 @@ fullJoinExplicit uA uB nullmakerA nullmakerB =   J.joinExplicit uA uB (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin --- * Inferrable versions+optionalRestrictExplicit :: U.Unpackspec a a+                         -> S.Select a+                         -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)+optionalRestrictExplicit = J.optionalRestrictExplicit +-- The Unpackpec is not used but I'm adding it in case we discover we+-- need it in the future.  Then we can use it without breaking the+-- API.+optionalExplicit :: U.Unpackspec a a+                 -> S.SelectArr i a+                 -> S.SelectArr i (M.MaybeFields a)+optionalExplicit _ = M.optional++-- * Inferrable versions (deprecated)++-- | Do not use.  Will be deprecated in 0.7.  Use 'optionalRestrict' instead. leftJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,                        D.Default U.Unpackspec fieldsR fieldsR,                        D.Default J.NullMaker fieldsR nullableFieldsR,@@ -131,6 +268,8 @@                    -- ^ Left join leftJoinInferrable = leftJoin +-- | Do not use.  Will be deprecated in 0.7.  Use 'optionalRestrict'+-- instead. rightJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,                         D.Default U.Unpackspec fieldsR fieldsR,                         D.Default J.NullMaker fieldsL nullableFieldsL,@@ -146,6 +285,8 @@ rightJoinInferrable = rightJoin  +-- | Do not use.  Will be deprecated in 0.7.  Use+-- 'Opaleye.FunctionalJoin.rightJoinF' instead. fullJoinInferrable  :: (D.Default U.Unpackspec fieldsL fieldsL,                         D.Default U.Unpackspec fieldsR fieldsR,                         D.Default J.NullMaker fieldsL nullableFieldsL,

@@ -5,5 +5,5 @@ import qualified Opaleye.Select            as S  -- | Add a commented label to the generated SQL.-label :: String -> S.Select a -> S.Select a-label l a = Q.simpleQueryArr (L.label' l . Q.runSimpleQueryArr a)+label :: String -> S.SelectArr a b -> S.SelectArr a b+label l a = Q.QueryArr (L.label' l . Q.runQueryArr a)

@@ -0,0 +1,9 @@+module Opaleye.Lateral+  ( lateral+  , viaLateral+  , laterally+  , bilaterally+  )+where++import Opaleye.Internal.Lateral

@@ -170,11 +170,12 @@  -- | Return a function of the inserted or updated rows ----- 'rReturning''s use of the 'D.Default' typeclass means that the+-- 'rReturning''s use of the @'D.Default' 'Opaleye.RunSelect.FromFields'@+-- typeclass means that the -- compiler will have trouble inferring types.  It is strongly -- recommended that you provide full type signatures when using -- 'rReturning'.-rReturning :: D.Default RQ.QueryRunner fields haskells+rReturning :: D.Default RQ.FromFields fields haskells            => (fieldsR -> fields)            -- ^            -> MI.Returning fieldsR [haskells]@@ -182,7 +183,7 @@  -- | Return a function of the inserted or updated rows.  Explicit -- version.  You probably just want to use 'rReturning' instead.-rReturningExplicit :: RQ.QueryRunner fields haskells+rReturningExplicit :: RQ.FromFields fields haskells                    -- ^                    -> (fieldsR -> fields)                    -- ^@@ -324,7 +325,7 @@   show . Print.ppUpdateReturning .::. arrangeUpdateReturning  -- | Insert rows into a table with @ON CONFLICT DO NOTHING@-{-# DEPRECATED runInsertManyOnConflictDoNothing "Use runInsert_" #-}+{-# DEPRECATED runInsertManyOnConflictDoNothing "Use 'runInsert_'.  Will be removed in version 0.8." #-} runInsertManyOnConflictDoNothing :: PGS.Connection                                  -- ^                                  -> T.Table columns columns'@@ -347,7 +348,7 @@ -- 'D.Default' typeclass means that the compiler will have trouble -- inferring types.  It is strongly recommended that you provide full -- type signatures when using it.-{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use runInsert_" #-}+{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-} runInsertManyReturningOnConflictDoNothing   :: (D.Default RQ.QueryRunner columnsReturned haskells)   => PGS.Connection

@@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +-- | Do not use. This module will be deprecated in 0.7.+ module Opaleye.Map where  type family Map f x

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}++-- | 'MaybeFields' is Opaleye's analogue to 'Data.Maybe.Maybe'.  You+-- probably won't want to create values of type 'MaybeFields'+-- directly; instead they will appear as the result of+-- left\/right\/outer join-like operations, such as+-- 'Opaleye.Join.optionalRestrict' and 'Opaleye.Join.optional'.++module Opaleye.MaybeFields (+  MaybeFields,+  nothingFields,+  justFields,+  fromMaybeFields,+  maybeFields,+  maybeFieldsToSelect,+  nothingFieldsOfTypeOf,+  catMaybeFields,+  Opaleye.Join.optional,+  Opaleye.MaybeFields.traverseMaybeFields,+  -- * Adaptors+  Nullspec,+  nullspecField,+  nullspecMaybeFields,+  nullspecList,+  nullspecEitherLeft,+  nullspecEitherRight,+  binaryspecMaybeFields,+  distinctspecMaybeFields,+  fromFieldsMaybeFields,+  toFieldsMaybeFields,+  unpackspecMaybeFields,+  valuesspecMaybeFields,+  -- * Explicit versions+  nothingFieldsExplicit,+  fromMaybeFieldsExplicit,+  maybeFieldsExplicit,+  Opaleye.Join.optionalExplicit,+  traverseMaybeFieldsExplicit,+  ) where++import Opaleye.Internal.Distinct+import Opaleye.Internal.MaybeFields+import Opaleye.Internal.Values+import Opaleye.Join+import Opaleye.Internal.Unpackspec+import Opaleye.Select++import Data.Profunctor.Product.Default++-- | 'traverseMaybeFields' is analogous to Haskell's+-- @'Data.Traversable.traverse' :: (a -> [b]) -> 'Data.Maybe.Maybe' a+-- -> ['Data.Maybe.Maybe' b]@.  In particular,+-- 'Data.Traversable.traverse' has the following definition that+-- generalises to 'traverseMaybeFields':+--+-- * @traverse _ Nothing = pure Nothing@+-- * @traverse f (Just x) = fmap Just (f x)@+traverseMaybeFields :: (Default Unpackspec a a, Default Unpackspec b b)+                    => SelectArr a b+                    -- ^+                    -> SelectArr (MaybeFields a) (MaybeFields b)+                    -- ^+traverseMaybeFields = Opaleye.Internal.MaybeFields.traverseMaybeFields++-- The Unpackspecs are currently redundant, but I'm adding them in+-- case they become necessary in the future.  Then we can use them+-- without breaking the API.+traverseMaybeFieldsExplicit :: Unpackspec a a+                            -> Unpackspec b b+                            -> SelectArr a b+                            -> SelectArr (MaybeFields a) (MaybeFields b)+traverseMaybeFieldsExplicit _ _ =+  Opaleye.Internal.MaybeFields.traverseMaybeFields

@@ -26,7 +26,7 @@  import qualified Opaleye.Column   as Column import qualified Opaleye.Distinct as Distinct-import qualified Opaleye.Join     as Join+import qualified Opaleye.Join as Join  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ @@ -48,8 +48,7 @@ 'Control.Applicative.Alternative' it may help you to know that 'restrict' corresponds to the 'Control.Monad.guard' function.) -} restrict :: S.SelectArr (F.Field T.SqlBool) ()-restrict = QueryArr f where-  f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)+restrict = O.restrict  {-| Add a @WHERE EXISTS@ clause to the current query. -} restrictExists :: S.SelectArr a b -> S.SelectArr a ()@@ -159,7 +158,7 @@  -- | Boolean or (.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool-(.||) = C.binOp HPQ.OpOr+(.||) = (O..||)  infixr 3 .&& @@ -169,7 +168,7 @@  -- | Boolean not not :: F.Field T.SqlBool -> F.Field T.SqlBool-not = C.unOp HPQ.OpNot+not = O.not  -- | True when any element of the container is true ors :: F.Foldable f => f (F.Field T.SqlBool) -> F.Field T.SqlBool@@ -218,9 +217,9 @@ -- This operation is equivalent to Postgres's @IN@ operator but, for -- expediency, is currently implemented using a @LEFT JOIN@.  Please -- file a bug if this causes any issues in practice.-inQuery :: D.Default O.EqPP fields fields-        => fields -> Query fields -> S.Select (F.Field T.SqlBool)-inQuery c q = qj'+inSelect :: D.Default O.EqPP fields fields+         => fields -> S.Select fields -> S.Select (F.Field T.SqlBool)+inSelect c q = qj'   where -- Remove every row that isn't equal to c         -- Replace the ones that are with '1'         q' = A.arr (const 1)@@ -412,3 +411,8 @@ -- | Identical to 'restrictNotExists'.  Will be deprecated in version 0.7. notExists :: QueryArr a b -> QueryArr a () notExists = restrictNotExists++-- | Identical to 'inSelect'.  Will be deprecated in version 0.7.+inQuery :: D.Default O.EqPP fields fields+        => fields -> Query fields -> S.Select (F.Field T.SqlBool)+inQuery = inSelect

@@ -2,7 +2,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} --- | Ordering, @LIMIT@, @OFFSET@ and @DISTINCT ON@+-- | @ORDER BY@, @LIMIT@, @OFFSET@ and @DISTINCT ON@  module Opaleye.Order ( -- * Order by                        orderBy@@ -52,7 +52,7 @@ -} orderBy :: O.Order a -> S.Select a -> S.Select a orderBy os q =-  Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q)+  Q.productQueryArr (O.orderByU os . Q.runSimpleQueryArr q)  -- | Specify an ascending ordering by the given expression. --   (Any NULLs appear last)@@ -82,18 +82,18 @@ -- * Limit and offset  {- |-Limit the results of the given query to the given maximum number of+Limit the results of the given 'S.Select' to the given maximum number of items.  /WARNING:/ If you're planning on using limit/offset together please use 'offset' /before/ you use 'limit', e.g.:  @-limit 10 (offset 50 yourQuery)+limit 10 (offset 50 yourSelect) @ -This is because Opaleye applies OFFSET and LIMIT to the query separately.-The result of the query given above is the following, which will return+This is because Opaleye applies @OFFSET@ and @LIMIT@ to the @SELECT@ separately.+The result of the 'S.Select' given above is the following, which will return 10 rows after skipping the first 50 (probably what you want).  @@@ -109,26 +109,26 @@ @ -} limit :: Int -> S.Select a -> S.Select a-limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a)+limit n a = Q.productQueryArr (O.limit' n . Q.runSimpleQueryArr a)  {- |-Offset the results of the given query by the given amount, skipping+Offset the results of the given 'S.Select' by the given amount, skipping that many result rows.  /WARNING:/ Please read the documentation of 'limit' before combining 'offset' with 'limit'. -} offset :: Int -> S.Select a -> S.Select a-offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)+offset n a = Q.productQueryArr (O.offset' n . Q.runSimpleQueryArr a)  -- * Distinct on  -- | Keep a row from each set where the given function returns the same result. No---   ordering is guaranteed. Mutliple fields may be distinguished by projecting out+--   ordering is guaranteed. Multiple fields may be distinguished by projecting out --   tuples of 'Opaleye.Field.Field_'s. Use 'distinctOnBy' to control how the rows --   are chosen. distinctOn :: D.Default U.Unpackspec b b => (a -> b) -> S.Select a -> S.Select a-distinctOn proj q = Q.simpleQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)+distinctOn proj q = Q.productQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)   -- | Keep the row from each set where the given function returns the same result. The@@ -137,7 +137,7 @@ --   out tuples of 'Opaleye.Field.Field_'s. distinctOnBy :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a              -> S.Select a -> S.Select a-distinctOnBy proj ord q = Q.simpleQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)+distinctOnBy proj ord q = Q.productQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)   -- * Other

@@ -110,7 +110,8 @@ pgCiLazyText :: CI.CI LText.Text -> Column PGCitext pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original --- No CI String instance since postgresql-simple doesn't define FromField (CI String)+-- No CI String instance since postgresql-simple doesn't define+-- FromField (CI String)  -- The json data type was introduced in PostgreSQL version 9.2 -- JSON values must be SQL string quoted@@ -143,15 +144,19 @@ pgValueJSONB :: Ae.ToJSON a => a -> Column PGJsonb pgValueJSONB = pgLazyJSONB . Ae.encode -pgArray :: forall a b. IsSqlType b => (a -> C.Column b) -> [a] -> C.Column (PGArray b)+pgArray :: forall a b. IsSqlType b+        => (a -> C.Column b) -> [a] -> C.Column (PGArray b) pgArray pgEl xs = C.unsafeCast arrayTy $   C.Column (HPQ.ArrayExpr (map oneEl xs))   where     oneEl = C.unColumn . pgEl     arrayTy = showSqlType ([] :: [PGArray b]) -pgRange :: forall a b. IsRangeType b => (a -> C.Column b) -> R.RangeBound a -> R.RangeBound a -> C.Column (PGRange b)-pgRange pgEl start end = C.Column (HPQ.RangeExpr (showRangeType ([] :: [b])) (oneEl start) (oneEl end))+pgRange :: forall a b. IsRangeType b+        => (a -> C.Column b) -> R.RangeBound a -> R.RangeBound a+        -> C.Column (PGRange b)+pgRange pgEl start end =+  C.Column (HPQ.RangeExpr (showRangeType ([] :: [b])) (oneEl start) (oneEl end))   where oneEl (R.Inclusive a) = HPQ.Inclusive . C.unColumn $ pgEl a         oneEl (R.Exclusive a) = HPQ.Exclusive . C.unColumn $ pgEl a         oneEl R.NegInfinity   = HPQ.NegInfinity

@@ -7,7 +7,12 @@    -- * Datatypes    IRQ.Cursor,    IRQ.FromFields,-   IRQ.FromField) where+   IRQ.FromField,+   IRQ.DefaultFromField,+   IRQ.defaultFromField,+   -- * Helper functions+   IRQ.fromPGSFromField,+   IRQ.fromPGSFieldParser) where  import qualified Data.Profunctor            as P import qualified Database.PostgreSQL.Simple as PGS@@ -23,7 +28,8 @@  -- * Running 'S.Select's --- | @runSelect@'s use of the 'D.Default' typeclass means that the+-- | @runSelect@'s use of the @'D.Default' 'FromFields'@+-- typeclass means that the -- compiler will have trouble inferring types.  It is strongly -- recommended that you provide full type signatures when using -- @runSelect@.@@ -80,8 +86,6 @@  -- | Declare a temporary cursor. The cursor is given a unique name for the given -- connection.------ Returns 'Nothing' when the query returns zero rows. declareCursor     :: D.Default FromFields fields haskells     => PGS.Connection

@@ -5,18 +5,6 @@ -- 'SelectArr' is a parametrised version of 'Select', i.e. it can be -- passed arguments. -module Opaleye.Select where--import qualified Opaleye.QueryArr as Q---- | A @SELECT@, i.e. an SQL query which produces a collection of--- rows.------ @Select a@ is analogous to a Haskell value @[a]@.-type Select = SelectArr ()+module Opaleye.Select (Select, SelectArr) where --- | A parametrised 'Select'.  A @SelectArr a b@ accepts an argument--- of type @a@.------ @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.-type SelectArr = Q.QueryArr+import Opaleye.Internal.QueryArr

@@ -19,9 +19,9 @@  -- * Showing SQL --- | Show the SQL query string generated from the query.+-- | Show the SQL query string generated from the 'S.Select'. ----- When 'Nothing' is returned it means that the 'Query' returns zero+-- When 'Nothing' is returned it means that the 'S.Select' returns zero -- rows. -- -- Example type specialization:@@ -42,7 +42,7 @@         -> Maybe String showSql = showSqlExplicit (D.def :: U.Unpackspec fields fields) --- | Show the unoptimized SQL query string generated from the query.+-- | Show the unoptimized SQL query string generated from the 'S.Select'. showSqlUnopt :: forall fields.                 D.Default U.Unpackspec fields fields              => S.Select fields

@@ -1,5 +1,5 @@ -- | SQL types and functions to create 'Opaleye.Field.Field_'s of--- those types.  You may find it more convenient to use+-- those types.  To create fields you may find it more convenient to use -- "Opaleye.ToFields" instead.  module Opaleye.SqlTypes (module Opaleye.SqlTypes,

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}   {- |@@ -66,15 +65,18 @@                       tableWithSchema,                       T.Table,                       T.tableField,-                      T.optional,-                      T.readOnly,-                      T.required,-                      -- * Querying tables+                      T.optionalTableField,+                      T.readOnlyTableField,+                      T.requiredTableField,+                      -- * Selecting from tables                       selectTable,                       -- * Other                       T.TableColumns,                       TableFields,                       -- * Deprecated+                      T.optional,+                      T.readOnly,+                      T.required,                       T.tableColumn,                       View,                       Writer,@@ -137,7 +139,7 @@                     -> Table a tablefields                     -- ^                     -> S.Select fields-selectTableExplicit cm table' = Q.simpleQueryArr f where+selectTableExplicit cm table' = Q.productQueryArr f where   f ((), t0) = (retwires, primQ, Tag.next t0) where     (retwires, primQ) = T.queryTable cm table' t0 

@@ -1,6 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} -module Opaleye.Values where+module Opaleye.Values(+  valuesSafe,+  -- * Explicit versions+  valuesExplicit,+  valuesSafeExplicit,+  valuesUnsafeExplicit,+  -- * Adaptors+  V.ValuesspecSafe,+  V.valuesspecField,+  -- * Deprecated versions+  values,+  valuesUnsafe,+  ) where  import qualified Opaleye.Internal.QueryArr as Q import           Opaleye.Internal.Values as V@@ -9,28 +21,55 @@  import           Data.Profunctor.Product.Default (Default, def) --- | 'values' implements Postgres's @VALUES@ construct and allows you--- to create a query that consists of the given rows.+-- | Please note that 'values' of an empty list generates incorrect+-- queries when mixed with @OUTER@\/@LEFT@\/@RIGHT JOIN@.  You should+-- use 'valuesSafe' instead.  'valuesSafe' will replace 'values' in+-- version 0.7.+values :: (Default V.Valuesspec fields fields,+           Default U.Unpackspec fields fields) =>+          [fields] -> S.Select fields+values = valuesExplicit def def++valuesExplicit :: U.Unpackspec fields fields'+               -> V.Valuesspec fields fields'+               -> [fields] -> S.Select fields'+valuesExplicit unpack valuesspec fields =+  Q.productQueryArr (V.valuesU unpack valuesspec fields)++-- | 'valuesSafe' implements Postgres's @VALUES@ construct and allows you+-- to create a @SELECT@ that consists of the given rows. -- -- Example type specialization: -- -- @--- values :: [(Field a, Field b)] -> Select (Field a, Field b)+-- valuesSafe :: [(Field a, Field b)] -> Select (Field a, Field b) -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the -- product type @Foo@: -- -- @--- selectTable :: [Foo (Field a) (Field b) (Field c)] -> S.Select (Foo (Field a) (Field b) (Field c))+-- valuesSafe :: [Foo (Field a) (Field b) (Field c)] -> S.Select (Foo (Field a) (Field b) (Field c)) -- @-values :: (Default V.Valuesspec fields fields,-           Default U.Unpackspec fields fields) =>-          [fields] -> S.Select fields-values = valuesExplicit def def+valuesSafe :: Default V.ValuesspecSafe fields fields =>+               [fields] -> S.Select fields+valuesSafe = valuesSafeExplicit def -valuesExplicit :: U.Unpackspec fields fields'-               -> V.Valuesspec fields fields'-               -> [fields] -> S.Select fields'-valuesExplicit unpack valuesspec fields =-  Q.simpleQueryArr (V.valuesU unpack valuesspec fields)+valuesSafeExplicit :: V.ValuesspecSafe fields fields'+                   -> [fields] -> S.Select fields'+valuesSafeExplicit valuesspec fields =+  Q.productQueryArr (V.valuesUSafe valuesspec fields)++-- | Forward-compatible version of unsafe 'values' that will not be+-- deprecated in 0.7, but in 0.8.+valuesUnsafe :: (Default V.Valuesspec fields fields,+                 Default U.Unpackspec fields fields) =>+                [fields] -> S.Select fields+valuesUnsafe = values++-- | Forward compatible version of unsafe 'valuesExplicit' that will+-- not be deprecated in 0.7, but in 0.8.+valuesUnsafeExplicit :: U.Unpackspec fields fields'+                     -> V.Valuesspec fields fields'+                     -> [fields] -> S.Select fields'+valuesUnsafeExplicit = valuesExplicit