opaleye 0.4.2.0 → 0.5.0.0

raw patch · 44 files changed

+1860/−285 lines, 44 filesdep ~aesondep ~basedep ~postgresql-simplePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, postgresql-simple, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• Doc/Tutorial/Main.hs +2/−0
• Doc/Tutorial/TutorialAdvanced.lhs +1/−1
• Doc/Tutorial/TutorialBasic.lhs +24/−8
• Doc/Tutorial/TutorialBasicMonomorphic.lhs +388/−0
• Doc/Tutorial/TutorialBasicTypeFamilies.lhs +420/−0
• Doc/Tutorial/TutorialManipulation.lhs +48/−21
• LICENSE +1/−1
• README.md +5/−0
• TODO.md +1/−0
• Test/QuickCheck.hs +46/−1
• Test/Test.hs +124/−11
• opaleye.cabal +15/−10
• src/Opaleye.hs +2/−0
• src/Opaleye/Aggregate.hs +63/−5
• src/Opaleye/Binary.hs +55/−11
• src/Opaleye/Column.hs +2/−8
• src/Opaleye/Constant.hs +11/−0
• src/Opaleye/Distinct.hs +4/−0
• src/Opaleye/Internal/Aggregate.hs +46/−5
• src/Opaleye/Internal/Binary.hs +15/−0
• src/Opaleye/Internal/Column.hs +17/−0
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +7/−6
• src/Opaleye/Internal/HaskellDB/Sql.hs +2/−1
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +15/−7
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +3/−2
• src/Opaleye/Internal/Join.hs +13/−4
• src/Opaleye/Internal/Label.hs +7/−0
• src/Opaleye/Internal/Optimize.hs +46/−12
• src/Opaleye/Internal/Order.hs +5/−3
• src/Opaleye/Internal/PackMap.hs +9/−5
• src/Opaleye/Internal/PrimQuery.hs +75/−35
• src/Opaleye/Internal/Print.hs +25/−8
• src/Opaleye/Internal/QueryArr.hs +3/−0
• src/Opaleye/Internal/RunQuery.hs +16/−13
• src/Opaleye/Internal/Sql.hs +39/−13
• src/Opaleye/Internal/Values.hs +14/−30
• src/Opaleye/Label.hs +11/−0
• src/Opaleye/Manipulation.hs +94/−43
• src/Opaleye/Operators.hs +58/−1
• src/Opaleye/Order.hs +1/−0
• src/Opaleye/PGTypes.hs +60/−1
• src/Opaleye/RunQuery.hs +43/−10
• src/Opaleye/Sql.hs +14/−9

@@ -1,3 +1,13 @@+## 0.5.0.0++* Added+    * `(.===)`, `aggregateOrdered`, `countStar`, `countRows`,+      `quot_`, `rem_`, 'charLength`+    * intersection and except query binary operators+    * `Constant` instances for `Maybe` and lists+    * `runInsertManyReturning`+    * `runQueryFold`+ ## 0.4.2.0  * Added `.===` and `./==` for comparison of product types

@@ -1,4 +1,6 @@ import TutorialBasic ()+import TutorialBasicMonomorphic ()+import TutorialBasicTypeFamilies () import TutorialManipulation () import TutorialAdvanced () import DefaultExplanation ()

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

