opaleye 0.6.7005.0 → 0.6.7006.0

raw patch · 32 files changed

+889/−444 lines, 32 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• Doc/Tutorial/DefaultExplanation.lhs +17/−17
• Doc/Tutorial/TutorialAdvanced.lhs +2/−2
• Doc/Tutorial/TutorialBasic.lhs +67/−73
• Doc/Tutorial/TutorialBasicMonomorphic.lhs +2/−2
• Doc/Tutorial/TutorialBasicTypeFamilies.lhs +2/−2
• Doc/Tutorial/TutorialManipulation.lhs +5/−5
• Doc/UPGRADING.md +0/−104
• TODO.md +0/−24
• Test/Opaleye/Test/Arbitrary.hs +51/−3
• Test/Opaleye/Test/Fields.hs +9/−0
• Test/Opaleye/Test/TraverseA.hs +40/−0
• Test/QuickCheck.hs +289/−190
• Test/Test.hs +8/−0
• opaleye.cabal +5/−3
• src/Opaleye/Constant.hs +3/−0
• src/Opaleye/Internal/Inferrable.hs +258/−0
• src/Opaleye/Internal/Locking.hs +25/−0
• src/Opaleye/Internal/MaybeFields.hs +21/−5
• src/Opaleye/Internal/Optimize.hs +1/−0
• src/Opaleye/Internal/PrimQuery.hs +8/−0
• src/Opaleye/Internal/Print.hs +5/−0
• src/Opaleye/Internal/QueryArr.hs +2/−0
• src/Opaleye/Internal/RunQuery.hs +7/−2
• src/Opaleye/Internal/Sql.hs +12/−2
• src/Opaleye/Internal/Values.hs +2/−0
• src/Opaleye/Join.hs +1/−1
• src/Opaleye/Operators.hs +1/−1
• src/Opaleye/RunSelect.hs +10/−0
• src/Opaleye/Table.hs +5/−5
• src/Opaleye/ToFields.hs +16/−1
• src/Opaleye/Values.hs +2/−2

@@ -1,4 +1,17 @@+## 0.6.7006.0++* Added `Opaleye.RunSelect.runSelectI` and+  `Opaleye.ToFields.toFieldsI` which have better inferability.++* Preliminary `FOR UPDATE` support in `Opaleye.Internal.Locking`.++* Added `fromFieldArray` for making `FromField`s for arrays.+ ## 0.6.7005.0++* Thanks to Shane (@duairc) and Ollie Charles (@ocharles) for writing+  most of the `lateral`- and `MaybeFields`-related code in this+  release.  * Add a `Monad` instance for `Select` (and `SelectArr i`). 

@@ -4,8 +4,8 @@ > import Opaleye (Field, FieldNullable, FromFields, Select, >                 SqlInt4, SqlBool, SqlText, SqlFloat4) > import qualified Opaleye as O-> import qualified Opaleye.Internal.Binary as Internal.Binary-> import Opaleye.Internal.Binary (Binaryspec)+> import qualified Opaleye.Adaptors as Adaptors+> import Opaleye.Adaptors (Binaryspec) > > import Data.Profunctor.Product ((***!), p4) > import Data.Profunctor.Product.Default (Default, def)@@ -63,30 +63,30 @@  So the next question is, how do we get our hands on a value of that type?  Well, we have `binaryspecField` which is a value that allows-us to access the column name within a single column.+us to access the field name within a single field. -> binaryspecColumn :: Binaryspec (Field a) (Field a)-> binaryspecColumn = Internal.Binary.binaryspecColumn+> binaryspecField :: Binaryspec (Field a) (Field a)+> binaryspecField = Adaptors.binaryspecField  `Binaryspec` is a `ProductProfunctor` so we can combine two of them to work on a pair. -> binaryspecColumn2 :: Binaryspec (Field a, Field b) (Field a, Field b)-> binaryspecColumn2 = binaryspecColumn ***! binaryspecColumn+> binaryspecField2 :: Binaryspec (Field a, Field b) (Field a, Field b)+> binaryspecField2 = binaryspecField ***! binaryspecField -Then we can use `binaryspecColumn2` in `unionAllExplicit`.+Then we can use `binaryspecField2` in `unionAllExplicit`.  > theUnionAll :: Select (Field SqlInt4, Field SqlText)-> theUnionAll = unionAllExplicit binaryspecColumn2 mySelect1 mySelect2+> theUnionAll = unionAllExplicit binaryspecField2 mySelect1 mySelect2 -Now suppose that we wanted to take a union of two queries with columns+Now suppose that we wanted to take a union of two queries with fields in a tuple of size four.  We can make a suitable `Binaryspec` like this: -> binaryspecColumn4 :: Binaryspec (Field a, Field b, Field c, Field d)+> binaryspecField4 :: Binaryspec (Field a, Field b, Field c, Field d) >                                 (Field a, Field b, Field c, Field d)-> binaryspecColumn4 = p4 (binaryspecColumn, binaryspecColumn,->                         binaryspecColumn, binaryspecColumn)+> binaryspecField4 = p4 (binaryspecField, binaryspecField,+>                        binaryspecField, binaryspecField)  Then we can pass this `Binaryspec` to `unionAllExplicit`. @@ -101,7 +101,7 @@ `Opaleye.Internal.Binary` contains the `Default` instance      instance Default Binaryspec (Field a) (Field a) where-      def = binaryspecColumn+      def = binaryspecField  That means that we know the "default" way of getting a @@ -168,7 +168,7 @@ > nullableIntRunner :: FromFields (FieldNullable SqlInt4) (Maybe Int) > nullableIntRunner = undefined -If I have a very simple query with a single column of `SqlInt4` then I can+If I have a very simple select with a single field of `SqlInt4` then I can run it using the `intRunner`.  > mySelect3 :: Select (Field SqlInt4)@@ -177,7 +177,7 @@ > runTheSelect :: SQL.Connection -> IO [Int] > runTheSelect c = runSelectExplicit intRunner c mySelect3 -If my query has several columns of different types I need to build up+If my select has several fields of different types I need to build up a larger `FromFields`.  > mySelect4 :: Select (Field SqlInt4, Field SqlText, Field SqlBool, FieldNullable SqlInt4)@@ -210,7 +210,7 @@ > largerSelectRunner' = def  And we can produce a version of `runSelect` which allows us to write-our query without explicitly passing the product-profunctor value.+our select without explicitly passing the product-profunctor value.  > runSelect :: Default FromFields a b => SQL.Connection -> Select a -> IO [b] > runSelect = O.runSelectExplicit def

@@ -27,7 +27,7 @@  We can define an aggregator to calculate the range of a group, that is the difference between its maximum and minimum.  Although we can write-this easily in SQL as `MAX(column) - MIN(column)`, Opaleye has the+this easily in SQL as `MAX(field) - MIN(field)`, Opaleye has the advantage of treating `range` as a first-class value able to be passed around between functions and manipulated at will. @@ -72,4 +72,4 @@ ===============  > printSql :: Default U.Unpackspec a a => Select a -> IO ()-> printSql = putStrLn . maybe "Empty query" id . Sql.showSql+> printSql = putStrLn . maybe "Empty select" id . Sql.showSql