@@ -11,6 +11,7 @@ > import           Opaleye (Column, Nullable, matchNullable, isNull, >                          Table(Table), required, queryTable, >                          Query, QueryArr, restrict, (.==), (.<=), (.&&), (.<),+>                          (.===), >                          (.++), ifThenElse, pgString, aggregate, groupBy, >                          count, avg, sum, leftJoin, runQuery, >                          showSqlForPostgres, Unpackspec,@@ -133,6 +134,10 @@  > $(makeAdaptorAndInstance "pBirthday" ''Birthday') +You don't have to use Template Haskell, but it just saves us writing+things out by hand here.  If you want to avoid Template Haskell see+[Data.Profunctor.Product.TH](https://hackage.haskell.org/package/product-profunctors-0.6.3.1/docs/Data-Profunctor-Product-TH.html).+ Then we can use 'Table' to make a table on our record type in exactly the same way as before. @@ -290,6 +295,8 @@ > >   returnA -< row +ghci> printSql twentiesAtAddress+ SELECT name0_1 as result1,        age1_1 as result2,        address2_1 as result3@@ -389,6 +396,8 @@ > >   returnA -< name .++ pgString " has " .++ aOrNo .++ pgString " boss" +ghci> printSql hasBoss+ SELECT (((name0_1) || ' has ')        || (CASE WHEN boss1_1 IS NULL THEN 'no' ELSE 'a' END))        || ' boss' as result1@@ -432,6 +441,7 @@ Then we get the following SQL.  ghci> printSql (bossQuery <<< queryTable employeeTable)+ SELECT CASE WHEN boss1_1 IS NULL THEN (name0_1) || ' has no boss'      ELSE (('The boss of ' || (name0_1)) || ' is ') || (boss1_1) END as result1 FROM (SELECT *@@ -634,8 +644,8 @@ uses of our Template Haskell derived code.  We use the 'pWidget' "adaptor" to specify how columns are aggregated.  Note that this is yet another example of avoiding a headache by keeping your datatype-fully polymorphic, because the 'count' aggregator changes a 'Wire-String' into a 'Wire Int64'.+fully polymorphic, because the 'count' aggregator changes a 'Column+String' into a 'Column Int64'.  Outer join ==========@@ -756,10 +766,7 @@  On the other hand we can make a newtype for the warehouse ID -> -- TODO: Since the `makeAdaptorAndInstance` Template Haskell is-> -- poorly written we have to make this `data` rather than `newtype` but-> -- this will be fixed in a later version.-> data WarehouseId' a = WarehouseId a+> newtype WarehouseId' a = WarehouseId a > $(makeAdaptorAndInstance "pWarehouseId" ''WarehouseId') > > type WarehouseIdColumn = WarehouseId' (Column PGInt4)@@ -774,14 +781,23 @@ >                               , wLocation = required "location" >                               , wNumGoods = required "num_goods" }) -Now the comparison will not pass the type checker.+Now the comparison will not pass the type checker  > -- forbiddenComparison :: GoodWarehouseColumn -> Column PGBool > -- forbiddenComparison w = wId w .== wNumGoods w > -- > -- => Couldn't match type `WarehouseId' (Column PGInt4)' with `Column PGInt4' +but we can compare two `WarehouseIdColumn`s. +> permittedComparison :: GoodWarehouseColumn+>                     -> GoodWarehouseColumn+>                     -> Column PGBool+> permittedComparison w1 w2 = wId w1 .=== wId w2++(Currently we use `.===`, a more polymorphic version of `.==`, but+`.==` may be generalised in the future.)+ Running queries on Postgres =========================== @@ -841,4 +857,4 @@ This is a little utility function to help with printing generated SQL.  > printSql :: Default Unpackspec a a => Query a -> IO ()-> printSql = putStrLn . showSqlForPostgres+> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres

@@ -0,0 +1,388 @@+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE UndecidableInstances #-}+>+> module TutorialBasicMonomorphic where+>+> import           Prelude hiding (sum)+>+> import           Opaleye (Column, Nullable,+>                          Table(Table), required, queryTable,+>                          Query, (.==),+>                          aggregate, groupBy,+>                          count, avg, sum, leftJoin, runQuery,+>                          showSqlForPostgres, Unpackspec,+>                          PGInt4, PGInt8, PGText, PGDate, PGFloat8)+>+> import qualified Opaleye                 as O+>+> import           Control.Applicative     ((<$>), (<*>), Applicative)+>+> import qualified Data.Profunctor         as P+> import           Data.Profunctor.Product (p3)+> import           Data.Profunctor.Product.Default (Default)+> import qualified Data.Profunctor.Product.Default as D+> import           Data.Time.Calendar (Day)+> import qualified Opaleye.Internal.TableMaker+> import qualified Opaleye.Internal.Join+>+> import qualified Database.PostgreSQL.Simple as PGS++Introduction+============++In this example file I'll give you a brief introduction to the Opaleye+relational query EDSL.  I'll show you how to define tables in Opaleye;+use them to generate selects, joins and filters; use the API of+Opaleye to make your queries more composable; and finally run the+queries on Postgres.++Schema+======++Opaleye assumes that a Postgres database already exists.  Currently+there is no support for creating databases or tables, though these+features may be added later according to demand.++A table is defined with the `Table` constructor.  The syntax is+simple.  You specify the types of the columns, the name of the table+and the names of the columns in the underlying database, and whether+the columns are required or optional.++(Note: This simple syntax is supported by an extra combinator that+describes the shape of the container that you are storing the columns+in.  In the first example we are using a tuple of size 3 and the+combinator is called `p3`.  We'll see examples of others later.)++The `Table` type constructor has two arguments.  The first one tells+us what columns we can write to the table and the second what columns+we can read from the table.  In this document we will always make all+columns required, so the write and read types will be the same.  All+`Table` types will have the same type argument repeated twice.  In the+manipulation tutorial you can see an example of when they might differ.++> personTable :: Table (Column PGText, Column PGInt4, Column PGText)+>                      (Column PGText, Column PGInt4, Column PGText)+> personTable = Table "personTable" (p3 ( required "name"+>                                       , required "age"+>                                       , required "address" ))++By default, the table `"personTable"` is looked up in PostgreSQL's+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 `queryTable`.++(Here and in a few other places in Opaleye there is some typeclass+magic going on behind the scenes to reduce boilerplate.  However, you+never *have* to use typeclasses.  All the magic that typeclasses do is+also available by explicitly passing in the "typeclass dictionary".+For this example file we will always use the typeclass versions+because they are simpler to read and the typeclass magic is+essentially invisible.)++> personQuery :: Query (Column PGText, Column PGInt4, Column PGText)+> personQuery = queryTable personTable++A `Query` corresponds to an SQL SELECT that we can run.  Here is the+SQL generated for `personQuery`.++ghci> printSql personQuery+SELECT name0_1 as result1,+       age1_1 as result2,+       address2_1 as result3+FROM (SELECT *+      FROM (SELECT name as name0_1,+                   age as age1_1,+                   address as address2_1+            FROM personTable as T1) as T1) as T1++This SQL is functionally equivalent to the following "idealized" SQL.+In this document every example of SQL generated by Opaleye will be+followed by an "idealized" equivalent version.  This will give you+some idea of how readable the SQL generated by Opaleye is.  Eventually+Opaleye should generate SQL closer to the "idealized" version, but+that is an ongoing project.  Since Postgres has a sensible query+optimization engine there should be little difference in performance+between Opaleye's version and the ideal.  Please submit any+differences encountered in practice as an Opaleye bug.++SELECT name,+       age+       address+FROM personTable++(`printSQL` is just a convenient utility function for the purposes of+this example file.  See below for its definition.)+++Record types+------------++Opaleye can use user defined types such as record types in queries.++Contrary to popular belief, you don't have to define your data types+to be polymorphic in all their fields.  Monomorphic field types will+mean that you have to define more datatypes and more instances for+them.++> data BirthdayColumn = BirthdayColumn { bdNameColumn :: Column PGText+>                                      , bdDayColumn  :: Column PGDate }+>+> data Birthday = Birthday { bdName :: String, bdDay :: Day }+>+> instance Default Unpackspec BirthdayColumn BirthdayColumn where+>   def = BirthdayColumn <$> P.lmap bdNameColumn D.def+>                        <*> P.lmap bdDayColumn  D.def+>+> instance Default Opaleye.Internal.TableMaker.ColumnMaker BirthdayColumn BirthdayColumn where+>   def = BirthdayColumn <$> P.lmap bdNameColumn D.def+>                        <*> P.lmap bdDayColumn  D.def++Then we can use 'Table' to make a table on our record type in exactly+the same way as before.++> birthdayTable :: Table BirthdayColumn BirthdayColumn+> birthdayTable = Table "birthdayTable"+>                        (BirthdayColumn <$> P.lmap bdNameColumn (required "name")+>                                        <*> P.lmap bdDayColumn  (required "birthday"))+>+> birthdayQuery :: Query BirthdayColumn+> birthdayQuery = queryTable birthdayTable++ghci> printSql birthdayQuery+SELECT name0_1 as result1,+       birthday1_1 as result2+FROM (SELECT *+      FROM (SELECT name as name0_1,+                   birthday as birthday1_1+            FROM birthdayTable as T1) as T1) as T1++Idealized SQL:++SELECT name,+       birthday+FROM birthdayTable+++Aggregation+===========++Type safe aggregation is the jewel in the crown of Opaleye.  Even SQL+generating APIs which are otherwise type safe often fall down when it+comes to aggregation.  If you want to find holes in the type system of+an SQL generating language, aggregation is the best place to look!  By+contrast, Opaleye aggregations always generate meaningful SQL.++By way of example, suppose we have a widget table which contains the+style, color, location, quantity and radius of widgets.  We can model+this information with the following datatype.++> data WidgetColumn = WidgetColumn { style    :: Column PGText+>                                  , color    :: Column PGText+>                                  , location :: Column PGText+>                                  , quantity :: Column PGInt4+>                                  , radius   :: Column PGFloat8+>                                  }+>+> instance Default Opaleye.Internal.TableMaker.ColumnMaker WidgetColumn WidgetColumn where+>   def = WidgetColumn <$> P.lmap style    D.def+>                      <*> P.lmap color    D.def+>                      <*> P.lmap location D.def+>                      <*> P.lmap quantity D.def+>                      <*> P.lmap radius   D.def++For the purposes of this example the style, color and location will be+strings, but in practice they might have been a different data type.++> widgetTable :: Table WidgetColumn WidgetColumn+> widgetTable = Table "widgetTable"+>                      (WidgetColumn <$> P.lmap style    (required "style")+>                                    <*> P.lmap color    (required "color")+>                                    <*> P.lmap location (required "location")+>                                    <*> P.lmap quantity (required "quantity")+>                                    <*> P.lmap radius   (required "radius"))+++Say we want to group by the style and color of widgets, calculating+how many (possibly duplicated) locations there are, the total number+of such widgets and their average radius.  `aggregateWidgets` shows us+how to do this.++> aggregateWidgets :: Query (Column PGText, Column PGText, Column PGInt8,+>                            Column PGInt4, Column PGFloat8)+> aggregateWidgets = aggregate ((,,,,) <$> P.lmap style    groupBy+>                                      <*> P.lmap color    groupBy+>                                      <*> P.lmap location count+>                                      <*> P.lmap quantity sum+>                                      <*> P.lmap radius   avg)+>                              (queryTable widgetTable)++The generated SQL is++ghci> printSql aggregateWidgets+SELECT result0_2 as result1,+       result1_2 as result2,+       result2_2 as result3,+       result3_2 as result4,+       result4_2 as result5+FROM (SELECT *+      FROM (SELECT style0_1 as result0_2,+                   color1_1 as result1_2,+                   COUNT(location2_1) as result2_2,+                   SUM(quantity3_1) as result3_2,+                   AVG(radius4_1) as result4_2+            FROM (SELECT *+                  FROM (SELECT style as style0_1,+                               color as color1_1,+                               location as location2_1,+                               quantity as quantity3_1,+                               radius as radius4_1+                        FROM widgetTable as T1) as T1) as T1+            GROUP BY style0_1,+                     color1_1) as T1) as T1++Idealized SQL:++SELECT style,+       color,+       COUNT(location),+       SUM(quantity),+       AVG(radius)+FROM widgetTable+GROUP BY style, color++Note: In `widgetTable` and `aggregateWidgets` we see more explicit+uses of our Template Haskell derived code.  We use the 'pWidget'+"adaptor" to specify how columns are aggregated.  Note that this is+yet another example of avoiding a headache by keeping your datatype+fully polymorphic, because the 'count' aggregator changes a 'Wire+String' into a 'Wire Int64'.++Outer join+==========++Opaleye supports left joins.  (Full outer joins and right joins are+left to be added as a simple starter project for a new Opaleye+contributer!)++Because left joins can change non-nullable columns into nullable+columns we have to make sure the type of the output supports+nullability.  We introduce the following type synonym for this+purpose, which is just a notational convenience.++> data BirthdayColumnNullable =+>   BirthdayColumnNullable { bdNameColumnNullable :: Column (Nullable PGText)+>                          , bdDayColumnNullable  :: Column (Nullable PGDate) }+>+> instance Default O.Unpackspec BirthdayColumnNullable BirthdayColumnNullable where+>   def = BirthdayColumnNullable <$> P.lmap bdNameColumnNullable D.def+>                                <*> P.lmap bdDayColumnNullable  D.def+>+> instance Default Opaleye.Internal.Join.NullMaker BirthdayColumn BirthdayColumnNullable where+>   def = BirthdayColumnNullable <$> P.lmap bdNameColumn D.def+>                                <*> P.lmap bdDayColumn  D.def++A left join is expressed by specifying the two tables to join and the+join condition.++> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText),+>                                  BirthdayColumnNullable)+> personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName+>     where eqName ((name, _, _), birthdayRow) = name .== bdNameColumn birthdayRow++The generated SQL is++ghci> printSql personBirthdayLeftJoin+SELECT result1_0_3 as result1,+       result1_1_3 as result2,+       result1_2_3 as result3,+       result2_0_3 as result4,+       result2_1_3 as result5+FROM (SELECT *+      FROM (SELECT name0_1 as result1_0_3,+                   age1_1 as result1_1_3,+                   address2_1 as result1_2_3,+                   name0_2 as result2_0_3,+                   birthday1_2 as result2_1_3+            FROM+            (SELECT *+             FROM (SELECT name as name0_1,+                          age as age1_1,+                          address as address2_1+                   FROM personTable as T1) as T1) as T1+            LEFT OUTER JOIN+            (SELECT *+             FROM (SELECT name as name0_2,+                          birthday as birthday1_2+                   FROM birthdayTable as T1) as T1) as T2+            ON+            (name0_1) = (name0_2)) as T1) as T1++Idealized SQL:++SELECT name0,+       age0,+       address0,+       name1,+       birthday1+FROM (SELECT name as name0,+             age as age0,+             address as address0+      FROM personTable) as T1+     LEFT OUTER JOIN+     (SELECT name as name1,+             birthday as birthday1+      FROM birthdayTable) as T1+ON name0 = name1+++A comment about type signatures+-------------------------------++We mentioned that Opaleye uses typeclass magic behind the scenes to+avoid boilerplate.  One consequence of this is that the compiler+cannot infer types in some cases. Use of `leftJoin` is one of those+cases.  You will generally need to provide a type signature yourself.+If you see the compiler complain that it cannot determine a `Default`+instance then specify more types.+++Running queries on Postgres+===========================+++Opaleye provides simple facilities for running queries on Postgres.+`runQuery` is a typeclass polymorphic function that effectively has+the following type++> -- runQuery :: Database.PostgreSQL.Simple.Connection+> --          -> Query columns -> IO [haskells]++It converts a "record" of Opaleye columns to a list of "records" of+Haskell values.  Like `leftJoin` this particular formulation uses+typeclasses so please put type signatures on everything in sight to+minimize the number of confusing error messages!++> instance Default O.QueryRunner BirthdayColumn Birthday where+>   def = Birthday <$> P.lmap bdNameColumn D.def+>                  <*> P.lmap bdDayColumn  D.def+>+> runBirthdayQuery :: PGS.Connection+>                  -> Query BirthdayColumn+>                  -> IO [Birthday]+> runBirthdayQuery = runQuery++Conclusion+==========++There ends the Opaleye introductions module.  Please send me your questions!++Utilities+=========++This is a little utility function to help with printing generated SQL.++> printSql :: Default Unpackspec a a => Query a -> IO ()+> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres

@@ -0,0 +1,420 @@+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE UndecidableInstances #-}+>+> {-# LANGUAGE TypeFamilies #-}+> {-# LANGUAGE EmptyDataDecls #-}+> {-# LANGUAGE FunctionalDependencies #-}+>+> module TutorialBasicTypeFamilies where+>+> import           Prelude hiding (sum)+>+> import           Opaleye (Column, Nullable,+>                          Table(Table), required, queryTable,+>                          Query, (.==), aggregate, groupBy,+>                          count, avg, sum, leftJoin, runQuery,+>                          showSqlForPostgres, Unpackspec,+>                          PGInt4, PGInt8, PGText, PGDate, PGFloat8)+> import qualified Opaleye as O+>+> import           Control.Applicative     ((<$>), (<*>), Applicative)+>+> import qualified Data.Profunctor         as P+> import           Data.Profunctor.Product (p3)+> import           Data.Profunctor.Product.Default (Default)+> import qualified Data.Profunctor.Product.Default as D+> import           Data.Time.Calendar (Day)+>+> import qualified Database.PostgreSQL.Simple as PGS++Introduction+============++In this example file I'll give you a brief introduction to the Opaleye+relational query EDSL.  I'll show you how to define tables in Opaleye;+use them to generate selects, joins and filters; use the API of+Opaleye to make your queries more composable; and finally run the+queries on Postgres.++Schema+======++Opaleye assumes that a Postgres database already exists.  Currently+there is no support for creating databases or tables, though these+features may be added later according to demand.++A table is defined with the `Table` constructor.  The syntax is+simple.  You specify the types of the columns, the name of the table+and the names of the columns in the underlying database, and whether+the columns are required or optional.++(Note: This simple syntax is supported by an extra combinator that+describes the shape of the container that you are storing the columns+in.  In the first example we are using a tuple of size 3 and the+combinator is called `p3`.  We'll see examples of others later.)++The `Table` type constructor has two arguments.  The first one tells+us what columns we can write to the table and the second what columns+we can read from the table.  In this document we will always make all+columns required, so the write and read types will be the same.  All+`Table` types will have the same type argument repeated twice.  In the+manipulation tutorial you can see an example of when they might differ.++> personTable :: Table (Column PGText, Column PGInt4, Column PGText)+>                      (Column PGText, Column PGInt4, Column PGText)+> personTable = Table "personTable" (p3 ( required "name"+>                                       , required "age"+>                                       , required "address" ))++By default, the table `"personTable"` is looked up in PostgreSQL's+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 `queryTable`.++(Here and in a few other places in Opaleye there is some typeclass+magic going on behind the scenes to reduce boilerplate.  However, you+never *have* to use typeclasses.  All the magic that typeclasses do is+also available by explicitly passing in the "typeclass dictionary".+For this example file we will always use the typeclass versions+because they are simpler to read and the typeclass magic is+essentially invisible.)++> personQuery :: Query (Column PGText, Column PGInt4, Column PGText)+> personQuery = queryTable personTable++A `Query` corresponds to an SQL SELECT that we can run.  Here is the+SQL generated for `personQuery`.++ghci> printSql personQuery+SELECT name0_1 as result1,+       age1_1 as result2,+       address2_1 as result3+FROM (SELECT *+      FROM (SELECT name as name0_1,+                   age as age1_1,+                   address as address2_1+            FROM personTable as T1) as T1) as T1++This SQL is functionally equivalent to the following "idealized" SQL.+In this document every example of SQL generated by Opaleye will be+followed by an "idealized" equivalent version.  This will give you+some idea of how readable the SQL generated by Opaleye is.  Eventually+Opaleye should generate SQL closer to the "idealized" version, but+that is an ongoing project.  Since Postgres has a sensible query+optimization engine there should be little difference in performance+between Opaleye's version and the ideal.  Please submit any+differences encountered in practice as an Opaleye bug.++SELECT name,+       age+       address+FROM personTable++(`printSQL` is just a convenient utility function for the purposes of+this example file.  See below for its definition.)+++Record types+------------++Opaleye can use user defined types such as record types in queries.++Contrary to popular belief, you don't have to define your data types+to be polymorphic in all their fields.  In fact there's a nice scheme+using type families that reduces boiler plate and has always been+compatible with Opaleye!++> type family Field      f a b n+> type family TableField f a b n req+>+> data H+> data O+> data Nulls+> data W+>+> data NN+> data N+>+> data Req+> data Opt+> +> type instance Field H h o NN = h+> type instance Field H h o N  = Maybe h+> type instance Field O h o NN = Column o+> type instance Field O h o N  = Column (Nullable o)+>+> type instance TableField H     h o n b   = Field H h o n+> type instance TableField O     h o n b   = Field O h o n+> type instance TableField W     h o n Req = Field O h o n+> type instance TableField W     h o n Opt = Maybe (Field O h o n)+> type instance TableField Nulls h o n b   = Column (Nullable o)+>+> -- Cryptic remark: If we were willing to only support 7.8 and up we+> -- could even have a symbol field containing the table name and use+> -- https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-TypeLits.html#v:symbolVal+> +>+> -- { If you use Tableable you don't even have to specify required or optional+>      +> class Tableable a b | a -> b where+>   tableField :: String -> O.TableProperties a b+>+> instance Tableable (Column a) (Column a) where+>   tableField = required+>+> instance Tableable (Maybe (Column a)) (Column a) where+>   tableField = O.optional+>+> -- }+>+> data Birthday f = Birthday { bdName :: TableField f String PGText NN Req+>                            , bdDay  :: TableField f Day    PGDate NN Req+>                            }+>+> instance ( Applicative (p (Birthday a))+>          , P.Profunctor p+>          , Default p (TableField a String PGText NN Req) (TableField b String PGText NN Req)+>          , Default p (TableField a Day    PGDate NN Req) (TableField b Day    PGDate NN Req)) =>+>   Default p (Birthday a) (Birthday b) where+>   def = Birthday <$> P.lmap bdName D.def+>                  <*> P.lmap bdDay  D.def++Then we can use 'Table' to make a table on our record type in exactly+the same way as before.++> birthdayTable :: Table (Birthday W) (Birthday O)+> birthdayTable = Table "birthdayTable"+>                        (Birthday <$> P.lmap bdName (required "name")+>                                  <*> P.lmap bdDay  (required "birthday"))+>+> birthdayQuery :: Query (Birthday O)+> birthdayQuery = queryTable birthdayTable++ghci> printSql birthdayQuery+SELECT name0_1 as result1,+       birthday1_1 as result2+FROM (SELECT *+      FROM (SELECT name as name0_1,+                   birthday as birthday1_1+            FROM birthdayTable as T1) as T1) as T1++Idealized SQL:++SELECT name,+       birthday+FROM birthdayTable+++Aggregation+===========++Type safe aggregation is the jewel in the crown of Opaleye.  Even SQL+generating APIs which are otherwise type safe often fall down when it+comes to aggregation.  If you want to find holes in the type system of+an SQL generating language, aggregation is the best place to look!  By+contrast, Opaleye aggregations always generate meaningful SQL.++By way of example, suppose we have a widget table which contains the+style, color, location, quantity and radius of widgets.  We can model+this information with the following datatype.++> data Widget f = Widget { style    :: Field f String PGText   NN+>                        , color    :: Field f String PGText   NN+>                        , location :: Field f String PGText   NN+>                        , quantity :: Field f Int    PGInt4   NN+>                        , radius   :: Field f Double PGFloat8 NN+>                        }+>+> instance ( Applicative (p (Widget a))+>          , P.Profunctor p+>          , Default p (Field a String PGText NN)   (Field b String PGText NN)+>          , Default p (Field a Int    PGInt4 NN)   (Field b Int    PGInt4 NN)+>          , Default p (Field a Double PGFloat8 NN) (Field b Double PGFloat8 NN)+>          , Default p (Field a Day    PGDate NN)   (Field b Day    PGDate NN)) =>+>   Default p (Widget a) (Widget b) where+>   def = Widget <$> P.lmap style    D.def+>                <*> P.lmap color    D.def+>                <*> P.lmap location D.def+>                <*> P.lmap quantity D.def+>                <*> P.lmap radius   D.def++For the purposes of this example the style, color and location will be+strings, but in practice they might have been a different data type.++> widgetTable :: Table (Widget O) (Widget O)+> widgetTable = Table "widgetTable"+>                      (Widget <$> P.lmap style    (required "style")+>                              <*> P.lmap color    (required "color")+>                              <*> P.lmap location (required "location")+>                              <*> P.lmap quantity (required "quantity")+>                              <*> P.lmap radius   (required "radius"))+++Say we want to group by the style and color of widgets, calculating+how many (possibly duplicated) locations there are, the total number+of such widgets and their average radius.  `aggregateWidgets` shows us+how to do this.++> aggregateWidgets :: Query (Column PGText, Column PGText, Column PGInt8,+>                            Column PGInt4, Column PGFloat8)+> aggregateWidgets = aggregate ((,,,,) <$> P.lmap style    groupBy+>                                      <*> P.lmap color    groupBy+>                                      <*> P.lmap location count+>                                      <*> P.lmap quantity sum+>                                      <*> P.lmap radius   avg)+>                              (queryTable widgetTable)++The generated SQL is++ghci> printSql aggregateWidgets+SELECT result0_2 as result1,+       result1_2 as result2,+       result2_2 as result3,+       result3_2 as result4,+       result4_2 as result5+FROM (SELECT *+      FROM (SELECT style0_1 as result0_2,+                   color1_1 as result1_2,+                   COUNT(location2_1) as result2_2,+                   SUM(quantity3_1) as result3_2,+                   AVG(radius4_1) as result4_2+            FROM (SELECT *+                  FROM (SELECT style as style0_1,+                               color as color1_1,+                               location as location2_1,+                               quantity as quantity3_1,+                               radius as radius4_1+                        FROM widgetTable as T1) as T1) as T1+            GROUP BY style0_1,+                     color1_1) as T1) as T1++Idealized SQL:++SELECT style,+       color,+       COUNT(location),+       SUM(quantity),+       AVG(radius)+FROM widgetTable+GROUP BY style, color++Note: In `widgetTable` and `aggregateWidgets` we see more explicit+uses of our Template Haskell derived code.  We use the 'pWidget'+"adaptor" to specify how columns are aggregated.  Note that this is+yet another example of avoiding a headache by keeping your datatype+fully polymorphic, because the 'count' aggregator changes a 'Wire+String' into a 'Wire Int64'.++Outer join+==========++Opaleye supports left joins.  (Full outer joins and right joins are+left to be added as a simple starter project for a new Opaleye+contributer!)++Because left joins can change non-nullable columns into nullable+columns we have to make sure the type of the output supports+nullability.  We introduce the following type synonym for this+purpose, which is just a notational convenience.++A left join is expressed by specifying the two tables to join and the+join condition.++> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText),+>                                  Birthday Nulls)+> personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName+>     where eqName ((name, _, _), birthdayRow) = name .== bdName birthdayRow++The generated SQL is++ghci> printSql personBirthdayLeftJoin+SELECT result1_0_3 as result1,+       result1_1_3 as result2,+       result1_2_3 as result3,+       result2_0_3 as result4,+       result2_1_3 as result5+FROM (SELECT *+      FROM (SELECT name0_1 as result1_0_3,+                   age1_1 as result1_1_3,+                   address2_1 as result1_2_3,+                   name0_2 as result2_0_3,+                   birthday1_2 as result2_1_3+            FROM+            (SELECT *+             FROM (SELECT name as name0_1,+                          age as age1_1,+                          address as address2_1+                   FROM personTable as T1) as T1) as T1+            LEFT OUTER JOIN+            (SELECT *+             FROM (SELECT name as name0_2,+                          birthday as birthday1_2+                   FROM birthdayTable as T1) as T1) as T2+            ON+            (name0_1) = (name0_2)) as T1) as T1++Idealized SQL:++SELECT name0,+       age0,+       address0,+       name1,+       birthday1+FROM (SELECT name as name0,+             age as age0,+             address as address0+      FROM personTable) as T1+     LEFT OUTER JOIN+     (SELECT name as name1,+             birthday as birthday1+      FROM birthdayTable) as T1+ON name0 = name1+++A comment about type signatures+-------------------------------++We mentioned that Opaleye uses typeclass magic behind the scenes to+avoid boilerplate.  One consequence of this is that the compiler+cannot infer types in some cases. Use of `leftJoin` is one of those+cases.  You will generally need to provide a type signature yourself.+If you see the compiler complain that it cannot determine a `Default`+instance then specify more types.+++Running queries on Postgres+===========================+++Opaleye provides simple facilities for running queries on Postgres.+`runQuery` is a typeclass polymorphic function that effectively has+the following type++> -- runQuery :: Database.PostgreSQL.Simple.Connection+> --          -> Query columns -> IO [haskells]++It converts a "record" of Opaleye columns to a list of "records" of+Haskell values.  Like `leftJoin` this particular formulation uses+typeclasses so please put type signatures on everything in sight to+minimize the number of confusing error messages!++> runBirthdayQuery :: PGS.Connection+>                  -> Query (Birthday O)+>                  -> IO [Birthday H]+> runBirthdayQuery = runQuery++Conclusion+==========++There ends the Opaleye introductions module.  Please send me your questions!++Utilities+=========++This is a little utility function to help with printing generated SQL.++> printSql :: Default Unpackspec a a => Query a -> IO ()+> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres

@@ -4,14 +4,15 @@ > > import           Opaleye (Column, Table(Table), >                           required, optional, (.==), (.<),->                           arrangeDeleteSql, arrangeInsertSql,->                           arrangeUpdateSql, arrangeInsertReturningSql,+>                           arrangeDeleteSql, arrangeInsertManySql,+>                           arrangeUpdateSql, arrangeInsertManyReturningSql, >                           PGInt4, PGFloat8) >-> import           Data.Profunctor.Product (p3)+> import           Data.Profunctor.Product (p4) > import           Data.Profunctor.Product.Default (Default, def) > import qualified Opaleye.Internal.Unpackspec as U-+> import qualified Opaleye.PGTypes as P+> import qualified Opaleye.Constant as C  Manipulation ============@@ -30,15 +31,19 @@ specify it when writing to the table.  The database will automatically fill in a value for us. -> table :: Table (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8)->                (Column PGInt4, Column PGFloat8, Column PGFloat8)-> table = Table "tablename" (p3 (optional "id", required "x", required "y"))+> table :: Table+>     (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8, Column P.PGText)+>     (Column PGInt4, Column PGFloat8, Column PGFloat8, Column P.PGText)+> table = Table "tablename" (p4 ( optional "id"+>                               , required "x"+>                               , required "y"+>                               , required "s" ))  To perform a delete we provide an expression from our read type to `Column Bool`.  All rows for which the expression is true are deleted.  > delete :: String-> delete = arrangeDeleteSql table (\(_, x, y) -> x .< y)+> delete = arrangeDeleteSql table (\(_, x, y, _) -> x .< y)  ghci> putStrLn delete DELETE FROM tablename@@ -46,10 +51,14 @@   To insert we provide a row with the write type.  Optional columns can-be omitted by providing `Nothing` instead.+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+`Opaleye.PGTypes` module, for example `pgString` to create a `Column+P.PGText` from a `String`.  > insertNothing :: String-> insertNothing = arrangeInsertSql table (Nothing, 2, 3)+> insertNothing = arrangeInsertManySql table (return (Nothing, 2, 3, P.pgString "Hello"))  ghci> putStrLn insertNothing INSERT INTO tablename (x,@@ -58,10 +67,28 @@         3.0)  +If we'd like to pass a value into the insertion function, we can't+rely on the Num instance and must use constant:++> insertNonLiteral :: Double -> String+> insertNonLiteral i =+>   arrangeInsertManySql table (return (Nothing, 2, C.constant i, P.pgString "Hello"))++ghci> > putStrLn $ insertNonLiteral 12.0+INSERT INTO "tablename" ("id",+                         "x",+                         "y",+                         "s")+VALUES (DEFAULT,+        2.0,+        12.0,+        E'Hello')++ If we really want to specify an optional column we can use `Just`.  > insertJust :: String-> insertJust = arrangeInsertSql table (Just 1, 2, 3)+> insertJust = arrangeInsertManySql table (return (Just 1, 2, 3, P.pgString "Hello"))  ghci> putStrLn insertJust INSERT INTO tablename (id,@@ -78,8 +105,8 @@ according to the update function.  > update :: String-> update = arrangeUpdateSql table (\(_, x, y) -> (Nothing, x + y, x - y))->                                 (\(id_, _, _) -> id_ .== 5)+> update = arrangeUpdateSql table (\(_, x, y, s) -> (Nothing, x + y, x - y, s))+>                                 (\(id_, _, _, _) -> id_ .== 5)  ghci> putStrLn update UPDATE tablename@@ -94,11 +121,12 @@ Opaleye supports it also.  > insertReturning :: String-> insertReturning = arrangeInsertReturningSql def' table (Nothing, 4, 5)->                                             (\(id_, _, _) -> id_)->                   -- TODO: vv This is too messy->                   where def' :: U.Unpackspec (Column a) (Column a)->                         def' = def+> insertReturning =+>   arrangeInsertManyReturningSql def' table (return (Nothing, 4, 5, P.pgString "Bye"))+>                                            (\(id_, _, _, _) -> id_)+>   -- TODO: vv This is too messy+>   where def' :: U.Unpackspec (Column a) (Column a)+>         def' = def  ghci> putStrLn insertReturning INSERT INTO tablename (x,@@ -113,12 +141,11 @@  This tutorial has only shown you how to generate the SQL string for manipulation queries.  In practice you actually want to run them!  To-run them you should use `runInsert` instead of `arrangeInsertSql`,+run them you should use `runInsertMany` instead of `arrangeInsertManySql`, `runDelete` instead of `arrangeDeleteSql`, etc..   Comments ======== -Opaleye does not currently support inserting more than one row at-once, or SELECT-valued INSERT or UPDATE.+Opaleye does not currently support SELECT-valued INSERT or UPDATE.

@@ -1,4 +1,4 @@-Copyright (c) 2014-2015 Purely Agile Limited+Copyright (c) 2014-2016 Purely Agile Limited  All rights reserved. 

@@ -10,6 +10,11 @@ composition (i.e. what is wonderful about Haskell)" – Daniel Patterson, [Position Development](http://positiondev.com/) +> "We use it for most of our DB code. It's very flexible and almost+  always as performant as manually written queries" – [Adam+  Bergmark](http://ircbrowse.net/browse/haskell?id=22634197&timestamp=1460980502#t1460980502),+  [Silk.co](http://www.silk.co/)+ Opaleye allows you to define your database tables and write queries against them in Haskell code, and aims to be typesafe in the sense that if your code compiles then the generated SQL query will not fail

@@ -31,3 +31,4 @@ * 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

@@ -40,9 +40,14 @@ columnsOfHaskells :: Haskells -> Columns columnsOfHaskells = O.constantExplicit eitherPP +columnsList :: (a, b) -> [Either a b]+columnsList (x, y) = [Left x, Right y]+ 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)] }@@ -56,7 +61,8 @@ unpackColumns = eitherPP  instance Show ArbitraryQuery where-  show (ArbitraryQuery q) = O.showSqlForPostgresExplicit unpackColumns q+  show (ArbitraryQuery q) = maybe "Empty query" id+                              (O.showSqlForPostgresExplicit unpackColumns q)  instance Show ArbitraryGarble where   show = const "A permutation"@@ -94,6 +100,9 @@     , 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 @@ -104,6 +113,15 @@                              ++ map (return . Right) [False, True]))     return (ArbitraryColumns l) +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)+ instance TQ.Arbitrary ArbitraryPositiveInt where   arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100)) @@ -174,6 +192,9 @@ instance Functor QueryDenotation where   fmap f = QueryDenotation . (fmap . fmap . fmap) f .unQueryDenotation +pureList :: [a] -> QueryDenotation a+pureList = QueryDenotation . pure . pure+ instance Applicative QueryDenotation where   pure    = QueryDenotation . pure . pure . pure   f <*> x = QueryDenotation ((liftA2 . liftA2 . liftA2) ($)@@ -302,6 +323,29 @@   compare' conn (denotation' (restrictFirstBool Arrow.<<< q))                 (onList restrictFirstBoolList (denotation' q)) +values :: PGS.Connection -> ArbitraryColumnsList -> IO Bool+values conn (ArbitraryColumnsList l) = do+  compareNoSort conn (denotation' (fmap columnsList (O.values (fmap O.constant l))))+                     (pureList (fmap columnsList l))++{- TODO++  * Aggregation+  * Binary operations+      * union+      * unionAll+      * intersect+      * intersectAll+      * except+      * exceptAll+  * Nullability+  * Left join+  * Label (check it has no effect)+  * Operators (mathematical, logical, etc.)+  * >>>?++-}+ -- }  -- { Running the QuickCheck@@ -337,6 +381,7 @@   test2 order   test1 distinct   test1 restrict+  test1 values  -- } 

@@ -1,5 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}  module Main where @@ -7,6 +8,7 @@  import           Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>)) import qualified Opaleye as O+import qualified Opaleye.Internal.Aggregate as IA  import qualified Database.PostgreSQL.Simple as PGS import qualified Data.Profunctor.Product.Default as D@@ -16,10 +18,12 @@ import qualified Data.List as L import           Data.Monoid ((<>)) import qualified Data.String as String+import qualified Data.Time   as Time  import qualified System.Exit as Exit import qualified System.Environment as Environment +import           Control.Applicative ((<$>), (<*>)) import qualified Control.Applicative as A import qualified Control.Arrow as Arr import           Control.Arrow ((&&&), (***), (<<<), (>>>))@@ -142,6 +146,9 @@ table6 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText) table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2")) +table7 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText)+table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2"))+ tableKeywordColNames :: O.Table (Column O.PGInt4, Column O.PGInt4)                                 (Column O.PGInt4, Column O.PGInt4) tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where"))@@ -158,6 +165,9 @@ table6Q :: Query (Column O.PGText, Column O.PGText) table6Q = O.queryTable table6 +table7Q :: Query (Column O.PGText, Column O.PGText)+table7Q = O.queryTable table7+ table1dataG :: Num a => [(a, a)] table1dataG = [ (1, 100)               , (1, 100)@@ -205,6 +215,12 @@ table6columndata :: [(Column O.PGText, Column O.PGText)] table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data +table7data :: [(String, String)]+table7data = [("foo", "c"), ("bar", "a"), ("baz", "b")]++table7columndata :: [(Column O.PGText, Column O.PGText)]+table7columndata = map (O.pgString *** O.pgString) table7data+ -- 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@@ -245,13 +261,16 @@ serialTables :: [Table_] serialTables = map columns2 ["table5"] +textTables :: [Table_]+textTables = map columns2 ["table6", "table7"]+ dropAndCreateDB :: PGS.Connection -> IO () dropAndCreateDB conn = do   mapM_ execute tables-  _ <- executeTextTable+  mapM_ executeTextTable textTables   mapM_ executeSerial serialTables   where execute = PGS.execute_ conn . dropAndCreateTableInt-        executeTextTable = (PGS.execute_ conn . dropAndCreateTableText . columns2) "table6"+        executeTextTable = PGS.execute_ conn . dropAndCreateTableText         executeSerial = PGS.execute_ conn . dropAndCreateTableSerial  type Test = PGS.Connection -> IO Bool@@ -334,6 +353,13 @@                                            table1Q)                       (\r -> [(1, 400) :: (Int, Int64), (2, 300)] == L.sort r) +testAggregate0 :: Test+testAggregate0 = testG (Arr.second aggregateCoerceFIXME+                        <<< O.aggregate (PP.p2 (O.sum, O.sum))+                                        (O.keepWhen (const (O.pgBool False))+                                         <<< table1Q))+                      (== ([] :: [(Int, Int64)]))+ testAggregateFunction :: Test testAggregateFunction = testG (Arr.second aggregateCoerceFIXME                         <<< O.aggregate (PP.p2 (O.groupBy, O.sum))@@ -360,6 +386,56 @@           (foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data ,           head (map snd table6data))] == r +-- | Using aggregateOrdered applies the ordering to all aggregates.++testStringArrayAggregateOrdered :: Test+testStringArrayAggregateOrdered = testG q expected+  where q = O.aggregateOrdered (O.asc snd) (PP.p2 (O.arrayAgg, O.stringAgg . O.pgString $ ",")) table7Q+        expected r = [( map fst sortedData+                      , L.intercalate "," . map snd $ sortedData+                      )+                     ] == r+        sortedData = L.sortBy (Ord.comparing snd) table7data++-- | Using orderAggregate you can apply different orderings to+-- different aggregates.++testMultipleAggregateOrdered :: Test+testMultipleAggregateOrdered = testG q 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 $ ","))+                        ) table7Q+        expected r = [( map fst . L.sortBy (Ord.comparing snd) $ table7data+                      , L.intercalate "," . map snd . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data+                      )+                     ] == r++-- | Applying an order to an ordered aggregate overwrites the old+-- order, just like with ordered queries.+--+testOverwriteAggregateOrdered :: Test+testOverwriteAggregateOrdered = testG q expected+  where q = O.aggregate ( IA.orderAggregate (O.asc snd)+                        . IA.orderAggregate (O.desc snd)+                        $ PP.p2 (O.arrayAgg, O.max)+                        ) table7Q+        expected r = [( map fst (L.sortBy (Ord.comparing snd) table7data)+                      , maximum (map snd table7data)+                      )+                     ] == r++testCountRows0 :: Test+testCountRows0 = testG q expected+  where q        = O.countRows (O.keepWhen (const (O.pgBool False)) <<< table7Q)+        expected = (== [0 :: Int64])++testCountRows3 :: Test+testCountRows3 = testG q expected+  where q        = O.countRows table7Q+        expected = (== [3 :: Int64])+ testOrderByG :: O.Order (Column O.PGInt4, Column O.PGInt4)                 -> ((Int, Int) -> (Int, Int) -> Ordering)                 -> Test@@ -520,7 +596,7 @@     if resultD /= expectedD       then return False       else do-      returned <- O.runInsertReturning conn table4 insertT returning+      returned <- O.runInsertManyReturning conn table4 insertT returning       _ <- O.runInsertMany conn table4 insertTMany       resultI <- runQueryTable4 @@ -536,17 +612,17 @@         expectedD = [(1, 10)]         runQueryTable4 = O.runQuery conn (O.queryTable table4) -        insertT :: (Column O.PGInt4, Column O.PGInt4)-        insertT = (1, 2)+        insertT :: [(Column O.PGInt4, Column O.PGInt4)]+        insertT = [(1, 2), (3, 5)]          insertTMany :: [(Column O.PGInt4, Column O.PGInt4)]         insertTMany = [(20, 30), (40, 50)]          expectedI :: [(Int, Int)]-        expectedI = [(1, 10), (1, 2), (20, 30), (40, 50)]+        expectedI = [(1, 10), (1, 2), (3, 5), (20, 30), (40, 50)]         returning (x, y) = x - y         expectedR :: [Int]-        expectedR = [-1]+        expectedR = [-1, -2]  testKeywordColNames :: Test testKeywordColNames conn = do@@ -572,18 +648,54 @@                    , (1, 2)                    , (2, 40) ] +testInQuery :: Test+testInQuery conn = do+  let q (x, e) = testG (O.inQuery x (O.queryTable table1)) (== [e]) conn++  r <- mapM (q . (\x ->      (x,        True)))  table1dataG+  s <- mapM (q . (\(x, y) -> ((x, y+1), False))) table1dataG++  return (and r && and s)++testAtTimeZone :: Test+testAtTimeZone = testG (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (== [t'])+  where t = O.pgUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))+        t' = Time.LocalTime d (Time.TimeOfDay 2 0 0)+        d = Time.fromGregorian 2015 1 1++testArrayLiterals :: Test+testArrayLiterals = testG (A.pure $ O.pgArray O.pgInt4 vals) (== [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 = testG (A.pure $ O.pgArray O.pgInt4 []) (== [[] :: [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 = testG (A.pure $ O.pgArray O.pgDouble doubles) (== [doubles])+  where+    doubles = [1 :: Double, 2]+ allTests :: [Test] allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase,-            testDistinct, testAggregate, testAggregateFunction,-            testAggregateProfunctor, testStringAggregate,+            testDistinct, testAggregate, testAggregate0, testAggregateFunction,+            testAggregateProfunctor, testStringArrayAggregate, testStringAggregate,             testOrderBy, testOrderBy2, testOrderBySame, testLimit, testOffset,             testLimitOffset, testOffsetLimit, testDistinctAndAggregate,             testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin,             testDoubleValues, testDoubleUnionAll,             testLeftJoin, testLeftJoinNullable, testThreeWayProduct, testValues,             testValuesEmpty, testUnionAll, testTableFunctor, testUpdate,-            testKeywordColNames, testInsertSerial-           ]+            testKeywordColNames, testInsertSerial, testInQuery, testAtTimeZone,+            testStringArrayAggregateOrdered, testMultipleAggregateOrdered,+            testOverwriteAggregateOrdered, testCountRows0, testCountRows3,+            testArrayLiterals, testEmptyArray, testFloatArray+            ]  -- Environment.getEnv throws an exception on missing environment variable! getEnv :: String -> IO (Maybe String)@@ -619,6 +731,7 @@                , (table3, table3columndata)                , (table4, table4columndata) ]   insert (table6, table6columndata)+  insert (table7, table7columndata)    -- Need to run quickcheck after table data has been inserted   QuickCheck.run conn