@@ -1,4 +1,3 @@-> {-# LANGUAGE Arrows #-} > {-# LANGUAGE FlexibleContexts #-} > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-}@@ -10,11 +9,11 @@ > > import           Opaleye (Field, FieldNullable, matchNullable, isNull, >                          Table, table, tableField, selectTable,->                          Select, SelectArr, restrict, (.==), (.<=), (.&&), (.<),+>                          Select, restrict, (.==), (.<=), (.&&), (.<), >                          (.===), >                          (.++), ifThenElse, sqlString, aggregate, groupBy, >                          count, avg, sum, leftJoin, runSelect,->                          showSql, Unpackspec,+>                          showSql, viaLateral, Unpackspec, >                          SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8, SqlBool) > > import           Data.Profunctor.Product (p2, p3)@@ -22,8 +21,6 @@ > import           Data.Profunctor.Product.TH (makeAdaptorAndInstance) > import           Data.Time.Calendar (Day) >-> import           Control.Arrow (returnA)-> > import qualified Database.PostgreSQL.Simple as PGS  Introduction@@ -69,7 +66,7 @@ default `"public"` schema. If we wanted to specify a different schema we could have used the `tableWithSchema` function instead of `table`. -To query a table we use `selectTable`.+To select all rows of a table we use `selectTable`.  (Here and in a few other places in Opaleye there is some typeclass magic going on behind the scenes to reduce boilerplate.  However, you@@ -167,24 +164,21 @@ Projection ========== -"Projection" means discarding some of the fields of our query, for+"Projection" means discarding some of the fields of our select, for example we might want to discard the "address" field of our `personSelect`. -Projection gives us our first example of using "arrow notation" to-write Opaleye queries.  Arrow notation is essentially a restricted-version of "do notation".  Arrow notation allows you to write arrow-computations, and do notation allows you to write monadic-computations.+Projection gives us our first example of using "do notation" to+write Opaleye queries.  Here we run the `personSelect` passing in () to signify "zero arguments".  We pattern match on the results and return only the fields we are interested in.  > nameAge :: Select (Field SqlText, Field SqlInt4)-> nameAge = proc () -> do->   (name, age, _) <- personSelect -< ()->   returnA -< (name, age)+> nameAge = do+>   (name, age, _) <- personSelect+>   pure (name, age)  ghci> printSql nameAge SELECT name0_1 as result1,@@ -205,16 +199,16 @@ =======  "Product" means taking the Cartesian product of two queries.  This is-simple in arrow notation.  Here we take the product of `personSelect`+simple in do notation.  Here we take the product of `personSelect` and `birthdaySelect`.  > personBirthdayProduct :: >   Select ((Field SqlText, Field SqlInt4, Field SqlText), BirthdayField)-> personBirthdayProduct = proc () -> do->   personRow   <- personSelect -< ()->   birthdayRow <- birthdaySelect -< ()+> personBirthdayProduct = do+>   personRow   <- personSelect+>   birthdayRow <- birthdaySelect >->   returnA -< (personRow, birthdayRow)+>   pure (personRow, birthdayRow)  ghci> printSql personBirthdayProduct SELECT name0_1 as result1,@@ -250,18 +244,18 @@ Restriction =========== -"Restriction" means restricting the rows of the result of a query to+"Restriction" means restricting the rows of the result of a select to only those where some condition holds.  We can restrict `personSelect` to the rows where the person is up to 18 years old.  > youngPeople :: Select (Field SqlText, Field SqlInt4, Field SqlText)-> youngPeople = proc () -> do->   row@(_, age, _) <- personSelect -< ()->   restrict -< age .<= 18+> youngPeople = do+>   row@(_, age, _) <- personSelect+>   viaLateral restrict (age .<= 18) >->   returnA -< row+>   pure row  ghci> printSql youngPeople SELECT name0_1 as result1,@@ -287,13 +281,13 @@ conditions.  > twentiesAtAddress :: Select (Field SqlText, Field SqlInt4, Field SqlText)-> twentiesAtAddress = proc () -> do->   row@(_, age, address) <- personSelect -< ()+> twentiesAtAddress = do+>   row@(_, age, address) <- personSelect >->   restrict -< (20 .<= age) .&& (age .< 30)->   restrict -< address .== sqlString "1 My Street, My Town"+>   viaLateral restrict $ (20 .<= age) .&& (age .< 30)+>   viaLateral restrict $ address .== sqlString "1 My Street, My Town" >->   returnA -< row+>   pure row  ghci> printSql twentiesAtAddress @@ -323,18 +317,18 @@ ----------  A Product followed by a restriction is sometimes called a "join" or-"inner join" in SQL terminology.  The following query is an example of+"inner join" in SQL terminology.  The following select is an example of such.  > personAndBirthday :: >   Select (Field SqlText, Field SqlInt4, Field SqlText, Field SqlDate)-> personAndBirthday = proc () -> do->   (name, age, address) <- personSelect -< ()->   birthday             <- birthdaySelect -< ()+> personAndBirthday = do+>   (name, age, address) <- personSelect+>   birthday             <- birthdaySelect >->   restrict -< name .== bdName birthday+>   viaLateral restrict $ name .== bdName birthday >->   returnA -< (name, age, address, bdDay birthday)+>   pure (name, age, address, bdDay birthday)   ghci> printSql personAndBirthday@@ -385,16 +379,16 @@ > employeeTable = table "employeeTable" (p2 ( tableField "name" >                                           , tableField "boss" )) -We can write a query that returns as string indicating for each+We can write a select that returns as string indicating for each employee whether they have a boss.  > hasBoss :: Select (Field SqlText)-> hasBoss = proc () -> do->   (name, nullableBoss) <- selectTable employeeTable -< ()+> hasBoss = do+>   (name, nullableBoss) <- selectTable employeeTable > >   let aOrNo = ifThenElse (isNull nullableBoss) (sqlString "no") (sqlString "a") >->   returnA -< name .++ sqlString " has " .++ aOrNo .++ sqlString " boss"+>   pure $ name .++ sqlString " has " .++ aOrNo .++ sqlString " boss"  ghci> printSql hasBoss @@ -413,18 +407,18 @@ FROM employeeTable  But we can do much more than just check for NULL of course.  We can-write a query arrow to produce a string describing each employee's+write a select to produce a string describing each employee's status along with the name of their boss, if any.  The combinator `matchNullable` checks whether `nullableBoss` is NULL.  If so it returns its first argument.  If not it passes the non-NULL value to the function that is the second argument. -> bossSelect :: SelectArr (Field SqlText, FieldNullable SqlText) (Field SqlText)-> bossSelect = proc (name, nullableBoss) -> do->   returnA -< matchNullable (name .++ sqlString " has no boss")->                            (\boss -> sqlString "The boss of " .++ name->                                      .++ sqlString " is " .++ boss)->                            nullableBoss+> bossSelect :: (Field SqlText, FieldNullable SqlText) -> Select (Field SqlText)+> bossSelect (name, nullableBoss) = do+>   pure $ matchNullable (name .++ sqlString " has no boss")+>                        (\boss -> sqlString "The boss of " .++ name+>                                  .++ sqlString " is " .++ boss)+>                        nullableBoss  Note that `matchNullable` corresponds to Haskell's @@ -464,7 +458,7 @@ Rewriting `twentiesAtAddress` will allow us to get our first glimpse of the enormous composability that Opaleye offers. -We can factor out some parts of the 'twentiesAtAddress' query.  For+We can factor out some parts of the 'twentiesAtAddress' select.  For example we can pull out the restriction to one's age being "in the twenties" and the restriction to the one's address being "1 My Street, My Town".@@ -474,13 +468,13 @@ just a synonym for `SelectArr ()` which means that it is a `SelectArr` that does not read any fields.) -> restrictIsTwenties :: SelectArr (Field SqlInt4) ()-> restrictIsTwenties = proc age -> do->   restrict -< (20 .<= age) .&& (age .< 30)+> restrictIsTwenties :: Field SqlInt4 -> Select ()+> restrictIsTwenties age = do+>   viaLateral restrict $ (20 .<= age) .&& (age .< 30) >-> restrictAddressIs1MyStreet :: SelectArr (Field SqlText) ()-> restrictAddressIs1MyStreet = proc address -> do->   restrict -< address .== sqlString "1 My Street, My Town"+> restrictAddressIs1MyStreet :: Field SqlText -> Select ()+> restrictAddressIs1MyStreet address = do+>   viaLateral restrict $ address .== sqlString "1 My Street, My Town"  We can't generate "the SQL of" these combinators.  They are not `Select`s so they don't have any SQL!  (This corresponds to the@@ -489,13 +483,13 @@ `twentiesAtAddress` in a more neatly-factored way.  > twentiesAtAddress' :: Select (Field SqlText, Field SqlInt4, Field SqlText)-> twentiesAtAddress' = proc () -> do->   row@(_, age, address) <- personSelect -< ()+> twentiesAtAddress' = do+>   row@(_, age, address) <- personSelect >->   restrictIsTwenties -< age->   restrictAddressIs1MyStreet -< address+>   restrictIsTwenties age+>   restrictAddressIs1MyStreet address >->   returnA -< row+>   pure row  The SQL generated is exactly the same as before @@ -519,23 +513,23 @@ pulling out a `SelectArr` which perform the mapping of a person's name to their date of birth by looking up in `birthdaySelect`. -> birthdayOfPerson :: SelectArr (Field SqlText) (Field SqlDate)-> birthdayOfPerson = proc name -> do->   birthday <- birthdaySelect -< ()+> birthdayOfPerson :: Field SqlText -> Select (Field SqlDate)+> birthdayOfPerson name = do+>   birthday <- birthdaySelect >->   restrict -< name .== bdName birthday+>   viaLateral restrict $ name .== bdName birthday >->   returnA -< bdDay birthday+>   pure (bdDay birthday)  We can then reimplement `personAndBirthday` as follows  > personAndBirthday' :: >   Select (Field SqlText, Field SqlInt4, Field SqlText, Field SqlDate)-> personAndBirthday' = proc () -> do->   (name, age, address) <- personSelect -< ()->   birthday <- birthdayOfPerson -< name+> personAndBirthday' = do+>   (name, age, address) <- personSelect+>   birthday <- birthdayOfPerson name >->   returnA -< (name, age, address, birthday)+>   pure (name, age, address, birthday)  and it yields the same SQL as before. @@ -814,7 +808,7 @@ typeclasses so please put type signatures on everything in sight to minimize the number of confusing error messages! -For example, for the 'twentiesAtAddress' query `runSelect` would have+For example, for the 'twentiesAtAddress' select `runSelect` would have the following type:  > runTwentiesSelect :: PGS.Connection@@ -825,7 +819,7 @@ Note that nullable fields are indicated with the FieldNullable type constructor, and these are converted to Maybe when executed.  If we have a table with a nullable field then FieldNullables turn into-Maybes.  We could run the query `selectTable employeeTable` like this.+Maybes.  We could run the select `selectTable employeeTable` like this.  > runEmployeesSelect :: PGS.Connection >                   -> Select (Field SqlText, FieldNullable SqlText)@@ -834,8 +828,8 @@  Newtypes are taken care of automatically by the typeclass instance that was generated by `makeAdaptorAndInstance`.  A `WarehouseId'-(Field SqlInt4)` becomes a `WarehouseId' Int` when the query is run.-We could run the query `selectTable goodWarehouseTable` like this.+(Field SqlInt4)` becomes a `WarehouseId' Int` when the select is run.+We could run the select `selectTable goodWarehouseTable` like this.  > type WarehouseId = WarehouseId' Int > type GoodWarehouse = Warehouse' WarehouseId String Int@@ -857,4 +851,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 . showSql+> printSql = putStrLn . maybe "Empty select" id . showSql

@@ -77,7 +77,7 @@ default `"public"` schema. If we wanted to specify a different schema we could have used the `tableWithSchema` constructor instead of `table`. -To query a table we use `selectTable`.+To select from a table we use `selectTable`.  (Here and in a few other places in Opaleye there is some typeclass magic going on behind the scenes to reduce boilerplate.  However, you@@ -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 . showSql+> printSql = putStrLn . maybe "Empty select" id . showSql

@@ -77,7 +77,7 @@ default `"public"` schema. If we wanted to specify a different schema we could have used the `tableWithSchema` function instead of `table`. -To query a table we use `selectTable`.+To select from a table we use `selectTable`.  (Here and in a few other places in Opaleye there is some typeclass magic going on behind the scenes to reduce boilerplate.  However, you@@ -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 . showSql+> printSql = putStrLn . maybe "Empty select" id . showSql

@@ -26,11 +26,11 @@ DELETE, INSERT and UPDATE.  To demonstrate manipulation in Opaleye we will need a table to perform-our manipulation on.  It will have four columns: an int4-valued "id"-column (assumed to be an auto-incrementing field) and three+our manipulation on.  It will have four fields: an int4-valued "id"+field (assumed to be an auto-incrementing field) and three float8-valued required fields.  The `Table` type constructor has two type arguments.  The first one is the type of writes to the table, and-the second is the type of reads from the table.  The "id" column is+the second is the type of reads from the table.  The "id" field is defined as optional (for writes) because its write type is `Maybe (Field SqlInt4)`.  That means we don't necessarily need to specify it when writing to the table.  The database will automatically fill in a@@ -58,7 +58,7 @@ WHERE ((x) < (y))  -To insert we provide rows with the write type.  Optional columns can+To insert we provide rows with the write type.  Optional fields can be omitted by providing `Nothing` instead.  Numeric SQL types have a Haskell `Num` instance so we can write them using numeric literals. Values of other types should be created using the functions in the@@ -104,7 +104,7 @@         E'Hello')  -If we really want to specify an optional column we can use `Just`.+If we really want to specify an optional field we can use `Just`.  > insertJust :: Insert Int64 > insertJust = Insert

@@ -1,104 +0,0 @@-# Changes since version 0--This document pertains to changes between various old pre-release-versions of Opaleye and the first release to Hackage.  It is-irrelevant to you if you have only used Opaleye since its first-Hackage release.--## Changes visible in the API--### `Wire` becomes `Column`.  `ExprArr` is gone.--The most important user-visible difference between Opaleye 0 and-Opaleye 1 is that `Wire` is now called `Column`.  This is not just a-cosmetic change.  `Column` contains an entire SQL expression rather-than just a column reference.  That is, it contains what used to be-`ExprArr`.  The benefit is that manipulating SQL expressions no longer-needs the hassle of `ExprArr`.  For example, numerical operations can-be expressed succinctly--    calculation = proc () -> do-        (a, b, c) <- table -< ()-        returnA -< a + ifThenElse (b .== c) (b * c) (a / 2)--### Namespace changes--The namespace has changed from Karamaan.Opaleye to Opaleye.  Many of-the version 0 modules were very cluttered with deprecated names.  They-have been cleaned and tidied.--### Tables have type parameters for writing and reading--Tables now have two type parameters.  One indicates how to use it for-writing, the other for reading.--### `Nullable` is no longer a synonym for `Maybe`--`Nullable` is now a new type independent of `Maybe`.  `runQuery` still-converts it to `Maybe` but Opaleye-side code should use `Nullable`-instead of `Maybe`.--### `ShowConstant` doesn't exist--The `ShowConstant` typeclass for lifting Haskell values into Opaleye-does not exist anymore.  Instead there is a `PGTypes` module with-individual functions for lifting values.  If after due consideration-it seems like the typeclass was needed after all it can be added back-in.--## Internal changes--### SQL generation--Opaleye 1 uses less of HaskellDB's SQL generator.  HaskellDB's-optimizer is extremely buggy and its SQL generator does not support-`OUTER JOIN` or `VALUES`.  It would have been more difficult to work-around or patch HaskellDB than simply to write a new SQL generator for-Opaleye, so we did the latter.--### `PackMap`--Many or most of the product profunctors in use in Opaleye 0 have been-unified as values of specific type called `PackMap` which seems very-similar to a "traversal" from `Control.Lens`.  This cuts down on a lot-of boilerplate and allows unification of concepts and functionality.--## Converting from version 0--Please note that although almost all of Opaleye 0's functionality is-now present in Opaleye 1, we are still missing the implementation of-many operators and instances.  This is a very small amount of work and-would be a good starter project.  Patches for this are welcome.  For-example--* `RunQuery` is fully implemented but most of the `QueryRunner`-  instances just need to be written down.-* Support for numeric, boolean, etc. operators is fully-  implemented but many of them still need to be written down.-* Support for binary set operations and `OUTER JOIN`s is fully-  implemented but the definitions of `UNION`, `INTERSECT`,-  `INTERSECT ALL`, `RIGHT JOIN`, `FULL OUTER JOIN` etc. still need-  to be written down.--Opaleye 0 and Opaleye 1 can exist together in the same codebase-because they have different package names and different module-namespaces.  However, I would recommend converting to Opaleye 1 and-writing all new code with Opaleye 1 because it is easier to use.--Converting from Opaleye 0 to Opaleye 1 might be smoother if you-provide the following synonyms during the transition.--    type Wire = Column-    type ExprArr = (->)--    toQueryArrDef :: ExprArr a b -> QueryArr a b-    toQueryArrDef = arr--Information about how well this works in practice would be gratefully-received.--You will probably find that many identifiers have changed,-particularly fully qualified identifiers.  Theoretically a transition-package could be provided that maps from the old names to the new-names, but I suspect this is likely to be more work than just changing-all the old uses by hand.

@@ -1,34 +1,10 @@-# Low priority--* General type families for improving instance resolution-  (product-profunctors).  (Currently there are three places in Opaleye-  where instance resolution needs to happen: `runQuery`,-  `runInsertReturning` and `leftJoin`.  As it happens it seems-  difficult to make any of these benefit from a general type family-  approach.)- ## Good starter projects for someone wanting to contribute to Opaleye  ### Very easy  * There may be some missing operators that just need to be written down-* RIGHT JOIN, FULL OUTER JOIN-* Set operations-    * EXCEPT-    * EXCEPT ALL-    * UNION-    * INTERSECT-    * INTERSECT ALL-* INSERT, UPDATE, DELETE RETURNING-* Improve the testing "framework" perhaps by upgrading it to Tasty  ### Require a bit of work  * Make the code generation neater-* Make VALUES work with more, type checked, value types-* Product-valued case statements and (.==)-* Make the test database parameters more easily configurable-* Randomised testing in a QuickCheck style-* distinct, union and aggregate can be made to work with QueryArr-  rather than just Query if we use LATERAL JOIN * Escape hatch for embedding raw SQL

@@ -31,9 +31,15 @@ newtype ArbitrarySelectMaybe =   ArbitrarySelectMaybe (O.Select (O.MaybeFields Fields)) newtype ArbitrarySelectArr = ArbitrarySelectArr (O.SelectArr Fields Fields)+newtype ArbitrarySelectArrMaybe =+  ArbitrarySelectArrMaybe (O.SelectArr (O.MaybeFields Fields) (O.MaybeFields Fields)) newtype ArbitraryKleisli = ArbitraryKleisli (Fields -> O.Select Fields) newtype ArbitraryHaskells = ArbitraryHaskells { unArbitraryHaskells :: Haskells }                         deriving Show+newtype ArbitraryMaybeHaskells =+  ArbitraryMaybeHaskells { unArbitraryMaybeHaskells :: Maybe Haskells }+  deriving Show+newtype ArbitraryFields = ArbitraryFields { unArbitraryFields :: Fields } newtype ArbitraryHaskellsList =   ArbitraryHaskellsList { unArbitraryHaskellsList :: [HaskellsTuple] }                              deriving Show@@ -104,9 +110,9 @@   . unArbitraryOrder  restrictFirstBool :: O.SelectArr Fields Fields-restrictFirstBool = Arrow.arr snd-      <<< Arrow.first O.restrict-      <<< Arrow.arr (firstBoolOrTrue (O.sqlBool True))+restrictFirstBool = proc fields -> do+  O.restrict -< fst (firstBoolOrTrue (O.sqlBool True) fields)+  Arrow.returnA -< fields  instance Show ArbitrarySelect where   show (ArbitrarySelect q) = maybe "Empty query" id@@ -121,6 +127,10 @@   -- We could plug in dummy data here, or maybe just an empty list   show _ = "ArbitrarySelectArr" +instance Show ArbitrarySelectArrMaybe 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"@@ -128,6 +138,9 @@ instance Show ArbitraryFunction where   show = const "A function" +instance Show ArbitraryFields where+  show = const "Fields"+ 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)@@ -165,6 +178,9 @@  -- It would be better if ArbitrarySelect recursively called this, but -- it will do for now.+--+-- We are skirting close to generating infinite query territory here!+-- We should be careful about precisely how we recurse. instance TQ.Arbitrary ArbitrarySelectMaybe where   arbitrary = do     TQ.oneof $@@ -179,7 +195,27 @@           ArbitrarySelect q <- TQ.arbitrary           return (fmap fieldsToMaybeFields q)       ]+      +++      [ do+          ArbitrarySelectMaybe qm <- TQ.arbitrary+          ArbitrarySelectArrMaybe q <- TQ.arbitrary+          return (q <<< qm)+      ] +instance TQ.Arbitrary ArbitrarySelectArrMaybe where+  arbitrary = do+    TQ.oneof $+      (fmap . fmap) ArbitrarySelectArrMaybe $+      [ do+          ArbitrarySelectMaybe q <- TQ.arbitrary+          return (P.lmap (const ()) q)+      , do+          ArbitrarySelectArr q <- TQ.arbitrary+          return (traverse' q)+      ]+    where traverse' = O.traverseMaybeFieldsExplicit unpackFields unpackFields++ -- [Note] Testing strategy -- -- We have to be very careful otherwise we will generate@@ -416,6 +452,18 @@  instance TQ.Arbitrary ArbitraryHaskells where     arbitrary = arbitraryHaskells 6++instance TQ.Arbitrary ArbitraryMaybeHaskells where+    arbitrary = do+      TQ.frequency [ (1, pure (ArbitraryMaybeHaskells Nothing))+                   , (20, do+                         ArbitraryHaskells hs <- TQ.arbitrary+                         pure (ArbitraryMaybeHaskells (Just hs)))+                   ]++instance TQ.Arbitrary ArbitraryFields where+    arbitrary = (ArbitraryFields . fieldsOfHaskells . unArbitraryHaskells)+                   <$> TQ.arbitrary  -- Postgres strings cannot contain the zero codepoint.  See --

@@ -66,6 +66,12 @@ fieldsOfHaskells :: Haskells -> Fields fieldsOfHaskells = O.toFieldsExplicit toFieldsFields +fieldsOfMaybeHaskells :: Maybe Haskells -> O.MaybeFields Fields+fieldsOfMaybeHaskells =+  O.toFieldsExplicit (O.toFieldsMaybeFields+                        (Choices <$> O.nullspecList)+                        toFieldsFields)+ fieldsList :: Functor m => (a, b, m s) -> Choices m a b s fieldsList (x, y, ms) =   Choices [ Left (CInt x),@@ -107,6 +113,9 @@ distinctFields :: O.Distinctspec Fields Fields distinctFields = P.dimap unChoices Choices (PP.list     (defChoicePP PP.+++! OM.unWithNulls D.def distinctNullsFields))++nullspecFields :: O.Nullspec a Fields+nullspecFields = fmap Choices O.nullspecList  fromFieldsFields :: O.FromFields Fields Haskells fromFieldsFields = defChoicesPP O.fromFieldsMaybeFields

@@ -0,0 +1,40 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}++module Opaleye.Test.TraverseA where++import Control.Arrow++-- I first learned this from Alexis King at+-- https://github.com/tomjaguarpaw/Arrows2/issues/3#issuecomment-561973678++data Traversal a r b+  = Done b+  | Yield a !(r -> Traversal a r b)++instance Functor (Traversal a r) where+  fmap f = \case+    Done x -> Done (f x)+    Yield v k -> Yield v (fmap f . k)++instance Applicative (Traversal a r) where+  pure = Done+  tf <*> tx = case tf of+    Done f -> fmap f tx+    Yield v k -> Yield v ((<*> tx) . k)++traversal :: Traversable t => t a -> Traversal a b (t b)+traversal = traverse (flip Yield Done)++traverseA :: (ArrowChoice arr, Traversable t)+          => arr (e, a) b -> arr (e, t a) (t b)+traverseA f = second (arr traversal) >>> go where+  go = proc (e, as) -> case as of+    Done bs -> returnA -< bs+    Yield a k -> do+      b <- f -< (e, a)+      go -< (e, k b)++traverseA1 :: (ArrowChoice arr, Traversable t)+           => arr a b -> arr (t a) (t b)+traverseA1 f = arr (\x -> ((), x)) >>> traverseA (arr snd >>> f)

@@ -13,22 +13,20 @@ import           Connection (Connection, withConnection) import           Opaleye.Test.Arbitrary import           Opaleye.Test.Fields+import           Opaleye.Test.TraverseA (traverseA1)  import qualified Opaleye as O import qualified Opaleye.Join as OJ  import qualified Database.PostgreSQL.Simple as PGS-import           Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2)+import           Control.Applicative (Applicative, pure, (<$>), (<*>)) import qualified Control.Arrow as Arrow import           Control.Arrow ((<<<)) import           Control.Category (Category, (.), id)-import           Control.Monad (when, (<=<))+import           Control.Monad (when, guard) import qualified Data.Profunctor.Product.Default as D-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.Monoid as Monoid import qualified Data.Ord as Ord hiding (compare) import qualified Data.Set as Set@@ -63,35 +61,53 @@   . unArbitraryOrder  newtype SelectArrDenotation a b =-  SelectArrDenotation { unSelectArrDenotation :: PGS.Connection -> [a] -> IO [b] }+  SelectArrDenotation { unSelectArrDenotation :: PGS.Connection -> a -> IO [b] }  type SelectDenotation = SelectArrDenotation ()  instance Functor (SelectArrDenotation a) where-  fmap f = SelectArrDenotation-           . (fmap . fmap . fmap . fmap) f-           . unSelectArrDenotation+  fmap = onList . fmap  instance Applicative (SelectArrDenotation a) where-  pure    = SelectArrDenotation . pure . pure . pure . pure-  f <*> x = SelectArrDenotation ((liftA2 . liftA2 . liftA2 . liftA2) ($)-                                   (unSelectArrDenotation f)-                                   (unSelectArrDenotation x))+  pure = Arrow.arr . const+  f <*> x = fmap (uncurry ($)) (f Arrow.&&& x)  instance Category SelectArrDenotation where-  id = SelectArrDenotation (\_ -> pure)+  id = Arrow.arr id   (.) = \(SelectArrDenotation f) (SelectArrDenotation g) ->-          SelectArrDenotation (\conn -> f conn <=< g conn)+          SelectArrDenotation (\conn a -> do+                                  bs <- g conn a+                                  concatMapM (f conn) bs) +instance Arrow.Arrow SelectArrDenotation where+  arr f = SelectArrDenotation (\_ -> pure . pure . f)+  first f = SelectArrDenotation (\conn (a, b) -> do+                                    as' <- unSelectArrDenotation f conn a+                                    pure (fmap (\a' -> (a', b)) as'))++instance Arrow.ArrowChoice SelectArrDenotation where+  left f = SelectArrDenotation $ \conn -> \case+    Left l -> (fmap . fmap) Left (unSelectArrDenotation f conn l)+    Right r -> (pure . pure . pure) r+ runSelectArrDenotation :: SelectArrDenotation a b                        -> a                        -> PGS.Connection                        -> IO [b]-runSelectArrDenotation sab a conn = unSelectArrDenotation sab conn [a]+runSelectArrDenotation sab a conn = unSelectArrDenotation sab conn a -onList :: ([a] -> [b]) -> SelectDenotation a -> SelectDenotation b+($$) :: Arrow.Arrow arr => arr a b -> a -> arr () b+($$) f a = f <<< Arrow.arr (const a)++unApply :: (a -> SelectDenotation b) -> SelectArrDenotation a b+unApply f = SelectArrDenotation (\conn a -> unSelectArrDenotation (f a) conn ())++onList :: ([a] -> [b]) -> SelectArrDenotation i a -> SelectArrDenotation i b onList f = SelectArrDenotation . (fmap . fmap . fmap) f . unSelectArrDenotation +onListK :: (a -> [b]) -> SelectArrDenotation a b+onListK f = SelectArrDenotation (\_ a -> pure (f a))+ -- 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@@ -119,38 +135,20 @@             Left l  -> Left l             Right _ -> Right Nothing -optionalDenotation :: [Haskells] -> [Maybe Haskells]-optionalDenotation = \case+optionalDenotation :: SelectArrDenotation i a -> SelectArrDenotation i (Maybe a)+optionalDenotation = onList $ \case   [] -> [Nothing]   xs -> map Just xs -optionalRestrictDenotation :: [Haskells] -> [Maybe Haskells]-optionalRestrictDenotation = optionalDenotation . restrictFirstBoolList--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)--                           justs' <- f conn justs-                           let _ = justs' :: [Haskells]--                           return ((Just <$> justs')-                                   ++ (Nothing <$ nothings))))+lateralDenotation :: (a -> SelectDenotation r) -> SelectArrDenotation a r+lateralDenotation = unApply -lateralDenotation :: (a -> SelectDenotation r)-               -> SelectArrDenotation a r-lateralDenotation f = SelectArrDenotation (\conn l ->-  concatMapM (\r -> unSelectArrDenotation (f r) conn [()]) l)+optionalRestrictDenotation :: SelectDenotation Haskells+                           -> SelectArrDenotation (Haskells -> Bool) (Maybe Haskells)+optionalRestrictDenotation hs = optionalDenotation $ proc cond -> do+  a <- hs -< ()+  onListK guard -< cond a+  Arrow.returnA -< a  pureList :: [a] -> SelectDenotation a pureList = SelectArrDenotation . pure . pure . pure@@ -158,46 +156,54 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f +denotationArrExplicit :: (ah -> af)+                      -> O.FromFields bf bh+                      -> O.SelectArr af bf+                      -> SelectArrDenotation ah bh+denotationArrExplicit toFields qr q =+  SelectArrDenotation (\conn h ->+      let fs = pure (toFields h)+      in O.runSelectExplicit qr conn (q <<< fs))+ denotationExplicit :: O.FromFields fields a                    -> O.Select fields                    -> SelectDenotation a-denotationExplicit qr q =-  SelectArrDenotation (\conn rs ->-    flip concatMapM rs (\() -> O.runSelectExplicit qr conn q))+denotationExplicit = denotationArrExplicit O.toFields  denotation :: O.Select Fields -> SelectDenotation Haskells denotation = denotationExplicit fromFieldsFields -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))--denotation2 :: O.Select (Fields, Fields)-            -> SelectDenotation (Haskells, Haskells)-denotation2 = denotationExplicit (fromFieldsFields PP.***! fromFieldsFields)+denotationArr :: O.SelectArr Fields Fields+              -> SelectArrDenotation Haskells Haskells+denotationArr = denotationArrExplicit fieldsOfHaskells fromFieldsFields  denotationMaybeFields :: O.Select (O.MaybeFields Fields)                       -> SelectDenotation (Maybe Haskells) denotationMaybeFields =   denotationExplicit (O.fromFieldsMaybeFields fromFieldsFields) -unSelectDenotations :: Connection-                    -> SelectDenotation a+denotationArrMaybeFields+  :: O.SelectArr (O.MaybeFields Fields) (O.MaybeFields Fields)+  -> SelectArrDenotation (Maybe Haskells) (Maybe Haskells)+denotationArrMaybeFields =+  denotationArrExplicit+    (O.toFieldsExplicit (O.toFieldsMaybeFields nullspecFields toFieldsFields))+    (O.fromFieldsMaybeFields fromFieldsFields)++unSelectDenotations :: SelectDenotation a                     -> SelectDenotation b                     -> ([a] -> [b] -> IO TQ.Property)+                    -> Connection                     -> IO TQ.Property-unSelectDenotations conn one two k = unSelectArrDenotations conn one two () k+unSelectDenotations one two = unSelectArrDenotations one two () -unSelectArrDenotations :: Connection-                       -> SelectArrDenotation i a+unSelectArrDenotations :: SelectArrDenotation i a                        -> SelectArrDenotation i b                        -> i                        -> ([a] -> [b] -> IO TQ.Property)+                       -> Connection                        -> IO TQ.Property-unSelectArrDenotations conn one two i k = do+unSelectArrDenotations one two i k conn = do   withConnection conn (runSelectArrDenotation one i) >>= \case     Left _ -> discard     Right oner -> withConnection conn (runSelectArrDenotation two i) >>= \case@@ -214,12 +220,12 @@ -- 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               -> SelectDenotation a+              -> Connection               -> IO TQ.Property-compareNoSort conn one two =-  unSelectDenotations conn one two $ \one' two' -> do+compareNoSort one two =+  unSelectDenotations one two $ \one' two' -> do   when (one' /= two')        (putStrLn $ if List.sort one' == List.sort two'                    then "[but they are equal sorted]"@@ -228,61 +234,161 @@   return (one' === two')  compare :: (Show a, Ord a)-         => Connection-         -> SelectDenotation a+         => SelectDenotation a          -> SelectDenotation a+         -> Connection          -> IO TQ.Property-compare conn one two = unSelectDenotations conn one two $ \one' two' ->+compare one two = unSelectDenotations one two $ \one' two' ->   return (List.sort one' === List.sort two') +-- The condition is *not* that denotation of the sort is equal to sort+-- of the denotation, because the ordering may not fully specify the+-- order. compareSortedBy :: (Show a, Ord a)                 => (a -> a -> Ord.Ordering)-                -> Connection                 -> SelectDenotation a                 -> SelectDenotation a+                -> Connection                 -> IO TQ.Property-compareSortedBy o conn one two = unSelectDenotations conn one two $ \one' two' ->+compareSortedBy o one two = unSelectDenotations one two $ \one' two' ->   return ((List.sort one' === List.sort two')           .&&. isSortedBy o one') +type ArbitraryArgument = ArbitraryHaskells++denotationC :: Arrow.Arrow selectArr+            => (SelectDenotation Haskells -> selectArr () b -> t1 -> t2)+            -> O.SelectArr Fields Fields+            -> selectArr Haskells b+            -> ArbitraryHaskells+            -> t1+            -> t2+denotationC compare_ q d (ArbitraryHaskells h) conn =+  compare_ (denotation (q . pure (fieldsOfHaskells h))) (d $$ h) conn++compareDenotation :: O.SelectArr Fields Fields+                  -> SelectArrDenotation Haskells Haskells+                  -> ArbitraryArgument+                  -> Connection+                  -> IO TQ.Property+compareDenotation = denotationC compare++compareDenotationMaybe :: O.SelectArr (O.MaybeFields Fields) Fields+                       -> SelectArrDenotation (Maybe Haskells) Haskells+                       -> ArbitraryMaybeHaskells+                       -> Connection+                       -> IO TQ.Property+compareDenotationMaybe q d (ArbitraryMaybeHaskells h) =+  compare (denotation (q . pure (fieldsOfMaybeHaskells h))) (d $$ h)++compareDenotationMaybe2 :: O.SelectArr (O.MaybeFields Fields)+                                       (O.MaybeFields Fields)+                        -> SelectArrDenotation (Maybe Haskells) (Maybe Haskells)+                        -> ArbitraryMaybeHaskells+                        -> Connection+                        -> IO TQ.Property+compareDenotationMaybe2 q d (ArbitraryMaybeHaskells h) =+  compare (denotationMaybeFields (q . pure (fieldsOfMaybeHaskells h)))+          (d $$ h)++compareDenotationNoSort :: O.SelectArr Fields Fields+                        -> SelectArrDenotation Haskells Haskells+                        -> ArbitraryArgument+                        -> Connection+                        -> IO TQ.Property+compareDenotationNoSort = denotationC compareNoSort++compareDenotation' :: (O.Select Fields -> O.Select Fields)+                   -> ([Haskells] -> [Haskells])+                   -> ArbitrarySelect+                   -> Connection+                   -> IO TQ.Property+compareDenotation' f g (ArbitrarySelect q) =+  compare (denotation (f q)) (onList g (denotation q))++compareDenotationMaybe' :: (O.Select Fields -> O.Select (O.MaybeFields Fields))+                        -> (SelectDenotation Haskells -> SelectDenotation (Maybe Haskells))+                        -> ArbitrarySelect+                        -> Connection+                        -> IO TQ.Property+compareDenotationMaybe' f g (ArbitrarySelect q) =+  compare (denotationMaybeFields (f q)) (g (denotation q))++compareDenotationNoSort' :: (O.Select Fields -> O.Select Fields)+                         -> ([Haskells] -> [Haskells])+                         -> ArbitrarySelect+                         -> Connection+                         -> IO TQ.Property+compareDenotationNoSort' f g (ArbitrarySelect q) =+  compareNoSort (denotation (f q)) (onList g (denotation q))+ -- }  -- { The tests -fields :: Connection -> ArbitraryHaskells -> IO TQ.Property-fields conn (ArbitraryHaskells c) =-  compareNoSort conn (denotation (pure (fieldsOfHaskells c)))-                     (pure c)+fields :: ArbitraryHaskells -> ArbitraryArgument -> Connection -> IO TQ.Property+       -- ^ The ArbitraryArgument isn't really used+fields (ArbitraryHaskells c) =+  compareDenotationNoSort (pure (fieldsOfHaskells c)) (pure c) -compose :: Connection+compose :: ArbitrarySelectArr         -> ArbitrarySelectArr-        -> ArbitrarySelect+        -> ArbitraryArgument+        -> Connection         -> 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+compose (ArbitrarySelectArr q1) (ArbitrarySelectArr q2) = do+  compareDenotation (q1 . q2) (denotationArr q1 . denotationArr q2) +-- We need to test this separately otherwise traverseMaybeFields won't+-- be properly tested.  We need that [traverseMaybeFields q <<< q'] is+-- [traverseMaybeFields q] <<< [q] and we only test it when q' is of+-- the form pure h.  The 'compose' tests do the rest, therefore we+-- need a version of 'compose' that checks composition of things whose+-- types are 'MaybeFields Fields'.+composeMaybe :: ArbitrarySelectArrMaybe+             -> ArbitrarySelectArrMaybe+             -> ArbitraryMaybeHaskells+             -> Connection+             -> IO TQ.Property+composeMaybe (ArbitrarySelectArrMaybe q1) (ArbitrarySelectArrMaybe q2) = do+  compareDenotationMaybe2 (q1 . q2) (denotation_ q1 . denotation_ q2)+  where denotation_ = denotationArrMaybeFields  -- Would prefer to write 'compare conn (denotation id) id' but that -- requires extending compare to compare SelectArrs.-identity :: Connection-         -> ArbitrarySelect+identity :: ArbitraryArgument+         -> Connection          -> IO TQ.Property-identity conn (ArbitrarySelect q) = do-  compare conn (denotation (id . q))-               (id . denotation q)+identity = compareDenotation id id -fmap' :: Connection -> ArbitraryFunction -> ArbitrarySelect -> IO TQ.Property-fmap' conn (ArbitraryFunction f) (ArbitrarySelect q) =-  compareNoSort conn (denotation (fmap f q))-                     (fmap f (denotation q))+arr :: ArbitraryFunction+    -> ArbitraryArgument+    -> Connection+    -> IO TQ.Property+arr (ArbitraryFunction f) =+  compareDenotationNoSort (Arrow.arr f) (Arrow.arr f) -apply :: Connection -> ArbitrarySelect -> ArbitrarySelect -> IO TQ.Property-apply conn (ArbitrarySelect q1) (ArbitrarySelect q2) =-  compare conn (denotation2 ((,) <$> q1 <*> q2))-                ((,) <$> denotation q1 <*> denotation q2)+fmap' :: ArbitraryFunction+      -> ArbitrarySelectArr+      -> ArbitraryArgument+      -> Connection+      -> IO TQ.Property+fmap' (ArbitraryFunction f) (ArbitrarySelectArr q) =+  compareDenotationNoSort (fmap f q)+                          (fmap f (denotationArr q)) +apply :: ArbitrarySelectArr+      -> ArbitrarySelectArr+      -> ArbitraryArgument+      -> Connection+      -> IO TQ.Property+apply (ArbitrarySelectArr q1) (ArbitrarySelectArr q2) =+  compareDenotation (pair <$> q1 <*> q2)+                    (pair <$> denotationArr q1 <*> denotationArr q2)++  where pair x y = Choices [Right (pure x), Right (pure y)]++ -- 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@@ -291,15 +397,15 @@ -- the remainder under the applied ordering. -- -- Strangely the same caveat doesn't apply to offset.-limit :: Connection-      -> ArbitraryPositiveInt+limit :: ArbitraryPositiveInt       -> ArbitrarySelect       -> ArbitraryOrder+      -> Connection       -> IO TQ.Property-limit conn (ArbitraryPositiveInt l) (ArbitrarySelect q) o = do+limit (ArbitraryPositiveInt l) (ArbitrarySelect q) o = do   let q' = O.limit l (O.orderBy (arbitraryOrder o) q) -  unSelectDenotations conn (denotation q') (denotation q) $ \one' two' -> do+  unSelectDenotations (denotation q') (denotation q) $ \one' two' -> do       let remainder = MultiSet.fromList two'                       `MultiSet.difference`                       MultiSet.fromList one'@@ -315,110 +421,90 @@       return ((length one' === min l (length two'))               .&&. condBool) -offset :: Connection -> ArbitraryPositiveInt -> ArbitrarySelect+offset :: ArbitraryPositiveInt -> ArbitrarySelect -> Connection        -> IO TQ.Property-offset conn (ArbitraryPositiveInt l) (ArbitrarySelect q) =-  compareNoSort conn (denotation (O.offset l q))-                     (onList (drop l) (denotation q))+offset (ArbitraryPositiveInt n) =+  compareDenotationNoSort' (O.offset n) (drop n) -order :: Connection -> ArbitraryOrder -> ArbitrarySelect -> IO TQ.Property-order conn o (ArbitrarySelect q) =+order :: ArbitraryOrder -> ArbitrarySelect -> Connection -> IO TQ.Property+order o (ArbitrarySelect q) =   compareSortedBy (arbitraryOrdering o)-                  conn                   (denotation (O.orderBy (arbitraryOrder o) q))                   (denotation q) -distinct :: Connection -> ArbitrarySelect -> IO TQ.Property-distinct conn (ArbitrarySelect q) =-  compare conn (denotation (O.distinctExplicit distinctFields q))-                (onList nub (denotation q))+distinct :: ArbitrarySelect -> Connection -> IO TQ.Property+distinct =+  compareDenotation' (O.distinctExplicit distinctFields) nub --- 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 :: Connection -> ArbitrarySelect -> IO TQ.Property-restrict conn (ArbitrarySelect q) =-  compare conn (denotation (restrictFirstBool <<< q))-                (onList restrictFirstBoolList (denotation q))+-- When we generalise compareDenotation... we can just test+--+--    compareDenotation... conn restrict restrictDenotation+restrict :: ArbitraryArgument -> Connection -> IO TQ.Property+restrict =+  compareDenotationNoSort restrictFirstBool restrictFirstBoolDenotation -values :: Connection -> ArbitraryHaskellsList -> IO TQ.Property-values conn (ArbitraryHaskellsList l) =-  compareNoSort conn-                (denotation (fmap fieldsList (O.valuesSafe (fmap O.toFields l))))+values :: ArbitraryHaskellsList -> Connection -> IO TQ.Property+values (ArbitraryHaskellsList l) =+  compareNoSort (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))+valuesEmpty :: [()] -> Connection -> IO TQ.Property+valuesEmpty l =+  compareNoSort (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))+aggregate :: ArbitrarySelect -> Connection -> IO TQ.Property+aggregate =+  compareDenotationNoSort' (O.aggregate aggregateFields)+                           aggregateDenotation  -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))+label :: String -> ArbitrarySelect -> Connection -> IO TQ.Property+label comment = compareDenotationNoSort' (O.label comment) id -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)+optional :: ArbitrarySelect -> Connection -> IO TQ.Property+optional = compareDenotationMaybe' (OJ.optionalExplicit unpackFields)+                                   optionalDenotation -maybeFieldsToSelect :: Connection -> ArbitrarySelectMaybe -> IO TQ.Property-maybeFieldsToSelect conn (ArbitrarySelectMaybe q) =-  compare conn (denotation (O.maybeFieldsToSelect <<< q))-               (onList (Maybe.maybeToList =<<) (denotationMaybeFields q))+optionalRestrict :: ArbitrarySelect -> Connection -> IO TQ.Property+optionalRestrict =+  compareDenotationMaybe' optionalRestrictF optionalRestrictFDenotation+  where optionalRestrictF = f (firstBoolOrTrue (O.sqlBool True))+                              (O.optionalRestrictExplicit unpackFields) -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+        optionalRestrictFDenotation = f (firstBoolOrTrue True)+                                        optionalRestrictDenotation -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 x y z = Arrow.arr (\() -> fst . x) Arrow.>>> (y z) -        f' :: FieldsTuple -> O.Select Fields-        f' = f . Arrow.arr fieldsList+maybeFieldsToSelect :: ArbitraryMaybeHaskells -> Connection -> IO TQ.Property+maybeFieldsToSelect =+  compareDenotationMaybe O.maybeFieldsToSelect+                         (onListK Maybe.maybeToList) -        denotation_q :: SelectDenotation HaskellsTuple-        denotation_q = fmap listHaskells (denotation q)+traverseMaybeFields :: ArbitrarySelectArr+                    -> ArbitraryMaybeHaskells+                    -> Connection+                    -> IO TQ.Property+traverseMaybeFields (ArbitrarySelectArr q) =+  compareDenotationMaybe2 (traverse' q)+                          (traverseA1 (denotationArr q))+  where traverse' = O.traverseMaybeFieldsExplicit unpackFields unpackFields -        denotation_f  :: HaskellsTuple -> SelectDenotation Haskells-        denotation_f = denotation . f' . O.toFields+lateral :: ArbitraryKleisli+        -> ArbitraryArgument+        -> Connection+        -> IO TQ.Property+lateral (ArbitraryKleisli f) =+  compareDenotation (O.lateral f) (lateralDenotation (denotation . f'))+  where f' = f . fieldsOfHaskells  {- TODO    * Nullability   * Operators (mathematical, logical, etc.)-  * Use traverseMaybeFields in generated queries  -} @@ -434,33 +520,46 @@  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)+  let prop1 :: TQ.Testable prop+            => (a -> Connection -> IO prop) -> a -> TQ.Property+      prop1 = fmap (\p -> TQ.ioProperty (p conn)) +      prop2 :: TQ.Testable prop+            => (a1 -> a2 -> Connection -> IO prop)+            -> a1 -> a2 -> TQ.Property+      prop2 = (fmap . fmap) (\p -> TQ.ioProperty (p conn))+++      prop3 :: TQ.Testable prop+            => (a1 -> a2 -> a3 -> Connection -> IO prop)+            -> a1 -> a2 -> a3 -> TQ.Property+      prop3 = (fmap . fmap . fmap) (\p -> TQ.ioProperty (p conn))+       test1 :: (Show a, TQ.Arbitrary a, TQ.Testable prop)-               => (Connection -> a -> IO prop) -> IO ()+               => (a -> Connection -> IO prop) -> IO ()       test1 = t . prop1        test2 :: (Show a1, Show a2, TQ.Arbitrary a1, TQ.Arbitrary a2,                 TQ.Testable prop)-               => (Connection -> a1 -> a2 -> IO prop) -> IO ()+               => (a1 -> a2 -> Connection -> 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)-               => (Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()+               => (a1 -> a2 -> a3 -> Connection -> IO prop) -> IO ()       test3 = t . prop3        t p = errorIfNotSuccess         =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p    test1 identity-  test2 compose-  test1 fields-  test2 fmap'-  test2 apply+  test2 arr+  test3 compose+  test3 composeMaybe+  test2 fields+  test3 fmap'+  test3 apply   test3 limit   test2 offset   test2 order@@ -491,10 +590,10 @@   TQ.Success {} -> return ()   _             -> error "Failed" -restrictFirstBoolList :: [Haskells] -> [Haskells]-restrictFirstBoolList = map snd-                        . filter fst-                        . map (firstBoolOrTrue True)+restrictFirstBoolDenotation :: SelectArrDenotation Haskells Haskells+restrictFirstBoolDenotation = proc hs -> do+  onListK guard -< fst (firstBoolOrTrue True hs)+  Arrow.returnA -< hs  isSortedBy ::(a -> a -> Ord.Ordering) -> [a] -> Bool isSortedBy comp xs = all (uncurry (.<=)) (zip xs (tail' xs))