@@ -1,6 +1,6 @@ name:            opaleye-copyright:       Copyright (c) 2014-2015 Purely Agile Limited-version:         0.4.2.0+copyright:       Copyright (c) 2014-2016 Purely Agile Limited+version:         0.5.0.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@@ -27,21 +27,21 @@   build-depends:       -- attoparsec can be removed once postgresql-simple patch in       -- Internal.RunQuery is merged upstream-      aeson               >= 0.6     && < 0.11+      aeson               >= 0.6     && < 0.12     , attoparsec          >= 0.10.3  && < 0.14     , base                >= 4       && < 5     , base16-bytestring   >= 0.1.1.6 && < 0.2     , case-insensitive    >= 1.2     && < 1.3     , bytestring          >= 0.10    && < 0.11-    , contravariant       >= 1.2     && < 1.4-    , postgresql-simple   >= 0.4.8.0 && < 0.6+    , contravariant       >= 1.2     && < 1.5+    , postgresql-simple   >= 0.5     && < 0.6     , pretty              >= 1.1.1.0 && < 1.2-    , product-profunctors >= 0.6.2   && < 0.7-    , profunctors         >= 4.0     && < 5.2-    , semigroups          >= 0.13    && < 0.18+    , product-profunctors >= 0.6.2   && < 0.8+    , profunctors         >= 4.0     && < 5.3+    , semigroups          >= 0.13    && < 0.19     , text                >= 0.11    && < 1.3-    , transformers        >= 0.3     && < 0.5-    , time                >= 1.4     && < 1.6+    , transformers        >= 0.3     && < 0.6+    , time                >= 1.4     && < 1.7     , time-locale-compat  >= 0.1     && < 0.2     , uuid                >= 1.3     && < 1.4     , void                >= 0.4     && < 0.8@@ -52,6 +52,7 @@                    Opaleye.Constant,                    Opaleye.Distinct,                    Opaleye.Join,+                   Opaleye.Label,                    Opaleye.Manipulation,                    Opaleye.Operators,                    Opaleye.Order,@@ -67,6 +68,7 @@                    Opaleye.Internal.Distinct,                    Opaleye.Internal.Helpers,                    Opaleye.Internal.Join,+                   Opaleye.Internal.Label,                    Opaleye.Internal.Order,                    Opaleye.Internal.Operators,                    Opaleye.Internal.Optimize,@@ -104,6 +106,7 @@     product-profunctors,     QuickCheck,     semigroups,+    time,     opaleye   ghc-options: -Wall @@ -113,6 +116,8 @@   other-modules: TutorialAdvanced,                  TutorialBasic,                  TutorialManipulation,+                 TutorialBasicMonomorphic,+                 TutorialBasicTypeFamilies,                  DefaultExplanation   hs-source-dirs: Doc/Tutorial   build-depends:

@@ -4,6 +4,7 @@                , module Opaleye.Constant                , module Opaleye.Distinct                , module Opaleye.Join+               , module Opaleye.Label                , module Opaleye.Manipulation                , module Opaleye.Operators                , module Opaleye.Order@@ -21,6 +22,7 @@ import Opaleye.Constant import Opaleye.Distinct import Opaleye.Join+import Opaleye.Label import Opaleye.Manipulation import Opaleye.Operators import Opaleye.Order

@@ -1,16 +1,21 @@ -- | Perform aggregations on query results. module Opaleye.Aggregate (module Opaleye.Aggregate, Aggregator) where +import           Control.Applicative (pure)+import           Data.Profunctor     (lmap)+ import qualified Opaleye.Internal.Aggregate as A-import           Opaleye.Internal.Aggregate (Aggregator)+import           Opaleye.Internal.Aggregate (Aggregator, orderAggregate) import qualified Opaleye.Internal.Column as IC-import           Opaleye.QueryArr (Query) import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Column as C-import qualified Opaleye.Order as Ord-import qualified Opaleye.PGTypes as T import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import           Opaleye.QueryArr  (Query)+import qualified Opaleye.Column    as C+import qualified Opaleye.Order     as Ord+import qualified Opaleye.PGTypes   as T+import qualified Opaleye.Join      as J+ -- This page of Postgres documentation tell us what aggregate -- functions are available --@@ -20,10 +25,36 @@ Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of type @a@, apply the aggregator to the results of the query. +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.+(Opaleye's behaviour is consistent with the meaning of aggregating+over groups of rows and Postgres's behaviour is inconsistent.  When a+query has zero rows it has zero groups, and thus zero rows in the+result of an aggregation.)++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' ->+QueryArr a b -> QueryArr a b'@.  Such a function would allow violation+of SQL's scoping rules and lead to invalid queries. -} aggregate :: Aggregator a b -> Query a -> Query b aggregate agg q = Q.simpleQueryArr (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+-- depend on the order they get their elements, like `arrayAgg` and+-- `stringAgg`.+--+-- Note that this orders all aggregations with the same ordering. If+-- you need different orderings for different aggregations, use+-- 'Opaleye.Internal.Aggregate.orderAggregate'.++aggregateOrdered  :: Ord.Order a -> Aggregator a b -> Query a -> Query b+aggregateOrdered o agg = aggregate (orderAggregate o agg)+ -- | Group the aggregation by equality on the input to 'groupBy'. groupBy :: Aggregator (C.Column a) (C.Column a) groupBy = A.makeAggr' Nothing@@ -36,6 +67,11 @@ count :: Aggregator (C.Column a) (C.Column T.PGInt8) count = A.makeAggr HPQ.AggrCount +-- | Count the number of rows in a group.  This 'Aggregator' is named+-- @countStar@ after SQL's @COUNT(*)@ aggregation function.+countStar :: Aggregator a (C.Column T.PGInt8)+countStar = lmap (const (0 :: C.Column T.PGInt4)) count+ -- | Average of a group avg :: Aggregator (C.Column T.PGFloat8) (C.Column T.PGFloat8) avg = A.makeAggr HPQ.AggrAvg@@ -59,3 +95,25 @@  stringAgg :: C.Column T.PGText -> Aggregator (C.Column T.PGText) (C.Column T.PGText) stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn++-- | Count the number of rows in a query.  This is different from+-- 'aggregate' 'count' because it always returns exactly one row, even+-- when the input query is empty.++-- This is currently implemented in a cheeky way with a LEFT JOIN.  If+-- there are any performance issues it could be rewritten to use an+-- SQL COUNT aggregation which groups by nothing.  This would require+-- changing the AST though, so I'm not too keen.+--+-- See https://github.com/tomjaguarpaw/haskell-opaleye/issues/162+countRows :: Query a -> Query (C.Column T.PGInt8)+countRows = fmap (C.fromNullable 0)+            . fmap snd+            . (\q -> J.leftJoin (pure ())+                                (aggregate count q)+                                (const (T.pgBool True)))+            . fmap (const (0 :: C.Column T.PGInt4))+            --- ^^ The count aggregator requires an input of type+            -- 'Column a' rather than 'a' (I'm not sure if there's a+            -- good reason for this).  To deal with that restriction+            -- we just map a dummy integer value over it.

@@ -3,11 +3,8 @@ module Opaleye.Binary where  import           Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Binary as B-import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM  import           Data.Profunctor.Product.Default (Default, def) @@ -26,19 +23,66 @@ --          -> Query (Foo (Column a) (Column b) (Column c)) --          -> Query (Foo (Column a) (Column b) (Column c)) -- @+--+-- By design there is no union function of type @QueryArr a b ->+-- QueryArr a b -> QueryArr a b@.  Such a function would allow+-- violation of SQL's scoping rules and lead to invalid queries. unionAll :: Default B.Binaryspec columns columns =>             Query columns -> Query columns -> Query columns unionAll = unionAllExplicit def  unionAllExplicit :: B.Binaryspec columns columns'                  -> Query columns -> Query columns -> Query columns'-unionAllExplicit binaryspec q1 q2 = Q.simpleQueryArr q where-  q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)-    where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)-          (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)+unionAllExplicit = B.sameTypeBinOpHelper PQ.UnionAll -          (newColumns, pes) =-            PM.run (B.runBinaryspec binaryspec (B.extractBinaryFields endTag)-                                    (columns1, columns2)) -          newPrimQuery = PQ.Binary PQ.UnionAll pes (primQuery1, primQuery2)+-- | The same as unionAll, except that it additionally removes any+--   duplicate rows.+union :: Default B.Binaryspec columns columns =>+         Query columns -> Query columns -> Query columns+union = unionExplicit def++unionExplicit :: B.Binaryspec columns columns'+              -> Query columns -> Query columns -> Query columns'+unionExplicit = B.sameTypeBinOpHelper PQ.Union++++intersectAll :: Default B.Binaryspec columns columns =>+            Query columns -> Query columns -> Query columns+intersectAll = intersectAllExplicit def++intersectAllExplicit :: B.Binaryspec columns columns'+                 -> Query columns -> Query columns -> Query columns'+intersectAllExplicit = B.sameTypeBinOpHelper PQ.IntersectAll+++-- | The same as intersectAll, except that it additionally removes any+--   duplicate rows.+intersect :: Default B.Binaryspec columns columns =>+         Query columns -> Query columns -> Query columns+intersect = intersectExplicit def++intersectExplicit :: B.Binaryspec columns columns'+              -> Query columns -> Query columns -> Query columns'+intersectExplicit = B.sameTypeBinOpHelper PQ.Intersect+++exceptAll :: Default B.Binaryspec columns columns =>+            Query columns -> Query columns -> Query columns+exceptAll = exceptAllExplicit def++exceptAllExplicit :: B.Binaryspec columns columns'+                 -> Query columns -> Query columns -> Query columns'+exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll+++-- | The same as exceptAll, except that it additionally removes any+--   duplicate rows.+except :: Default B.Binaryspec columns columns =>+         Query columns -> Query columns -> Query columns+except = exceptExplicit def++exceptExplicit :: B.Binaryspec columns columns'+              -> Query columns -> Query columns -> Query columns'+exceptExplicit = B.sameTypeBinOpHelper PQ.Except

@@ -1,12 +1,13 @@ module Opaleye.Column (module Opaleye.Column,                        Column,                        Nullable,+                       unsafeCast,                        unsafeCoerce,                        unsafeCoerceColumn,                        unsafeCompositeField)  where  import           Opaleye.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn,-                                          unsafeCompositeField)+                                          unsafeCast, unsafeCompositeField) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.PGTypes as T@@ -44,10 +45,3 @@ -- provided value coerced to a nullable type. maybeToNullable :: Maybe (Column a) -> Column (Nullable a) maybeToNullable = maybe null toNullable---- | Cast a column to any other type. This is safe for some conversions such as uuid to text.-unsafeCast :: String -> C.Column a -> Column b-unsafeCast = mapColumn . HPQ.CastExpr-  where-    mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a-    mapColumn primExpr c = C.Column (primExpr (C.unColumn c))

@@ -22,6 +22,7 @@ import qualified Data.Profunctor                 as P  import           Control.Applicative (Applicative, pure, (<*>))+import           Data.Functor                    ((<$>))   newtype Constant haskells columns =@@ -54,6 +55,9 @@ instance D.Default Constant Int (Column T.PGInt4) where   def = Constant T.pgInt4 +instance D.Default Constant Int.Int32 (Column T.PGInt4) where+  def = Constant $ T.pgInt4 . fromIntegral+ instance D.Default Constant Int.Int64 (Column T.PGInt8) where   def = Constant T.pgInt8 @@ -101,6 +105,13 @@  instance D.Default Constant Ae.Value (Column T.PGJsonb) where   def = Constant T.pgValueJSONB++instance D.Default Constant haskell (Column sql) => D.Default Constant (Maybe haskell) (Maybe (Column sql)) where+  def = Constant (constant <$>)++instance (D.Default Constant a (Column b), T.IsSqlType b)+         => D.Default Constant [a] (Column (T.PGArray b)) where+  def = Constant (T.pgArray (constantExplicit D.def))  -- { Boilerplate instances 

@@ -21,6 +21,10 @@ -- @ -- distinct :: Query (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) -- @+--+-- By design there is no distinct function of type @QueryArr a b ->+-- QueryArr a b@.  Such a function would allow violation of SQL's+-- scoping rules and lead to invalid queries. distinct :: D.Default Distinctspec columns columns =>             Query columns -> Query columns distinct = distinctExplicit D.def

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} module Opaleye.Internal.Aggregate where  import           Control.Applicative (Applicative, pure, (<*>))@@ -9,6 +10,7 @@ import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.Order as O  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ @@ -23,18 +25,57 @@ takes a list of @a@ and returns a single row of type @b@. -} newtype Aggregator a b = Aggregator-                         (PM.PackMap (Maybe HPQ.AggrOp, HPQ.PrimExpr) HPQ.PrimExpr+                         (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), 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 (m, e))))+                          (\f (C.Column e) -> fmap C.Column (f (fmap (,[]) m, e))))  makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b) makeAggr = makeAggr' . Just +-- | Order the values within each aggregation in `Aggregator` using+-- the given ordering. This is only relevant for aggregations that+-- depend on the order they get their elements, like+-- `Opaleye.Aggregate.arrayAgg` and `Opaleye.Aggregate.stringAgg`.+--+-- You can either apply it to an aggregation of multiple columns, in+-- which case it will apply to all aggregation functions in there, or you+-- can apply it to a single column, and then compose the aggregations+-- afterwards. Examples:+--+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray a))+-- > x = (,) <$> orderAggregate (asc snd) (lmap fst arrayAggGrouped)+-- >         <*> orderAggregate (desc snd) (lmap fst arrayAggGrouped)+--+-- This will generate:+--+-- @+-- SELECT array_agg(a ORDER BY b ASC), array_agg(a ORDER BY b DESC)+-- FROM (SELECT a, b FROM ...)+-- @+--+-- Or:+--+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray b))+-- > x = orderAggregate (asc snd) $ p2 (arrayAggGrouped, arrayAggGrouped)+--+-- This will generate:+--+-- @+-- SELECT array_agg(a ORDER BY b ASC), array_agg(b ORDER BY b ASC)+-- FROM (SELECT a, b FROM ...)+-- @++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 (P.second' (const $ O.orderExprs c o)))) c))+ runAggregator :: Applicative f => Aggregator a b-              -> ((Maybe HPQ.AggrOp, HPQ.PrimExpr) -> f HPQ.PrimExpr) -> a -> f b+              -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr) -> f HPQ.PrimExpr)+              -> a -> f b runAggregator (Aggregator a) = PM.traversePM a  aggregateU :: Aggregator a b@@ -45,8 +86,8 @@          primQ' = PQ.Aggregate projPEs primQ -extractAggregateFields :: T.Tag -> (Maybe HPQ.AggrOp, HPQ.PrimExpr)-      -> PM.PM [(HPQ.Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] HPQ.PrimExpr+extractAggregateFields :: T.Tag -> (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr)+      -> PM.PM [(HPQ.Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] HPQ.PrimExpr extractAggregateFields = PM.extractAttr "result"  -- { Boilerplate instances

@@ -5,6 +5,8 @@ import           Opaleye.Internal.Column (Column(Column)) import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.PrimQuery as PQ  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ @@ -33,6 +35,19 @@ binaryspecColumn :: Binaryspec (Column a) (Column a) binaryspecColumn = Binaryspec (PM.PackMap (\f (Column e, Column e')                                            -> fmap Column (f (e, e'))))++sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'+                    -> Q.Query columns -> Q.Query columns -> Q.Query columns'+sameTypeBinOpHelper binop binaryspec q1 q2 = Q.simpleQueryArr q where+  q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)+    where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)+          (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)++          (newColumns, pes) =+            PM.run (runBinaryspec binaryspec (extractBinaryFields endTag)+                                    (columns1, columns2))++          newPrimQuery = PQ.Binary binop pes (primQuery1, primQuery2)  instance Default Binaryspec (Column a) (Column a) where   def = binaryspecColumn

@@ -1,5 +1,7 @@ module Opaleye.Internal.Column where +import Data.String+ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ  -- | Numeric 'Column' types are instances of 'Num', so you can use@@ -18,6 +20,13 @@ unsafeCoerceColumn :: Column a -> Column b unsafeCoerceColumn (Column e) = Column e +-- | Cast a column to any other type. This is safe for some conversions such as uuid to text.+unsafeCast :: String -> Column a -> Column b+unsafeCast = mapColumn . HPQ.CastExpr+  where+    mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a+    mapColumn primExpr c = Column (primExpr (unColumn c))+ unsafeCompositeField :: Column a -> String -> Column b unsafeCompositeField (Column e) fieldName =   Column (HPQ.CompositeExpr e fieldName)@@ -64,3 +73,11 @@ instance (PGNum a, PGFractional a) => Fractional (Column a) where   fromRational = pgFromRational   (/) = binOp HPQ.OpDiv++class PGIntegral a++class PGString a where+    pgFromString :: String -> Column a++instance PGString a => IsString (Column a) where+  fromString = pgFromString

@@ -20,7 +20,7 @@                 | CompositeExpr     PrimExpr Attribute -- ^ Composite Type Query                 | BinExpr   BinOp PrimExpr PrimExpr                 | UnExpr    UnOp PrimExpr-                | AggrExpr  AggrOp PrimExpr+                | AggrExpr  AggrOp PrimExpr [OrderExpr]                 | ConstExpr Literal                 | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr                 | ListExpr [PrimExpr]@@ -32,6 +32,7 @@                                     -- TODO: I'm not sure this belongs                                     -- here.  Perhaps a special type is                                     -- needed for insert expressions.+                | ArrayExpr [PrimExpr] -- ^ ARRAY[..]                 deriving (Read,Show)  data Literal = NullLit@@ -52,7 +53,7 @@                 | OpCat                 | OpPlus | OpMinus | OpMul | OpDiv | OpMod                 | OpBitNot | OpBitAnd | OpBitOr | OpBitXor-                | OpAsg+                | OpAsg | OpAtTimeZone                 deriving (Show,Read)  data UnOp = OpNot@@ -73,14 +74,14 @@                 deriving (Show,Read)  data OrderExpr = OrderExpr OrderOp PrimExpr-               deriving (Show)+               deriving (Show,Read)  data OrderNulls = NullsFirst | NullsLast-                deriving Show+                deriving (Show,Read)  data OrderDirection = OpAsc | OpDesc-                    deriving Show+                    deriving (Show,Read)  data OrderOp = OrderOp { orderDirection :: OrderDirection                        , orderNulls     :: OrderNulls }-               deriving (Show)+               deriving (Show,Read)

@@ -38,7 +38,7 @@              | PrefixSqlExpr  String SqlExpr              | PostfixSqlExpr String SqlExpr              | FunSqlExpr     String [SqlExpr]-             | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions.+             | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] -- ^ Aggregate functions separate from normal functions.              | ConstSqlExpr   String              | CaseSqlExpr    [(SqlExpr,SqlExpr)] SqlExpr              | ListSqlExpr    [SqlExpr]@@ -47,6 +47,7 @@              | ParensSqlExpr SqlExpr              | CastSqlExpr String SqlExpr              | DefaultSqlExpr+             | ArraySqlExpr [SqlExpr]   deriving Show  -- | Data type for SQL UPDATE statements.

@@ -4,6 +4,8 @@  module Opaleye.Internal.HaskellDB.Sql.Default  where +import Control.Applicative ((<$>))+ import Opaleye.Internal.HaskellDB.PrimQuery import qualified Opaleye.Internal.HaskellDB.PrimQuery as PQ import Opaleye.Internal.HaskellDB.Sql@@ -118,12 +120,13 @@       -- because it leads to a non-uniformity of treatment, as seen       -- below.  Perhaps we should have just `AggrExpr AggrOp` and       -- always put the `PrimExpr` in the `AggrOp`.-      AggrExpr op e    -> let op' = showAggrOp op-                              e' = sqlExpr gen e-                              moreAggrFunParams = case op of-                                AggrStringAggr primE -> [sqlExpr gen primE]-                                _ -> []-                           in AggrFunSqlExpr op' (e' : moreAggrFunParams)+      AggrExpr op e ord -> let op' = showAggrOp op+                               e' = sqlExpr gen e+                               ord' = toSqlOrder gen <$> ord+                               moreAggrFunParams = case op of+                                 AggrStringAggr primE -> [sqlExpr gen primE]+                                 _ -> []+                            in AggrFunSqlExpr op' (e' : moreAggrFunParams) ord'       ConstExpr l      -> ConstSqlExpr (sqlLiteral gen l)       CaseExpr cs e    -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs]                               e'  = sqlExpr gen e@@ -133,6 +136,7 @@       FunExpr n exprs  -> FunSqlExpr n (map (sqlExpr gen) exprs)       CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1)       DefaultInsertExpr -> DefaultSqlExpr+      ArrayExpr es -> ArraySqlExpr (map (sqlExpr gen) es)  showBinOp :: BinOp -> String showBinOp  OpEq         = "="@@ -157,6 +161,7 @@ showBinOp  OpBitOr      = "|" showBinOp  OpBitXor     = "^" showBinOp  OpAsg        = "="+showBinOp  OpAtTimeZone = "AT TIME ZONE"   data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix@@ -201,7 +206,10 @@                     -> binQuote s       StringLit s   -> quote s       IntegerLit i  -> show i-      DoubleLit d   -> show d+      DoubleLit d   -> if isNaN d then "'NaN'"+                       else if isInfinite d && d < 0 then "'-Infinity'"+                       else if isInfinite d && d > 0 then "'Infinity'"+                       else show d       OtherLit o    -> o  