@@ -30,6 +30,7 @@ import qualified Opaleye.Internal.Aggregate       as IA import           Opaleye.Internal.RunQuery        (DefaultFromField) import           Opaleye.Internal.MaybeFields     as OM+import           Opaleye.Internal.Locking         as OL import qualified Connection import qualified QuickCheck import           System.Environment               (lookupEnv)@@ -1181,7 +1182,12 @@         query2 = pure ((fmap (const (0 :: Field O.SqlInt4)) nothing_)                        O..=== fmap (const (1 :: Field O.SqlInt4)) nothing_) +testForUpdate :: Test+testForUpdate = do+  it "Returns same rows from a table" $+      testH (OL.forUpdate table1Q) (`shouldBe` table1data) + main :: IO () main = do   let envVarName = "POSTGRES_CONNSTRING"@@ -1328,3 +1334,5 @@         testLiterals       describe "MaybeFields" $ do         testMaybeFieldsDistinct+      describe "Locking" $ do+        testForUpdate

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis-version:         0.6.7005.0+version:         0.6.7006.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@@ -17,7 +17,6 @@ extra-doc-files: README.md                  CHANGELOG.md                  *.md-                 Doc/*.md tested-with:     GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2  source-repository head@@ -36,7 +35,7 @@     , contravariant       >= 1.2     && < 1.6     , postgresql-simple   >= 0.5.3   && < 0.7     , pretty              >= 1.1.1.0 && < 1.2-    , product-profunctors >= 0.8.0.0 && < 0.11+    , product-profunctors >= 0.8.0.0 && < 0.12     , profunctors         >= 4.0     && < 5.6     , scientific          >= 0.3     && < 0.4     , semigroups          >= 0.13    && < 0.20@@ -78,7 +77,9 @@                    Opaleye.Internal.Binary,                    Opaleye.Internal.Column,                    Opaleye.Internal.Distinct,+                   Opaleye.Internal.Locking,                    Opaleye.Internal.Helpers,+                   Opaleye.Internal.Inferrable,                    Opaleye.Internal.Join,                    Opaleye.Internal.Label,                    Opaleye.Internal.Lateral,@@ -114,6 +115,7 @@   other-modules: Connection,                  Opaleye.Test.Arbitrary,                  Opaleye.Test.Fields,+                 Opaleye.Test.TraverseA,                  QuickCheck,                  TypeFamilies,                  Wrapped

@@ -71,6 +71,9 @@   def = Constant (C.maybeToNullable . fmap f)     where Constant f = D.def +instance D.Default ToFields (Column a) (Column a) where+  def = Constant id+ instance D.Default ToFields String (Column T.SqlText) where   def = Constant T.sqlString 

@@ -0,0 +1,258 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Opaleye.Internal.Inferrable where++import qualified Opaleye.Column as C+import           Opaleye.Internal.RunQuery (FromField, FromFields)+import qualified Opaleye.Internal.RunQuery as RQ+import qualified Opaleye.SqlTypes as T+import           Opaleye.Constant (ToFields)++import qualified Data.ByteString as SBS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.CaseInsensitive as CI+import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import qualified Data.Profunctor.Product.Default as D+import qualified Data.Scientific                 as Sci+import qualified Data.Text.Lazy as LT+import qualified Data.Text as ST+import qualified Data.Time as Time+import           Data.Typeable (Typeable)+import           Data.UUID (UUID)+import qualified Database.PostgreSQL.Simple.Range as R+import           GHC.Int (Int32, Int64)++newtype Inferrable p a b = Inferrable { runInferrable :: p a b }++-- FromFields++-- OVERLAPPABLE is pretty grim, but it will go away when we switch to Field+instance {-# OVERLAPPABLE #-}+  D.Default (Inferrable FromField) a b+  => D.Default (Inferrable FromFields) (C.Column a) b where+  def = Inferrable (RQ.queryRunner (runInferrable D.def))++instance+     (D.Default (Inferrable FromField) a b, Maybe b ~ maybe_b)+  => D.Default (Inferrable FromFields) (C.Column (C.Nullable a)) maybe_b where+  def = Inferrable (RQ.queryRunner (RQ.queryRunnerColumnNullable (runInferrable D.def)))++-- FromField++instance int ~ Int => D.Default (Inferrable FromField) T.SqlInt4 int where+  def = Inferrable D.def++instance int64 ~ Int64 => D.Default (Inferrable FromField) T.SqlInt8 int64 where+  def = Inferrable D.def++instance text ~ ST.Text => D.Default (Inferrable FromField) T.SqlText text where+  def = Inferrable D.def++instance (Typeable h, D.Default (Inferrable FromField) f h, hs ~ [h])+  => D.Default (Inferrable FromField) (T.SqlArray f) hs where+  def = Inferrable (RQ.fromFieldArray (runInferrable D.def))++instance double ~ Double => D.Default (Inferrable FromField) T.SqlFloat8 double where+  def = Inferrable D.def++instance bool ~ Bool => D.Default (Inferrable FromField) T.SqlBool bool where+  def = Inferrable D.def++instance uuid ~ UUID => D.Default (Inferrable FromField) T.SqlUuid uuid where+  def = Inferrable D.def++instance bytestring ~ SBS.ByteString+  => D.Default (Inferrable FromField) T.SqlBytea bytestring where+  def = Inferrable D.def++instance day ~ Time.Day+  => D.Default (Inferrable FromField) T.SqlDate day where+  def = Inferrable D.def++-- I'm not certain what we should map timestamptz to.  The+-- postgresql-simple types it maps to are ZonedTime and UTCTime, but+-- maybe it's more accurate to map it to a *pair* of LocalTime and a+-- time zone.++--instance utctime ~ Time.UTCTime+--  => D.Default (Inferrable FromField) T.SqlTimestamptz utctime where+--  def = Inferrable D.def++instance localtime ~ Time.LocalTime+  => D.Default (Inferrable FromField) T.SqlTimestamp localtime where+  def = Inferrable D.def++instance timeofday ~ Time.TimeOfDay+  => D.Default (Inferrable FromField) T.SqlTime timeofday where+  def = Inferrable D.def++instance cttext ~ CI.CI ST.Text+  => D.Default (Inferrable FromField) T.SqlCitext cttext where+  def = Inferrable D.def++-- It's not clear what to map JSON types to++{-+instance QueryRunnerColumnDefault T.PGJson String where+  defaultFromField = fieldParserQueryRunnerColumn jsonFieldParser++instance QueryRunnerColumnDefault T.PGJson Ae.Value where+  defaultFromField = fromPGSFromField++instance QueryRunnerColumnDefault T.PGJsonb String where+  defaultFromField = fieldParserQueryRunnerColumn jsonbFieldParser++instance QueryRunnerColumnDefault T.PGJsonb Ae.Value where+  defaultFromField = fromPGSFromField++instance QueryRunnerColumnDefault T.PGTimestamptz Time.UTCTime where+  defaultFromField = fromPGSFromField++instance QueryRunnerColumnDefault T.PGTimestamptz Time.ZonedTime where+  defaultFromField = fromPGSFromField+-}++-- ToFields++{- The instance for arrays would clash with String.  String is going to+   be use far more, so to get arrays you'll have to explicitly use+   `sqlArray`.++instance (D.Default (Inferrable ToFields) a (C.Column b),+          T.IsSqlType b,+          C.Column (T.SqlArray b) ~ cSqlArrayb)+         => D.Default (Inferrable ToFields) [a] cSqlArrayb where+  def = Inferrable (toToFields (T.sqlArray (toFieldsExplicit+                                               (runInferrable D.def))))+-}++instance C.Column a ~ columnA+  => D.Default (Inferrable ToFields) (C.Column a) columnA where+  def = Inferrable D.def++instance C.Column T.SqlText ~ cSqlText+  => D.Default (Inferrable ToFields) String cSqlText where+  def = Inferrable D.def++instance C.Column T.SqlBytea ~ cSqlBytea+  => D.Default (Inferrable ToFields) LBS.ByteString cSqlBytea where+  def = Inferrable D.def++instance C.Column T.SqlBytea ~ cSqlBytea+  => D.Default (Inferrable ToFields) SBS.ByteString cSqlBytea where+  def = Inferrable D.def++instance C.Column T.SqlText ~ cSqlText+  => D.Default (Inferrable ToFields) ST.Text cSqlText where+  def = Inferrable D.def++instance C.Column T.SqlText ~ cSqlText+  => D.Default (Inferrable ToFields) LT.Text cSqlText where+  def = Inferrable D.def++instance C.Column T.SqlNumeric ~ cSqlNumeric+  => D.Default (Inferrable ToFields) Sci.Scientific cSqlNumeric where+  def = Inferrable D.def++instance C.Column T.SqlInt4 ~ cSqlInt4+  => D.Default (Inferrable ToFields) Int cSqlInt4 where+  def = Inferrable D.def++instance C.Column T.SqlInt4 ~ cSqlInt4+  => D.Default (Inferrable ToFields) Int32 cSqlInt4 where+  def = Inferrable D.def++instance C.Column T.SqlInt8 ~ cSqlInt8+  => D.Default (Inferrable ToFields) Int64 cSqlInt8 where+  def = Inferrable D.def++instance C.Column T.SqlFloat8 ~ cSqlFloat8+  => D.Default (Inferrable ToFields) Double cSqlFloat8 where+  def = Inferrable D.def++instance C.Column T.SqlBool ~ cSqlBool+  => D.Default (Inferrable ToFields) Bool cSqlBool where+  def = Inferrable D.def++instance C.Column T.SqlUuid ~ cSqlUuid+  => D.Default (Inferrable ToFields) UUID cSqlUuid where+  def = Inferrable D.def++instance C.Column T.SqlDate ~ cSqlDate+  => D.Default (Inferrable ToFields) Time.Day cSqlDate where+  def = Inferrable D.def++instance C.Column T.SqlTimestamptz ~ cSqlTimestamptz+  => D.Default (Inferrable ToFields) Time.UTCTime cSqlTimestamptz where+  def = Inferrable D.def++instance C.Column T.SqlTimestamptz ~ cSqlTimestamptz+  => D.Default (Inferrable ToFields) Time.ZonedTime cSqlTimestamptz where+  def = Inferrable D.def++instance C.Column T.SqlTime ~ cSqlTime+  => D.Default (Inferrable ToFields) Time.TimeOfDay cSqlTime where+  def = Inferrable D.def++instance C.Column T.SqlCitext ~ cSqlCitext+  => D.Default (Inferrable ToFields) (CI.CI ST.Text) cSqlCitext where+  def = Inferrable D.def++instance C.Column T.SqlCitext ~ cSqlCitext+  => D.Default (Inferrable ToFields) (CI.CI LT.Text) cSqlCitext where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlInt4) ~ cRangeInt4+  => D.Default (Inferrable ToFields) (R.PGRange Int) cRangeInt4 where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlInt8) ~ cRangeInt8+  => D.Default (Inferrable ToFields) (R.PGRange Int64) cRangeInt8 where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlNumeric) ~ cRangeScientific+  => D.Default (Inferrable ToFields) (R.PGRange Sci.Scientific) cRangeScientific where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlTimestamp) ~ cRangeTimestamp+  => D.Default (Inferrable ToFields) (R.PGRange Time.LocalTime) cRangeTimestamp where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlTimestamptz) ~ cRangeTimestamptz+  => D.Default (Inferrable ToFields) (R.PGRange Time.UTCTime) cRangeTimestamptz where+  def = Inferrable D.def++instance C.Column (T.SqlRange T.SqlDate) ~ cRangeDate+  => D.Default (Inferrable ToFields) (R.PGRange Time.Day) cRangeDate where+  def = Inferrable D.def++{-  It's not clear if Aeson Value should map to JSON or JSONB.++instance D.Default ToFields Ae.Value (Column T.SqlJson) where+  def = Constant T.sqlValueJSON++instance D.Default ToFields Ae.Value (Column T.SqlJsonb) where+  def = Constant T.sqlValueJSONB++-}++-- Boilerplate instances++instance Functor (p a) => Functor (Inferrable p a) where+  fmap f = Inferrable . fmap f . runInferrable++instance Applicative (p a) => Applicative (Inferrable p a) where+  pure = Inferrable . pure+  f <*> x = Inferrable (runInferrable f <*> runInferrable x)++instance P.Profunctor p => P.Profunctor (Inferrable p) where+  dimap f g = Inferrable . P.dimap f g . runInferrable++instance PP.ProductProfunctor p => PP.ProductProfunctor (Inferrable p) where+  purePP = Inferrable . PP.purePP+  f **** g = Inferrable (runInferrable f PP.**** runInferrable g)

@@ -0,0 +1,25 @@+-- | Support for Postgres @SELECT@ locking clauses.+--+-- This functionality is new.  If you use it then please [open an+-- issue on+-- GitHub](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new)+-- and let us know how it went, whether that is well or badly.+--+-- Not all Postgres locking clauses are supported.  If you need+-- another form of locking clause then please [open an issue on+-- GitHub](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new).++module Opaleye.Internal.Locking where++import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.PrimQuery as PQ++-- | Adds a @FOR UPDATE@ clause to the 'Q.Select'.+--+-- Postgres has strong restrictions regarding the @SELECT@ clauses to+-- which a @FOR UPDATE@ can be added. Opaleye makes no attempt to+-- enforce those restrictions through its type system so it's very+-- easy to create queries that fail at run time using this operation.+forUpdate :: Q.Select a -> Q.Select a+forUpdate s =+  Q.QueryArr ((\(a, pq, t) -> (a, PQ.ForUpdate pq, t)) . Q.runQueryArr s)

@@ -2,7 +2,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}  module Opaleye.Internal.MaybeFields where @@ -11,9 +15,11 @@  import qualified Opaleye.Internal.Binary as B import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Constant as Constant+import qualified Opaleye.ToFields as Constant import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import           Opaleye.Internal.Inferrable (Inferrable(Inferrable),+                                              runInferrable) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.QueryArr as IQ import qualified Opaleye.Internal.RunQuery as RQ@@ -205,9 +211,9 @@ toFieldsMaybeFields :: V.Nullspec a b                     -> Constant.ToFields a b                     -> Constant.ToFields (Maybe a) (MaybeFields b)-toFieldsMaybeFields n p = Constant.Constant $ \case+toFieldsMaybeFields n p = Constant.toToFields $ \case   Nothing -> nothingFieldsExplicit n-  Just a  -> justFields (Constant.constantExplicit p a)+  Just a  -> justFields (Constant.toFieldsExplicit p a)  ifPPMaybeFields :: IfPP a b -> IfPP (MaybeFields a) (MaybeFields b) ifPPMaybeFields = productProfunctorMaybeFields PP.def@@ -295,8 +301,8 @@   => 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+instance (PP.Default Constant.ToFields a b, PP.Default V.Nullspec a b)+  => PP.Default Constant.ToFields (Maybe a) (MaybeFields b) where   def = toFieldsMaybeFields PP.def PP.def  instance PP.Default IfPP a b@@ -314,3 +320,13 @@ instance PP.Default (WithNulls B.Binaryspec) a b   => PP.Default B.Binaryspec (MaybeFields a) (MaybeFields b) where   def = binaryspecMaybeFields PP.def++instance (PP.Default (Inferrable RQ.FromFields) fields haskells,+          Maybe haskells ~ maybe_haskells)+  => PP.Default (Inferrable RQ.FromFields) (MaybeFields fields) maybe_haskells where+  def = Inferrable (fromFieldsMaybeFields (runInferrable PP.def))++instance (PP.Default (Inferrable Constant.ToFields) a b, PP.Default V.Nullspec a b,+          MaybeFields b ~ maybeFields_b)+  => PP.Default (Inferrable Constant.ToFields) (Maybe a) maybeFields_b where+  def = Inferrable (toFieldsMaybeFields PP.def (runInferrable PP.def))

@@ -62,6 +62,7 @@   , PQ.label     = fmap . PQ.Label   , PQ.relExpr   = return .: PQ.RelExpr   , PQ.rebind    = \b -> fmap . PQ.Rebind b+  , PQ.forUpdate = fmap PQ.ForUpdate   }   where -- If only the first argument is Just, do n1 on it         -- If only the second argument is Just, do n2 on it

@@ -85,6 +85,11 @@                   | Rebind    Bool                               (Bindings HPQ.PrimExpr)                               (PrimQuery' a)+                  | ForUpdate (PrimQuery' a)+                  -- We may support more locking clauses than just+                  -- ForUpdate in the future+                  --+                  -- https://www.postgresql.org/docs/current/sql-select.html#SQL-FOR-UPDATE-SHARE                  deriving Show  type PrimQuery = PrimQuery' ()@@ -121,6 +126,7 @@   , relExpr           :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p     -- ^ A relation-valued expression   , rebind            :: Bool -> Bindings HPQ.PrimExpr -> p -> p+  , forUpdate         :: p -> p   }  @@ -140,6 +146,7 @@   , relExpr           = RelExpr   , existsf           = Exists   , rebind            = Rebind+  , forUpdate         = ForUpdate   }  foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p@@ -159,6 +166,7 @@           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)+          ForUpdate q                 -> forUpdate         f (self q)         fix g = let x = g x in x  times :: PrimQuery -> PrimQuery -> PrimQuery

@@ -51,6 +51,7 @@                  $$  HPrint.ppOrderBy (Sql.orderBy s)                  $$  ppLimit (Sql.limit s)                  $$  ppOffset (Sql.offset s)+                 $$  ppFor (Sql.for s)   ppSelectJoin :: Join -> Doc@@ -147,6 +148,10 @@ ppOffset :: Maybe Int -> Doc ppOffset Nothing = empty ppOffset (Just n) = text ("OFFSET " ++ show n)++ppFor :: Maybe Sql.LockStrength -> Doc+ppFor Nothing       = empty+ppFor (Just Sql.Update) = text "FOR UPDATE"  ppValues :: [[HSql.SqlExpr]] -> Doc ppValues v = HPrint.ppAs (Just "V") (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v))

@@ -83,6 +83,8 @@                                     :| [(PQ.Lateral, primQueryR)])                                    [] +-- | Convert an arrow argument into a function argument so that it can+-- be applied inside @do@-notation rather than arrow notation. viaLateral :: SelectArr i a -> i -> Select a viaLateral s i = s <<< pure i 

@@ -271,8 +271,13 @@  instance (Typeable b, DefaultFromField a b) =>          QueryRunnerColumnDefault (T.PGArray a) [b] where-  defaultFromField = QueryRunnerColumn (P.lmap arrayColumn c) ((fmap . fmap . fmap) fromPGArray (pgArrayFieldParser f))-    where QueryRunnerColumn c f = defaultFromField+  defaultFromField = fromFieldArray defaultFromField++fromFieldArray :: Typeable h => FromField f h -> FromField (T.PGArray f) [h]+fromFieldArray q =+  QueryRunnerColumn (P.lmap arrayColumn c)+                    ((fmap . fmap . fmap) fromPGArray (pgArrayFieldParser f))+  where QueryRunnerColumn c f = q  -- } 

@@ -45,7 +45,8 @@   orderBy    :: [(HSql.SqlExpr, HSql.SqlOrder)],   distinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr),   limit      :: Maybe Int,-  offset     :: Maybe Int+  offset     :: Maybe Int,+  for        :: Maybe LockStrength   }           deriving Show @@ -70,6 +71,7 @@ data JoinType = LeftJoin | RightJoin | FullJoin deriving Show data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show data Lateral = Lateral | NonLateral deriving Show+data LockStrength = Update deriving Show  data Label = Label {   lLabel  :: String,@@ -100,6 +102,7 @@   , PQ.relExpr           = relExpr   , PQ.existsf           = exists   , PQ.rebind            = rebind+  , PQ.forUpdate         = forUpdate   }  exists :: Bool -> Select -> Select -> Select@@ -262,7 +265,8 @@   orderBy    = [],   distinctOn = Nothing,   limit      = Nothing,-  offset     = Nothing+  offset     = Nothing,+  for        = Nothing   }  sqlExpr :: HPQ.PrimExpr -> HSql.SqlExpr@@ -301,3 +305,9 @@   where selectAttrs = case star of           True  -> SelectAttrsStar           False -> SelectAttrs++forUpdate :: Select -> Select+forUpdate s = SelectFrom newSelect {+    tables = [(NonLateral, s)]+  , for = Just Update+  }

@@ -58,6 +58,8 @@ newtype Valuesspec columns columns' =   Valuesspec (PM.PackMap () HPQ.PrimExpr () columns') +type ValuesspecUnsafe = Valuesspec+ runValuesspec :: Applicative f => Valuesspec columns columns'               -> (() -> f HPQ.PrimExpr) -> f columns' runValuesspec (Valuesspec v) f = PM.traversePM v f ()

@@ -167,7 +167,7 @@  -- | 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+-- 'optionalRestrict' except without the return type wrapped in -- 'Opaleye.Internal.MaybeFields.MaybeFields'.  leftJoinA :: (D.Default U.Unpackspec fieldsR fieldsR,

@@ -6,7 +6,7 @@ -- | Operators on 'Column's.  Please note that numeric 'Column' types -- are instances of 'Num', so you can use '*', '/', '+', '-' on them. -module Opaleye.Operators (module Opaleye.Operators) where+module Opaleye.Operators where  import qualified Control.Arrow as A import qualified Data.Foldable as F

@@ -23,6 +23,7 @@ import qualified Opaleye.TypeFamilies as TF import           Opaleye.Internal.RunQuery (FromFields) import qualified Opaleye.Internal.RunQuery as IRQ+import           Opaleye.Internal.Inferrable (Inferrable, runInferrable)  import qualified Data.Profunctor.Product.Default as D @@ -160,3 +161,12 @@     -> S.Select fields     -> IO (IRQ.Cursor haskells) declareCursorExplicit = RQ.declareCursorExplicit++-- | Version of 'runSelect' with better type inference+runSelectI :: (D.Default (Inferrable FromFields) fields haskells)+           => PGS.Connection+           -- ^+           -> S.Select fields+           -- ^+           -> IO [haskells]+runSelectI = RQ.runQueryExplicit (runInferrable D.def)

@@ -4,11 +4,11 @@  {- | - Fields can be required or optional and, independently, nullable or+ Table fields can be required or optional and, independently, nullable or  non-nullable.   A required non-nullable @SqlInt4@ (for example) is defined with- 'required' and gives rise to a+ 'T.requiredTableField' and gives rise to a   @  TableFields (Field SqlInt4) (Field SqlInt4)@@ -18,7 +18,7 @@  update into this column you must give it a @Field SqlInt4@ (which you  can define with @sqlInt4 :: Int -> Field SqlInt4@). - A required nullable @SqlInt4@ is defined with 'required' and gives rise+ A required nullable @SqlInt4@ is defined with 'T.requiredTableField' and gives rise  to a   @@@ -30,7 +30,7 @@  @toNullable :: Field a -> FieldNullable a@, or with @null ::  FieldNullable a@. - An optional non-nullable @SqlInt4@ is defined with 'optional' and gives+ An optional non-nullable @SqlInt4@ is defined with 'T.optionalTableField' and gives  rise to a   @@@ -44,7 +44,7 @@  omitted from the query and the default value will be used. Otherwise  you have to provide a @Just@ containing a @Field SqlInt4@. - An optional nullable @SqlInt4@ is defined with 'optional' and gives+ An optional nullable @SqlInt4@ is defined with 'T.optionalTableField' and gives  rise to a   @

@@ -1,6 +1,21 @@-module Opaleye.ToFields (C.toFields, C.ToFields, module Opaleye.ToFields) where+{-# LANGUAGE FlexibleContexts #-} +module Opaleye.ToFields (C.toFields, toFieldsI, C.ToFields, module Opaleye.ToFields) where+ import qualified Opaleye.Constant as C+import           Opaleye.Internal.Inferrable (Inferrable, runInferrable) +import qualified Data.Profunctor.Product.Default as D+ toFieldsExplicit :: C.ToFields haskells fields -> haskells -> fields toFieldsExplicit = C.constantExplicit++toToFields :: (haskells -> fields) -> C.ToFields haskells fields+toToFields = C.Constant++-- | Version of 'C.toFields' with better type inference+toFieldsI :: (D.Default (Inferrable C.ToFields) haskells fields)+          => haskells+          -- ^+          -> fields+toFieldsI = toFieldsExplicit (runInferrable D.def)

@@ -62,7 +62,7 @@  -- | Forward-compatible version of unsafe 'values' that will not be -- deprecated in 0.7, but in 0.8.-valuesUnsafe :: (Default V.Valuesspec fields fields,+valuesUnsafe :: (Default V.ValuesspecUnsafe fields fields,                  Default U.Unpackspec fields fields) =>                 [fields] -> S.Select fields valuesUnsafe = values@@ -70,6 +70,6 @@ -- | 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'+                     -> V.ValuesspecUnsafe fields fields'                      -> [fields] -> S.Select fields' valuesUnsafeExplicit = valuesExplicit