@@ -26,7 +26,7 @@ import qualified Data.List.NonEmpty as NEL import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, doubleQuotes,                                   empty, equals, hcat, hsep, parens, punctuate,-                                  text, vcat)+                                  text, vcat, brackets)  -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first -- column.  We need an identity function, but due to@@ -123,7 +123,7 @@       PrefixSqlExpr op e  -> text op <+> ppSqlExpr e       PostfixSqlExpr op e -> ppSqlExpr e <+> text op       FunSqlExpr f es     -> text f <> parens (commaH ppSqlExpr es)-      AggrFunSqlExpr f es     -> text f <> parens (commaH ppSqlExpr es)+      AggrFunSqlExpr f es ord -> text f <> parens (commaH ppSqlExpr es <+> ppOrderBy ord)       ConstSqlExpr c      -> text c       CaseSqlExpr cs el   -> text "CASE" <+> vcat (map ppWhen cs)                              <+> text "ELSE" <+> ppSqlExpr el <+> text "END"@@ -134,6 +134,7 @@       PlaceHolderSqlExpr -> text "?"       CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ)       DefaultSqlExpr    -> text "DEFAULT"+      ArraySqlExpr es -> text "ARRAY" <> brackets (commaH ppSqlExpr es)  commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f

@@ -7,8 +7,10 @@ import           Opaleye.Internal.Column (Column, Nullable) import qualified Opaleye.Column as C +import qualified Control.Applicative as A+ import           Data.Profunctor (Profunctor, dimap)-import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))+import qualified Data.Profunctor.Product as PP import qualified Data.Profunctor.Product.Default as D  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ@@ -30,11 +32,18 @@  -- { Boilerplate instances +instance Functor (NullMaker a) where+  fmap f (NullMaker g) = NullMaker (fmap f g)++instance A.Applicative (NullMaker a) where+  pure = NullMaker . A.pure+  NullMaker f <*> NullMaker x = NullMaker (f A.<*> x)+ instance Profunctor NullMaker where   dimap f g (NullMaker h) = NullMaker (dimap f g h) -instance ProductProfunctor NullMaker where-  empty = NullMaker empty-  NullMaker f ***! NullMaker f' = NullMaker (f ***! f')+instance PP.ProductProfunctor NullMaker where+  empty  = PP.defaultEmpty+  (***!) = PP.defaultProfunctorProduct  --

@@ -0,0 +1,7 @@+module Opaleye.Internal.Label where++import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.PrimQuery as PQ++label' :: String -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+label' l (x, q, t) = (x, PQ.Label l q, t)

@@ -1,27 +1,29 @@+{-# LANGUAGE LambdaCase #-}+ module Opaleye.Internal.Optimize where  import           Prelude hiding (product)  import qualified Opaleye.Internal.PrimQuery as PQ+import           Opaleye.Internal.Helpers   ((.:))  import qualified Data.List.NonEmpty as NEL -optimize :: PQ.PrimQuery -> PQ.PrimQuery+import           Control.Applicative ((<$>), (<*>), pure)+import qualified Data.Traversable    as T++optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a optimize = mergeProduct . removeUnit -removeUnit :: PQ.PrimQuery -> PQ.PrimQuery-removeUnit = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,-                                PQ.Order, PQ.Limit, PQ.Join, PQ.Values,-                                PQ.Binary)+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.filter (not . PQ.isUnit) pqs of-                         [] -> return PQ.Unit-                         xs -> NEL.fromList xs+          where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit) pqs) of+                         Nothing -> return PQ.Unit+                         Just xs -> xs -mergeProduct :: PQ.PrimQuery -> PQ.PrimQuery-mergeProduct = PQ.foldPrimQuery (PQ.Unit, PQ.BaseTable, product, PQ.Aggregate,-                                PQ.Order, PQ.Limit, PQ.Join, PQ.Values,-                                PQ.Binary)+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@@ -29,3 +31,35 @@                 pes' = NEL.toList pqs >>= conds                 conds (PQ.Product _ cs) = cs                 conds _ = []++removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b)+removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold {+    PQ.unit      = return PQ.Unit+  , PQ.empty     = const Nothing+  , PQ.baseTable = return .: PQ.BaseTable+  , PQ.product   = \x y -> PQ.Product <$> (T.traverse removeEmpty+                                               =<< T.sequence x)+                                      <*> pure y+  , PQ.aggregate = fmap . PQ.Aggregate+  , PQ.order     = fmap . PQ.Order+  , PQ.limit     = fmap . PQ.Limit+  , PQ.join      = \jt pe pq1 pq2 -> PQ.Join jt pe <$> pq1 <*> pq2+  , PQ.values    = return .: PQ.Values+  , PQ.binary    = \case+      -- Some unfortunate duplication here+      PQ.Except       -> binary Just            (const Nothing) PQ.Except+      PQ.Union        -> binary Just            Just            PQ.Union+      PQ.Intersect    -> binary (const Nothing) (const Nothing) PQ.Intersect++      PQ.ExceptAll    -> binary Just            (const Nothing) PQ.ExceptAll+      PQ.UnionAll     -> binary Just            Just            PQ.UnionAll+      PQ.IntersectAll -> binary (const Nothing) (const Nothing) PQ.IntersectAll+  , PQ.label     = fmap . PQ.Label+  }+  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+          (Nothing, Nothing)   -> Nothing+          (Nothing, Just pq2)  -> n2 pq2+          (Just pq1, Nothing)  -> n1 pq1+          (Just pq1, Just pq2) -> Just (PQ.Binary jj exprs (pq1, pq2))

@@ -50,9 +50,11 @@  orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) orderByU os (columns, primQ, t) = (columns, primQ', t)-  where primQ' = PQ.Order orderExprs primQ-        Order sos = os-        orderExprs = map (uncurry HPQ.OrderExpr) (sos columns)+  where primQ' = PQ.Order oExprs primQ+        oExprs = orderExprs columns os++orderExprs :: a -> Order a -> [HPQ.OrderExpr]+orderExprs x (Order os) = map (uncurry HPQ.OrderExpr) (os x)  limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t)

@@ -40,8 +40,7 @@ -- '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.-data PackMap a b s t = PackMap (Applicative f =>-                                (a -> f b) -> s -> f t)+data 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@@ -135,8 +134,13 @@   (***!) = PP.defaultProfunctorProduct  instance PP.SumProfunctor (PackMap a b) where-  f +++! g = (PackMap (\x -> eitherFunction (f' x) (g' x)))-    where PackMap f' = f-          PackMap g' = g+  f +++! g =+    PackMap (\x ->+               case f of+                 PackMap f' ->+                   case g of+                     PackMap g' ->+                       eitherFunction (f' x)+                                      (g' x))  -- }

@@ -10,7 +10,14 @@ data LimitOp = LimitOp Int | OffsetOp Int | LimitOffsetOp Int Int              deriving Show -data BinOp = Except | Union | UnionAll deriving Show+data BinOp = Except+           | ExceptAll+           | Union+           | UnionAll+           | Intersect+           | IntersectAll+             deriving Show+ data JoinType = LeftJoin deriving Show  data TableIdentifier = TableIdentifier@@ -20,7 +27,7 @@  tiToSqlTable :: TableIdentifier -> HSql.SqlTable tiToSqlTable ti = HSql.SqlTable { HSql.sqlTableSchemaName = tiSchemaName ti-                                , HSql.sqlTableName = tiTableName ti }+                                , HSql.sqlTableName       = tiTableName ti }   -- In the future it may make sense to introduce this datatype@@ -28,42 +35,75 @@  -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check -- for emptiness explicity in the SQL generation phase.-data PrimQuery = Unit-               | BaseTable TableIdentifier [(Symbol, HPQ.PrimExpr)]-               | Product (NEL.NonEmpty PrimQuery) [HPQ.PrimExpr]-               | Aggregate [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] PrimQuery-               | Order [HPQ.OrderExpr] PrimQuery-               | Limit LimitOp PrimQuery-               | Join JoinType HPQ.PrimExpr PrimQuery PrimQuery-               | Values [Symbol] [[HPQ.PrimExpr]]-               | Binary BinOp [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery, PrimQuery)++-- The type parameter 'a' is used to control whether the 'Empty'+-- constructor can appear.  If 'a' = '()' then it can appear.  If 'a'+-- = 'Void' then it cannot.  When we create queries it is more+-- convenient to allow 'Empty', but it is hard to represent 'Empty' in+-- SQL so we remove it in 'Optimize' and set 'a = Void'.+data PrimQuery' a = Unit+                  | Empty     a+                  | BaseTable TableIdentifier [(Symbol, HPQ.PrimExpr)]+                  | Product   (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr]+                  | Aggregate [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))]+                              (PrimQuery' a)+                  | Order     [HPQ.OrderExpr] (PrimQuery' a)+                  | Limit     LimitOp (PrimQuery' a)+                  | Join      JoinType HPQ.PrimExpr (PrimQuery' a) (PrimQuery' a)+                  | Values    [Symbol] (NEL.NonEmpty [HPQ.PrimExpr])+                  | Binary    BinOp+                              [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]+                              (PrimQuery' a, PrimQuery' a)+                  | Label     String (PrimQuery' a)                  deriving Show -type PrimQueryFold p = ( p-                       , TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> p-                       , NEL.NonEmpty p -> [HPQ.PrimExpr] -> p-                       , [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> p -> p-                       , [HPQ.OrderExpr] -> p -> p-                       , LimitOp -> p -> p-                       , JoinType -> HPQ.PrimExpr -> p -> p -> p-                       , [Symbol] -> [[HPQ.PrimExpr]] -> p-                       , BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p-                       )+type PrimQuery = PrimQuery' ()+type PrimQueryFold = PrimQueryFold' () -foldPrimQuery :: PrimQueryFold p -> PrimQuery -> p-foldPrimQuery (unit, baseTable, product, aggregate, order, limit, join, values,-               binary) = fix fold+data PrimQueryFold' a p = PrimQueryFold+  { unit      :: p+  , empty     :: a -> p+  , baseTable :: TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> p+  , product   :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p+  , aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] -> p -> p+  , order     :: [HPQ.OrderExpr] -> p -> p+  , limit     :: LimitOp -> p -> p+  , join      :: JoinType -> HPQ.PrimExpr -> p -> p -> p+  , values    :: [Symbol] -> (NEL.NonEmpty [HPQ.PrimExpr]) -> p+  , binary    :: BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p+  , label     :: String -> p -> p+  }+++primQueryFoldDefault :: PrimQueryFold' a (PrimQuery' a)+primQueryFoldDefault = PrimQueryFold+  { unit      = Unit+  , empty     = Empty+  , baseTable = BaseTable+  , product   = Product+  , aggregate = Aggregate+  , order     = Order+  , limit     = Limit+  , join      = Join+  , values    = Values+  , binary    = Binary+  , label     = Label }++foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p+foldPrimQuery f = fix fold   where fold self primQ = case primQ of-          Unit                       -> unit-          BaseTable ti syms          -> baseTable ti syms-          Product pqs pes            -> product (fmap self pqs) pes-          Aggregate aggrs pq         -> aggregate aggrs (self pq)-          Order pes pq               -> order pes (self pq)-          Limit op pq                -> limit op (self pq)-          Join j cond q1 q2          -> join j cond (self q1) (self q2)-          Values ss pes              -> values ss pes-          Binary binop pes (pq, pq') -> binary binop pes (self pq, self pq')-        fix f = let x = f x in x+          Unit                      -> unit      f+          Empty a                   -> empty     f a+          BaseTable ti syms         -> baseTable f ti syms+          Product qs pes            -> product   f (fmap self qs) pes+          Aggregate aggrs q         -> aggregate f aggrs (self q)+          Order pes q               -> order     f pes (self q)+          Limit op q                -> limit     f op (self q)+          Join j cond q1 q2         -> join      f j cond (self q1) (self q2)+          Values ss pes             -> values    f ss pes+          Binary binop pes (q1, q2) -> binary    f binop pes (self q1, self q2)+          Label l pq                -> label     f l (self pq)+        fix g = let x = g x in x  times :: PrimQuery -> PrimQuery -> PrimQuery times q q' = Product (q NEL.:| [q']) []@@ -71,6 +111,6 @@ restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery restrict cond primQ = Product (return primQ) [cond] -isUnit :: PrimQuery -> Bool+isUnit :: PrimQuery' a -> Bool isUnit Unit = True isUnit _    = False

@@ -6,8 +6,9 @@ import           Opaleye.Internal.Sql (Select(SelectFrom, Table,                                               SelectJoin,                                               SelectValues,-                                              SelectBinary),-                                       From, Join, Values, Binary)+                                              SelectBinary,+                                              SelectLabel),+                                       From, Join, Values, Binary, Label)  import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint@@ -15,15 +16,17 @@ import           Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,                                             parens) import qualified Data.List.NonEmpty as NEL+import qualified Data.Text          as ST  type TableAlias = String  ppSql :: Select -> Doc-ppSql (SelectFrom s) = ppSelectFrom s-ppSql (Table table) = HPrint.ppTable table-ppSql (SelectJoin j) = ppSelectJoin j+ppSql (SelectFrom s)   = ppSelectFrom s+ppSql (Table table)    = HPrint.ppTable table+ppSql (SelectJoin j)   = ppSelectJoin j ppSql (SelectValues v) = ppSelectValues v ppSql (SelectBinary v) = ppSelectBinary v+ppSql (SelectLabel v)  = ppSelectLabel v  ppSelectFrom :: From -> Doc ppSelectFrom s = text "SELECT"@@ -57,6 +60,16 @@                    $$ ppBinOp (Sql.bOp b)                    $$ ppSql (Sql.bSelect2 b) +ppSelectLabel :: Label -> Doc+ppSelectLabel l = text "/*" <+> text (defuseComments (Sql.lLabel l)) <+> text "*/"+                  $$ ppSql (Sql.lSelect l)+  where+    defuseComments = ST.unpack+                   . ST.replace (ST.pack "--") (ST.pack " - - ")+                   . ST.replace (ST.pack "/*") (ST.pack " / * ")+                   . ST.replace (ST.pack "*/") (ST.pack " * / ")+                   . ST.pack+ ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" @@ -84,6 +97,7 @@   SelectJoin slj        -> parens (ppSelectJoin slj)   SelectValues slv      -> parens (ppSelectValues slv)   SelectBinary slb      -> parens (ppSelectBinary slb)+  SelectLabel sll       -> parens (ppSelectLabel sll)  ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppGroupBy Nothing   = empty@@ -105,9 +119,12 @@  ppBinOp :: Sql.BinOp -> Doc ppBinOp o = text $ case o of-  Sql.Union    -> "UNION"-  Sql.UnionAll -> "UNION ALL"-  Sql.Except   -> "EXCEPT"+  Sql.Union        -> "UNION"+  Sql.UnionAll     -> "UNION ALL"+  Sql.Except       -> "EXCEPT"+  Sql.ExceptAll    -> "EXCEPT ALL"+  Sql.Intersect    -> "INTERSECT"+  Sql.IntersectAll -> "INTERSECT ALL"  ppInsertReturning :: Sql.Returning HSql.SqlInsert -> Doc ppInsertReturning (Sql.Returning insert returnExprs) =

@@ -17,7 +17,10 @@ import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP +-- | @QueryArr a b@ is analogous to a Haskell function @a -> [b]@. newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag))++-- | @Query a@ is analogous to a Haskell value @[a]@. type Query = QueryArr ()  simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b

@@ -33,7 +33,7 @@ import qualified Data.Time as Time import qualified Data.String as String import           Data.UUID (UUID)-import           GHC.Int (Int64)+import           GHC.Int (Int32, Int64)  -- { Only needed for annoying postgresql-simple patch below @@ -69,14 +69,14 @@ data QueryRunnerColumn pgType haskellType =   QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType) +instance Functor (QueryRunnerColumn u) where+  fmap f ~(QueryRunnerColumn u fp) = QueryRunnerColumn u ((fmap . fmap . fmap) f fp)+ data QueryRunner columns haskells =   QueryRunner (U.Unpackspec columns ())               (columns -> RowParser haskells)-              -- We never actually-              -- look at the columns-              -- except to see its-              -- "type" in the case-              -- of a sum profunctor+              -- 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               -- asked for zero columns then the SQL generator will@@ -85,15 +85,17 @@               -- have to make sure we read a single Int.  fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn coltype haskell-fieldQueryRunnerColumn =-  QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) fromField+fieldQueryRunnerColumn = fieldParserQueryRunnerColumn fromField +fieldParserQueryRunnerColumn :: FieldParser haskell -> QueryRunnerColumn coltype haskell+fieldParserQueryRunnerColumn = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn)+ queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True)     where QueryRunnerColumn u fp = qrc  queryRunnerColumnNullable :: QueryRunnerColumn a b-                       -> QueryRunnerColumn (Nullable a) (Maybe b)+                          -> QueryRunnerColumn (Nullable a) (Maybe b) queryRunnerColumnNullable qr =   QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp)   where QueryRunnerColumn u fp = qr@@ -125,6 +127,9 @@ instance QueryRunnerColumnDefault T.PGInt4 Int where   queryRunnerColumnDefault = fieldQueryRunnerColumn +instance QueryRunnerColumnDefault T.PGInt4 Int32 where+  queryRunnerColumnDefault = fieldQueryRunnerColumn+ instance QueryRunnerColumnDefault T.PGInt8 Int64 where   queryRunnerColumnDefault = fieldQueryRunnerColumn @@ -171,15 +176,13 @@   queryRunnerColumnDefault = fieldQueryRunnerColumn  instance QueryRunnerColumnDefault T.PGJson String where-  queryRunnerColumnDefault =-    QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonFieldParser+  queryRunnerColumnDefault = fieldParserQueryRunnerColumn jsonFieldParser  instance QueryRunnerColumnDefault T.PGJson Ae.Value where   queryRunnerColumnDefault = fieldQueryRunnerColumn  instance QueryRunnerColumnDefault T.PGJsonb String where-  queryRunnerColumnDefault =-    QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonbFieldParser+  queryRunnerColumnDefault = fieldParserQueryRunnerColumn jsonbFieldParser  instance QueryRunnerColumnDefault T.PGJsonb Ae.Value where   queryRunnerColumnDefault = fieldQueryRunnerColumn

@@ -14,6 +14,7 @@  import qualified Data.List.NonEmpty as NEL import qualified Data.Maybe as M+import qualified Data.Void as V  import qualified Control.Arrow as Arr @@ -22,6 +23,7 @@             | SelectJoin Join             | SelectValues Values             | SelectBinary Binary+            | SelectLabel Label             deriving Show  data SelectAttrs =@@ -59,15 +61,30 @@ } deriving Show  data JoinType = LeftJoin deriving Show-data BinOp = Except | Union | UnionAll deriving Show+data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show +data Label = Label {+  lLabel  :: String,+  lSelect :: Select+} deriving Show+ data Returning a = Returning a (NEL.NonEmpty HSql.SqlExpr) -sqlQueryGenerator :: PQ.PrimQueryFold Select-sqlQueryGenerator = (unit, baseTable, product, aggregate, order, limit_, join,-                     values, binary)+sqlQueryGenerator :: PQ.PrimQueryFold' V.Void Select+sqlQueryGenerator = PQ.PrimQueryFold+  { PQ.unit      = unit+  , PQ.empty     = empty+  , PQ.baseTable = baseTable+  , PQ.product   = product+  , PQ.aggregate = aggregate+  , PQ.order     = order+  , PQ.limit     = limit_+  , PQ.join      = join+  , PQ.values    = values+  , PQ.binary    = binary+  , PQ.label     = label } -sql :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> Select+sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes))                                           , tables = [pqSelect] }   where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq@@ -77,6 +94,9 @@ unit :: Select unit = SelectFrom newSelect { attrs  = SelectAttrs (ensureColumns []) } +empty :: V.Void -> select+empty = V.absurd+ baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select baseTable ti columns = SelectFrom $     newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))@@ -87,7 +107,7 @@     newSelect { tables = NEL.toList ss               , criteria = map sqlExpr pes } -aggregate :: [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> Select -> Select+aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] -> Select -> Select aggregate aggrs s = SelectFrom $ newSelect { attrs = SelectAttrs                                                (ensureColumns (map attr aggrs))                                            , tables = [s]@@ -114,8 +134,8 @@         aggrOp (_, (x, _)) = x  -aggrExpr :: Maybe HPQ.AggrOp -> HPQ.PrimExpr -> HPQ.PrimExpr-aggrExpr = maybe id HPQ.AggrExpr+aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr]) -> HPQ.PrimExpr -> HPQ.PrimExpr+aggrExpr = maybe id (\(op, ord) e -> HPQ.AggrExpr op e ord)  order :: [HPQ.OrderExpr] -> Select -> Select order oes s = SelectFrom $@@ -139,9 +159,9 @@ -- Postgres seems to name columns of VALUES clauses "column1", -- "column2", ... . I'm not sure to what extent it is customisable or -- how robust it is to rely on this-values :: [Symbol] -> [[HPQ.PrimExpr]] -> Select+values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> Select values columns pes = SelectValues Values { vAttrs  = SelectAttrs (mkColumns columns)-                                         , vValues = (map . map) sqlExpr pes }+                                         , vValues = NEL.toList ((fmap . map) sqlExpr pes) }   where mkColumns = ensureColumns . zipWith (flip (curry (sqlBinding . Arr.second mkColumn))) [1..]         mkColumn i = (HPQ.BaseTableAttrExpr . ("column" ++) . show) (i::Int) @@ -163,9 +183,12 @@  binOp :: PQ.BinOp -> BinOp binOp o = case o of-  PQ.Except   -> Except-  PQ.Union    -> Union-  PQ.UnionAll -> UnionAll+  PQ.Except       -> Except+  PQ.ExceptAll    -> ExceptAll+  PQ.Union        -> Union+  PQ.UnionAll     -> UnionAll+  PQ.Intersect    -> Intersect+  PQ.IntersectAll -> IntersectAll  newSelect :: From newSelect = From {@@ -195,3 +218,6 @@               -> NEL.NonEmpty a ensureColumnsGen f = M.fromMaybe (return . f $ HSql.ConstSqlExpr "0")                    . NEL.nonEmpty++label :: String -> Select -> Select+label l s = SelectLabel (Label l s)

@@ -2,8 +2,6 @@  module Opaleye.Internal.Values where -import qualified Opaleye.PGTypes as T- import           Opaleye.Internal.Column (Column(Column)) import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Tag as T@@ -11,6 +9,7 @@ import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Data.List.NonEmpty as NEL import           Data.Profunctor (Profunctor, dimap, rmap) import           Data.Profunctor.Product (ProductProfunctor, empty, (***!)) import qualified Data.Profunctor.Product as PP@@ -18,19 +17,8 @@  import           Control.Applicative (Applicative, pure, (<*>)) --- There are two annoyances with creating SQL VALUES statements------ 1. SQL does not allow empty VALUES statements so if we want to---    create a VALUES statement from an empty list we have to fake it---    somehow.  The current approach is to make a VALUES statement---    with a single row of NULLs and then restrict it with WHERE---    FALSE.---- 2. Postgres's type inference of constants is pretty poor so we will---    sometimes have to give explicit type signatures.  The future---    ShowConstant class will have the same problem.  NB We don't---    actually currently address this problem.-+-- FIXME: We don't currently handle the case of zero columns.  Need to+-- emit a dummy column and data. valuesU :: U.Unpackspec columns columns'         -> Valuesspec columns columns'         -> [columns]@@ -44,17 +32,13 @@           PM.run (runValuesspec valuesspec (extractValuesField t))          valuesPEs = map fst valuesPEs_nulls-        nulls = map snd valuesPEs_nulls -        yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery-        yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))--        values' :: [[HPQ.PrimExpr]]-        (values', wrap) = if null rows-                          then ([nulls], yieldNoRows)-                          else (map runRow rows, id)+        values :: [[HPQ.PrimExpr]]+        values = map runRow rows -        primQ' = wrap (PQ.Values valuesPEs values')+        primQ' = case NEL.nonEmpty values of+          Nothing      -> PQ.Empty ()+          Just values' -> PQ.Values valuesPEs values'  -- We don't actually use the return value of this.  It might be better -- to come up with another Applicative instance for specifically doing@@ -64,19 +48,19 @@   PM.write pe   return pe -extractValuesField :: T.Tag -> HPQ.PrimExpr-                   -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr+extractValuesField :: T.Tag -> primExpr+                   -> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr extractValuesField = PM.extractAttr "values"  newtype Valuesspec columns columns' =-  Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')+  Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')  runValuesspec :: Applicative f => Valuesspec columns columns'-              -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'+              -> (() -> f HPQ.PrimExpr) -> f columns' runValuesspec (Valuesspec v) f = PM.traversePM v f () -instance Default Valuesspec (Column T.PGInt4) (Column T.PGInt4) where-  def = Valuesspec (PM.PackMap (\f () -> fmap Column (f (HPQ.ConstExpr HPQ.NullLit))))+instance Default Valuesspec (Column a) (Column a) where+  def = Valuesspec (PM.PackMap (\f () -> fmap Column (f ())))  -- { 

@@ -0,0 +1,11 @@+module Opaleye.Label where++import           Opaleye.QueryArr (Query)+import qualified Opaleye.Internal.Label as L+import qualified Opaleye.Internal.QueryArr as Q++{- |+Add a label in comments to the given query.+-}+label :: String -> Query a -> Query a+label l a = Q.simpleQueryArr (L.label' l . Q.runSimpleQueryArr a)

@@ -1,5 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Inserts, updates and deletes+--+-- Please note that you currently you can only INSERT or UPDATE with+-- constant values, not the result of SELECTS.  That is, you can+-- generate SQL of the form+--+-- @+-- INSERT INTO thetable ('John', 1);+-- @+--+-- but not+--+-- @+-- INSERT INTO thetable+--    SELECT 'John',+--    (SELECT num FROM thetable ORDER BY num DESC LIMIT 1) + 1;+-- @+ module Opaleye.Manipulation (module Opaleye.Manipulation,                              U.Unpackspec) where @@ -28,9 +46,13 @@ import           Data.String (fromString) import qualified Data.List.NonEmpty as NEL +-- | Returns the number of rows inserted+--+-- This will be deprecated in a future release.  Use 'runInsertMany' instead. runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql +-- | Returns the number of rows inserted runInsertMany :: PGS.Connection               -> T.Table columns columns'               -> [columns]@@ -44,14 +66,29 @@ -- compiler will have trouble inferring types.  It is strongly -- recommended that you provide full type signatures when using -- @runInsertReturning@.+--+-- This will be deprecated in a future release.  Use+-- 'runInsertManyReturning' instead. runInsertReturning :: (D.Default RQ.QueryRunner returned haskells)-                      => PGS.Connection-                      -> T.Table columnsW columnsR-                      -> columnsW-                      -> (columnsR -> returned)-                      -> IO [haskells]+                   => PGS.Connection+                   -> T.Table columnsW columnsR+                   -> columnsW+                   -> (columnsR -> returned)+                   -> IO [haskells] runInsertReturning = runInsertReturningExplicit D.def +-- | @runInsertManyReturning@'s 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+-- @runInsertManyReturning@.+runInsertManyReturning :: (D.Default RQ.QueryRunner returned haskells)+                       => PGS.Connection+                       -> T.Table columnsW columnsR+                       -> [columnsW]+                       -> (columnsR -> returned)+                       -> IO [haskells]+runInsertManyReturning = runInsertManyReturningExplicit D.def+ -- | Where the predicate is true, update rows using the supplied -- function. runUpdate :: PGS.Connection -> T.Table columnsW columnsR@@ -64,12 +101,12 @@ -- strongly recommended that you provide full type signatures when -- using @runInsertReturning@. runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells)-                      => PGS.Connection-                      -> T.Table columnsW columnsR-                      -> (columnsR -> columnsW)-                      -> (columnsR -> Column PGBool)-                      -> (columnsR -> returned)-                      -> IO [haskells]+                   => PGS.Connection+                   -> T.Table columnsW columnsR+                   -> (columnsR -> columnsW)+                   -> (columnsR -> Column PGBool)+                   -> (columnsR -> returned)+                   -> IO [haskells] runUpdateReturning = runUpdateReturningExplicit D.def  -- | Delete rows where the predicate is true.@@ -79,17 +116,33 @@  -- | You probably don't need this, but can just use -- 'runInsertReturning' instead.  You only need it if you want to run--- an UPDATE RETURNING statement but need to be explicit about the+-- an INSERT RETURNING statement but need to be explicit about the -- 'QueryRunner'. runInsertReturningExplicit :: RQ.QueryRunner returned haskells-                            -> PGS.Connection-                            -> T.Table columnsW columnsR-                            -> columnsW-                            -> (columnsR -> returned)-                            -> IO [haskells]-runInsertReturningExplicit qr conn t w r = PGS.queryWith_ parser conn-                                             (fromString-                                             (arrangeInsertReturningSql u t w r))+                           -> PGS.Connection+                           -> T.Table columnsW columnsR+                           -> columnsW+                           -> (columnsR -> returned)+                           -> IO [haskells]+runInsertReturningExplicit qr conn t =+  runInsertManyReturningExplicit qr conn t . return++-- | You probably don't need this, but can just use+-- 'runInsertManyReturning' instead.  You only need it if you want to+-- run an UPDATE RETURNING statement but need to be explicit about the+-- 'QueryRunner'.+runInsertManyReturningExplicit :: RQ.QueryRunner returned haskells+                               -> PGS.Connection+                               -> T.Table columnsW columnsR+                               -> [columnsW]+                               -> (columnsR -> returned)+                               -> IO [haskells]+runInsertManyReturningExplicit qr conn t columns r =+  case NEL.nonEmpty columns of+    Nothing       -> return []+    Just columns' -> PGS.queryWith_ parser conn+                       (fromString+                        (arrangeInsertManyReturningSql u t columns' r))   where IRQ.QueryRunner u _ _ = qr         parser = IRQ.prepareRowParser qr (r v)         TI.Table _ (TI.TableProperties _ (TI.View v)) = t@@ -174,28 +227,27 @@  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeInsertReturning :: U.Unpackspec returned ignored-                       -> T.Table columnsW columnsR-                       -> columnsW-                       -> (columnsR -> returned)-                       -> Sql.Returning HSql.SqlInsert-arrangeInsertReturning unpackspec table columns returningf =+arrangeInsertManyReturning :: U.Unpackspec returned ignored+                           -> T.Table columnsW columnsR+                           -> NEL.NonEmpty columnsW+                           -> (columnsR -> returned)+                           -> Sql.Returning HSql.SqlInsert+arrangeInsertManyReturning unpackspec table columns returningf =   Sql.Returning insert returningSEs-  where insert = arrangeInsert table columns+  where insert = arrangeInsertMany table columns         TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table)         returningPEs = U.collectPEs unpackspec (returningf columnsR)         returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.-arrangeInsertReturningSql :: U.Unpackspec returned ignored-                          -> T.Table columnsW columnsR-                          -> columnsW-                          -> (columnsR -> returned)-                          -> String-arrangeInsertReturningSql = show-                            . Print.ppInsertReturning-                            .:: arrangeInsertReturning+arrangeInsertManyReturningSql :: U.Unpackspec returned ignored+                              -> T.Table columnsW columnsR+                              -> NEL.NonEmpty columnsW+                              -> (columnsR -> returned)+                              -> String+arrangeInsertManyReturningSql =+  show . Print.ppInsertReturning .:: arrangeInsertManyReturning  -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release.@@ -215,11 +267,10 @@ -- | For internal use only.  Do not use.  Will be removed in a -- subsequent release. arrangeUpdateReturningSql :: U.Unpackspec returned ignored-                       -> T.Table columnsW columnsR-                       -> (columnsR -> columnsW)-                       -> (columnsR -> Column PGBool)-                       -> (columnsR -> returned)-                       -> String-arrangeUpdateReturningSql = show-                            . Print.ppUpdateReturning-                            .::. arrangeUpdateReturning+                          -> T.Table columnsW columnsR+                          -> (columnsR -> columnsW)+                          -> (columnsR -> Column PGBool)+                          -> (columnsR -> returned)+                          -> String+arrangeUpdateReturningSql =+  show . Print.ppUpdateReturning .::. arrangeUpdateReturning

@@ -13,13 +13,17 @@ import           Opaleye.Internal.Column (Column(Column), unsafeCase_,                                           unsafeIfThenElse, unsafeGt) import qualified Opaleye.Internal.Column as C-import           Opaleye.Internal.QueryArr (QueryArr(QueryArr))+import           Opaleye.Internal.QueryArr (QueryArr(QueryArr), Query) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Operators as O import           Opaleye.Internal.Helpers   ((.:)) import qualified Opaleye.Order as Ord import qualified Opaleye.PGTypes as T +import qualified Opaleye.Column   as Column+import qualified Opaleye.Distinct as Distinct+import qualified Opaleye.Join     as Join+ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ  import qualified Data.Profunctor.Product.Default as D@@ -81,6 +85,12 @@ (.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.>=) = C.binOp HPQ.OpGtEq +quot_ :: C.PGIntegral a => Column a -> Column a -> Column a+quot_ = C.binOp HPQ.OpDiv++rem_ :: C.PGIntegral a => Column a -> Column a -> Column a+rem_ = C.binOp HPQ.OpMod+ case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a case_ = unsafeCase_ @@ -106,9 +116,56 @@ like :: Column T.PGText -> Column T.PGText -> Column T.PGBool like = C.binOp HPQ.OpLike +charLength :: C.PGString a => Column a -> Column Int+charLength (Column e) = Column (HPQ.FunExpr "char_length" [e])+ -- | True when any element of the container is true ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool ors = F.foldl' (.||) (T.pgBool False)  in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool in_ hs w = ors . fmap (w .==) $ hs++-- | True if the first argument occurs amongst the rows of the second,+-- false otherwise.+--+-- 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 columns columns+        => columns -> QueryArr () columns -> Query (Column T.PGBool)+inQuery 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)+             A.<<< keepWhen (c .===)+             A.<<< q++        -- Left join with a query that has a single row+        -- We either get a single row with '1'+        -- or a single row with 'NULL'+        qj :: Query (Column T.PGInt4, Column (C.Nullable T.PGInt4))+        qj = Join.leftJoin (A.arr (const 1))+                           (Distinct.distinct q')+                           (uncurry (.==))+                          +        -- Check whether it is 'NULL'+        qj' :: Query (Column T.PGBool)+        qj' = A.arr (Opaleye.Operators.not+                     . Column.isNull+                     . snd)+              A.<<< qj++timestamptzAtTimeZone :: Column T.PGTimestamptz+                      -> Column T.PGText+                      -> Column T.PGTimestamp+timestamptzAtTimeZone = C.binOp HPQ.OpAtTimeZone++emptyArray :: T.IsSqlType a => Column (T.PGArray a)+emptyArray = T.pgArray id []++arrayPrepend :: Column a -> Column (T.PGArray a) -> Column (T.PGArray a)+arrayPrepend (Column e) (Column es) = Column (HPQ.FunExpr "array_prepend" [e, es])++singletonArray :: T.IsSqlType a => Column a -> Column (T.PGArray a)+singletonArray x = arrayPrepend x emptyArray

@@ -81,3 +81,4 @@ instance PGOrd T.PGTimestamp instance PGOrd T.PGCitext instance PGOrd T.PGUuid+instance PGOrd a => PGOrd (C.Nullable a)

@@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Opaleye.PGTypes (module Opaleye.PGTypes) where @@ -7,7 +8,7 @@ import qualified Opaleye.Internal.PGTypes as IPT  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Opaleye.Internal.HaskellDB.Sql.Default as HSD (quote)+import qualified Opaleye.Internal.HaskellDB.Sql.Default as HSD  import qualified Data.CaseInsensitive as CI import qualified Data.Aeson as Ae@@ -51,6 +52,16 @@ instance C.PGFractional PGFloat8 where   pgFromRational = pgDouble . fromRational +instance C.PGIntegral PGInt2+instance C.PGIntegral PGInt4+instance C.PGIntegral PGInt8++instance C.PGString PGText where+  pgFromString = pgString++instance C.PGString PGCitext where+  pgFromString = pgCiLazyText . CI.mk . LText.pack+ literalColumn :: HPQ.Literal -> Column a literalColumn = IPT.literalColumn {-# WARNING literalColumn@@ -147,3 +158,51 @@  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 pgEl xs = C.unsafeCast arrayTy $+  C.Column (HPQ.ArrayExpr (map oneEl xs))+  where+    oneEl = C.unColumn . pgEl+    arrayTy = showPGType ([] :: [PGArray b])++class IsSqlType pgType where+  showPGType :: proxy pgType -> String+instance IsSqlType PGBool where+  showPGType _ = "boolean"+instance IsSqlType PGDate where+  showPGType _ = "date"+instance IsSqlType PGFloat4 where+  showPGType _ = "real"+instance IsSqlType PGFloat8 where+  showPGType _ = "double precision"+instance IsSqlType PGInt8 where+  showPGType _ = "bigint"+instance IsSqlType PGInt4 where+  showPGType _ = "integer"+instance IsSqlType PGInt2 where+  showPGType _ = "smallint"+instance IsSqlType PGNumeric where+  showPGType _ = "numeric"+instance IsSqlType PGText where+  showPGType _ = "text"+instance IsSqlType PGTime where+  showPGType _ = "time"+instance IsSqlType PGTimestamp where+  showPGType _ = "timestamp"+instance IsSqlType PGTimestamptz where+  showPGType _ = "timestamp with time zone"+instance IsSqlType PGUuid where+  showPGType _ = "uuid"+instance IsSqlType PGCitext where+  showPGType _ =  "citext"+instance IsSqlType PGBytea where+  showPGType _ = "bytea"+instance IsSqlType a => IsSqlType (PGArray a) where+  showPGType _ = showPGType ([] :: [a]) ++ "[]"+instance IsSqlType a => IsSqlType (C.Nullable a) where+  showPGType _ = showPGType ([] :: [a])+instance IsSqlType PGJson where+  showPGType _ = "json"+instance IsSqlType PGJsonb where+  showPGType _ = "jsonb"

@@ -50,24 +50,47 @@                  -> PGS.Connection                  -> Query columns                  -> IO [haskells]-runQueryExplicit qr conn q = PGS.queryWith_ parser conn sql+runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql   where (sql, parser) = prepareQuery qr q -prepareQuery :: QueryRunner columns haskells -> Query columns -> (PGS.Query, FR.RowParser haskells)-prepareQuery qr@(QueryRunner u _ _) q = (sql, parser)-  where sql :: PGS.Query-        sql = String.fromString (S.showSqlForPostgresExplicit u q)-        -- FIXME: We're doing work twice here-        (b, _, _) = Q.runSimpleQueryArrStart q ()-        parser = IRQ.prepareRowParser qr b+-- | @runQueryFold@ streams the results of a query incrementally and consumes+-- the results with a left fold.+--+-- This fold is /not/ strict. The stream consumer is responsible for+-- forcing the evaluation of its result to avoid space leaks.+runQueryFold+  :: D.Default QueryRunner columns haskells+  => PGS.Connection+  -> Query columns+  -> b+  -> (b -> haskells -> IO b)+  -> IO b+runQueryFold = runQueryFoldExplicit D.def +runQueryFoldExplicit+  :: QueryRunner columns haskells+  -> PGS.Connection+  -> Query columns+  -> b+  -> (b -> haskells -> IO b)+  -> IO b+runQueryFoldExplicit qr conn q z f = case sql of+  Nothing   -> return z+  Just sql' -> PGS.foldWith_ parser conn sql' z f+  where (sql, parser) = prepareQuery qr q+ -- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on --   your own datatypes.  For example: -- -- @ -- newtype Foo = Foo Int--- instance Default QueryRunnerColumn Foo Foo where---    def = queryRunnerColumn ('Opaleye.Column.unsafeCoerce' :: Column Foo -> Column PGInt4) Foo def+--+-- instance QueryRunnerColumnDefault Foo Foo where+--    queryRunnerColumnDefault =+--        queryRunnerColumn ('Opaleye.Column.unsafeCoerceColumn'+--                               :: Column Foo -> Column PGInt4)+--                          Foo+--                          queryRunnerColumnDefault -- @ queryRunnerColumn :: (Column a' -> Column a) -> (b -> b')                   -> IRQ.QueryRunnerColumn a b -> IRQ.QueryRunnerColumn a' b'@@ -75,3 +98,13 @@                                                             (fmapFP haskellF fp)   where IRQ.QueryRunnerColumn u fp = qrc         fmapFP = fmap . fmap . fmap++-- | For internal use only.  Do not use.  Will be removed in a+-- subsequent release.+prepareQuery :: QueryRunner columns haskells -> Query columns -> (Maybe PGS.Query, FR.RowParser haskells)+prepareQuery qr@(QueryRunner u _ _) q = (sql, parser)+  where sql :: Maybe PGS.Query+        sql = fmap String.fromString (S.showSqlForPostgresExplicit u q)+        -- FIXME: We're doing work twice here+        (b, _, _) = Q.runSimpleQueryArrStart q ()+        parser = IRQ.prepareRowParser qr b

@@ -15,33 +15,38 @@  import qualified Data.Profunctor.Product.Default as D --- | Example type specialization:+-- | When 'Nothing' is returned it means that the query has no results. --+-- Example type specialization:+-- -- @--- showSqlForPostgres :: Query (Column a, Column b) -> String+-- showSqlForPostgres :: Query (Column a, Column b) -> Maybe String -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the -- product type @Foo@: -- -- @--- showSqlForPostgres :: Query (Foo (Column a) (Column b) (Column c)) -> String+-- showSqlForPostgres :: Query (Foo (Column a) (Column b) (Column c)) -> Maybe String -- @ showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns =>-                      Q.Query columns -> String+                      Q.Query columns -> Maybe String showSqlForPostgres = showSqlForPostgresExplicit (D.def :: U.Unpackspec columns columns)  showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns =>-                           Q.Query columns -> String+                           Q.Query columns -> Maybe String showSqlForPostgresUnopt = showSqlForPostgresUnoptExplicit (D.def :: U.Unpackspec columns columns) -showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> String+showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String showSqlForPostgresExplicit = formatAndShowSQL                              . (\(x, y, z) -> (x, Op.optimize y, z))                              .: Q.runQueryArrUnpack -showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> String+showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String showSqlForPostgresUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack -formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> String-formatAndShowSQL = show . Pr.ppSql . Sql.sql+formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery' a, T.Tag) -> Maybe String+formatAndShowSQL = fmap (show . Pr.ppSql . Sql.sql) . traverse2Of3 Op.removeEmpty+  where -- Just a lens+        traverse2Of3 :: Functor f => (a -> f b) -> (x, a, y) -> f (x, b, y)+        traverse2Of3 f (x, y, z) = fmap (\y' -> (x, y', z)) (f y)