opaleye 0.3.1.2 → 0.4.0.0

raw patch · 41 files changed

+1277/−349 lines, 41 filesdep +QuickCheckdep +containersdep +voiddep ~contravariantdep ~product-profunctorsdep ~semigroupsPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, containers, void

Dependency ranges changed: contravariant, product-profunctors, semigroups

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−2
• Doc/Tutorial/TutorialAdvanced.lhs +1/−1
• Doc/Tutorial/TutorialManipulation.lhs +5/−1
• LICENSE +1/−1
• README.md +21/−5
• Test/QuickCheck.hs +306/−0
• Test/Test.hs +125/−17
• opaleye.cabal +18/−8
• src/Opaleye/Aggregate.hs +10/−2
• src/Opaleye/Column.hs +5/−4
• src/Opaleye/Internal/Aggregate.hs +9/−1
• src/Opaleye/Internal/Binary.hs +2/−2
• src/Opaleye/Internal/Column.hs +5/−1
• src/Opaleye/Internal/Distinct.hs +4/−1
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +25/−13
• src/Opaleye/Internal/HaskellDB/Sql.hs +15/−16
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +81/−57
• src/Opaleye/Internal/HaskellDB/Sql/Generate.hs +2/−1
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +46/−23
• src/Opaleye/Internal/Helpers.hs +5/−0
• src/Opaleye/Internal/Join.hs +3/−3
• src/Opaleye/Internal/Order.hs +20/−10
• src/Opaleye/Internal/PGTypes.hs +30/−0
• src/Opaleye/Internal/PackMap.hs +54/−14
• src/Opaleye/Internal/PrimQuery.hs +3/−3
• src/Opaleye/Internal/Print.hs +20/−12
• src/Opaleye/Internal/QueryArr.hs +5/−4
• src/Opaleye/Internal/RunQuery.hs +84/−21
• src/Opaleye/Internal/Sql.hs +48/−25
• src/Opaleye/Internal/Table.hs +40/−13
• src/Opaleye/Internal/TableMaker.hs +2/−2
• src/Opaleye/Internal/Tag.hs +1/−1
• src/Opaleye/Internal/Unpackspec.hs +29/−1
• src/Opaleye/Internal/Values.hs +2/−2
• src/Opaleye/Join.hs +7/−10
• src/Opaleye/Manipulation.hs +85/−26
• src/Opaleye/Operators.hs +13/−4
• src/Opaleye/Order.hs +52/−5
• src/Opaleye/PGTypes.hs +54/−27
• src/Opaleye/RunQuery.hs +17/−2
• src/Opaleye/Table.hs +4/−8

@@ -1,3 +1,14 @@+* Added `runUpdateReturning`+* Ordering operators and `max` and `min` aggregators are now restricted to a typeclass+* Added `stringAgg` and `arrayAgg` aggregations.+* Added `PGOrd` typeclass for typesafe ordering operations.+* Support sorting NULLs first or last with `ascNullsFirst` and `descNullsFirst`+* Added JSON types+* Added `runInsertMany`++Thanks to Travis Staton, Jakub Ryška and Christopher Lewis for helping+with these changes.+ ## 0.3.1.2  * Use time >= 1.4 and time-locale-compat@@ -15,8 +26,13 @@  ## 0.3 -* Replace `Default QueryRunner` with a new class `DefaultQueryRunnerColumn`, migrate with `s/Default QueryRunner/DefaultQueryRunnerColumn` and `s/def/queryRunnerColumnDefault/`-* Remove `ShowConstant`, use the monomorphic functions defined in the new module `Opaleye.PGTypes` instead. You will need to replace `Column Bool` with `Column PGBool` et.c. in query signatures+* Replace `Default QueryRunner` with a new class+  `DefaultQueryRunnerColumn`, migrate with `s/Default+  QueryRunner/DefaultQueryRunnerColumn` and+  `s/def/queryRunnerColumnDefault/`+* Remove `ShowConstant`, use the monomorphic functions defined in the+  new module `Opaleye.PGTypes` instead. You will need to replace+  `Column Bool` with `Column PGBool` etc. in query signatures * Re-export more modules from `Opaleye` * Add `boolAnd`, `boolOr,` `max`, and `min` aggregators * Add `lower` and `upper`

@@ -47,7 +47,7 @@ > rangeOfChildrensAges = aggregate (p2 (A.groupBy, range)) (queryTable personTable)  -TutorialAdvanced> printSql rangeOfChildrensAges +TutorialAdvanced> printSql rangeOfChildrensAges SELECT result0_2 as result1,        (result1_2) - (result2_2) as result2 FROM (SELECT *

@@ -10,6 +10,7 @@ > > import           Data.Profunctor.Product (p3) > import           Data.Profunctor.Product.Default (Default, def)+> import qualified Opaleye.Internal.Unpackspec as U   Manipulation@@ -93,8 +94,11 @@ Opaleye supports it also.  > insertReturning :: String-> insertReturning = arrangeInsertReturningSql def table (Nothing, 4, 5)+> 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  ghci> putStrLn insertReturning INSERT INTO tablename (x,

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

@@ -1,4 +1,4 @@-# Brief introduction to Opaleye+# Brief introduction to Opaleye [![Hackage version](https://img.shields.io/hackage/v/opaleye.svg?style=flat)](https://hackage.haskell.org/package/opaleye) [![Build Status](https://img.shields.io/travis/tomjaguarpaw/haskell-opaleye.svg?style=flat)](https://travis-ci.org/tomjaguarpaw/haskell-opaleye)  Opaleye is a Haskell library which provides an SQL-generating embedded domain specific language for targeting Postgres.  You need Opaleye if@@ -8,7 +8,7 @@ > "Opaleye really is great. You've managed to bring what is so wonderful about relational databases and give it type safety and composition (i.e. what is wonderful about Haskell)" – Daniel-Patterson, [Position Development](http://www.positiondev.com/)+Patterson, [Position Development](http://positiondev.com/)  Opaleye allows you to define your database tables and write queries against them in Haskell code, and aims to be typesafe in the sense@@ -60,6 +60,16 @@ Commercial support for Opaleye is provided by [Purely Agile](http://www.purelyagile.com/). +# Backup maintainers++In the event of the main developer becoming unreachable, please+contact the following who are authorised to make bugfixes and+dependency version bumps:++* Adam Bergmark+* Erik Hesselink+* Oliver Charles+ # Contributors  The Opaleye Project was founded by Tom Ellis, inspired by theoretical@@ -69,9 +79,15 @@ Bjorn Bringert, Anders Hockersten, Torbjorn Martin, Jeremy Shaw and Justin Bailey. -Silk (Erik Hesselink, Adam Bergmark), Karamaan (Christopher Lewis),-Fynder (Renzo Carbonara, Oliver Charles) and Daniel Patterson-contributed code to the project.+The following individuals and organisations have made helpful+contributions:++* Silk (Erik Hesselink, Adam Bergmark)+* Karamaan (Christopher Lewis)+* Fynder (Renzo Carbonara, Oliver Charles)+* Daniel Patterson+* Jakub Ryška+* Travis Staton  Joseph Abrahamson, Alfredo Di Napoli and Mietek Bak performed useful reviews of early versions which helped improve the codebase.

@@ -0,0 +1,306 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}++module QuickCheck where++import qualified Opaleye as O+import qualified Database.PostgreSQL.Simple as PGS+import qualified Test.QuickCheck as TQ+import           Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2)+import qualified Data.Profunctor.Product.Default as D+import           Data.List (sort, sortBy)+import qualified Data.Profunctor.Product as PP+import qualified Data.Functor.Contravariant.Divisible as Divisible+import qualified Data.Monoid as Monoid+import qualified Data.Ord as Ord+import qualified Data.Set as Set+import qualified Data.Maybe as Maybe+import qualified Control.Arrow as Arrow++twoIntTable :: String+            -> O.Table (O.Column O.PGInt4, O.Column O.PGInt4)+                       (O.Column O.PGInt4, O.Column O.PGInt4)+twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))++table1 :: O.Table (O.Column O.PGInt4, O.Column O.PGInt4)+                  (O.Column O.PGInt4, O.Column O.PGInt4)+table1 = twoIntTable "table1"++data QueryDenotation a =+  QueryDenotation { unQueryDenotation :: PGS.Connection -> IO [a] }++onList :: ([a] -> [b]) -> QueryDenotation a -> QueryDenotation b+onList f = QueryDenotation . (fmap . fmap) f . unQueryDenotation++type Columns = [Either (O.Column O.PGInt4) (O.Column O.PGBool)]+type Haskells = [Either Int Bool]++newtype ArbitraryQuery   = ArbitraryQuery (O.Query Columns)+newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Columns }+                        deriving Show+newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int+                            deriving Show+newtype ArbitraryOrder = ArbitraryOrder { unArbitraryOrder :: [(Order, Int)] }+                      deriving Show+newtype ArbitraryGarble =+  ArbitraryGarble { unArbitraryGarble :: forall a. [a] -> [a] }++data Order = Asc | Desc deriving Show++unpackColumns :: O.Unpackspec Columns Columns+unpackColumns = eitherPP++instance Show ArbitraryQuery where+  show (ArbitraryQuery q) = O.showSqlForPostgresExplicit unpackColumns q++instance Show ArbitraryGarble where+  show = const "A permutation"++instance TQ.Arbitrary ArbitraryQuery where+  arbitrary = TQ.oneof [+      (ArbitraryQuery . pure . unArbitraryColumns)+        <$> TQ.arbitrary+    , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1)))+    , do+        ArbitraryQuery q <- TQ.arbitrary+        aq (O.distinctExplicit eitherPP q)+    , do+        ArbitraryQuery q <- TQ.arbitrary+        l                <- TQ.choose (0, 100)+        aq (O.limit l q)+    , do+        ArbitraryQuery q <- TQ.arbitrary+        l                <- TQ.choose (0, 100)+        aq (O.offset l q)+    , do+        ArbitraryQuery q <- TQ.arbitrary+        o                <- TQ.arbitrary+        aq (O.orderBy (arbitraryOrder o) q)++    , do+        ArbitraryQuery q <- TQ.arbitrary+        f                <- TQ.arbitrary+        aq (fmap (unArbitraryGarble f) q)++    , do+        ArbitraryQuery q <- TQ.arbitrary+        aq (restrictFirstBool Arrow.<<< q)+    ]+    where aq = return . ArbitraryQuery+++instance TQ.Arbitrary ArbitraryColumns where+    arbitrary = do+    l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1]+                             ++ map (return . Right) [O.pgBool False, O.pgBool True]))+    return (ArbitraryColumns l)++instance TQ.Arbitrary ArbitraryPositiveInt where+  arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100))++instance TQ.Arbitrary ArbitraryOrder where+  arbitrary = fmap ArbitraryOrder+                   (TQ.listOf ((,)+                               <$> TQ.oneof [return Asc, return Desc]+                               <*> TQ.choose (0, 100)))++odds :: [a] -> [a]+odds []     = []+odds (x:xs) = x : evens xs++evens :: [a] -> [a]+evens []     = []+evens (_:xs) = odds xs++instance TQ.Arbitrary ArbitraryGarble where+  arbitrary = do+    i <- TQ.choose (0 :: Int, 4)++    return (ArbitraryGarble (\xs ->+        if i == 0 then+          evens xs ++ odds xs+        else if i == 1 then+          evens xs ++ evens xs+        else if i == 2 then+          odds xs ++ odds xs+        else if i == 3 then+          evens xs+        else+          odds xs))++arbitraryOrder :: ArbitraryOrder -> O.Order Columns+arbitraryOrder = Monoid.mconcat+                 . map (\(direction, index) ->+                         (case direction of+                             Asc  -> (\f -> Divisible.choose  f (O.asc id) (O.asc id))+                             Desc -> (\f -> Divisible.choose  f (O.desc id) (O.desc id)))+                         -- If the list is empty we have to conjure up+                         -- an arbitrary value of type Column+                         (\l -> let len = length l+                                in if len > 0 then+                                     l !! (index `mod` length l)+                                   else+                                     Left 0))+                 . unArbitraryOrder++arbitraryOrdering :: ArbitraryOrder -> Haskells -> Haskells -> Ord.Ordering+arbitraryOrdering = Monoid.mconcat+                    . map (\(direction, index) ->+                            (case direction of+                                Asc  -> id+                                Desc -> flip)+                         -- If the list is empty we have to conjure up+                         -- an arbitrary value of type Column+                         --+                         -- Note that this one will compare Left Int+                         -- to Right Bool, but it never gets asked to+                         -- do so, so we don't care.+                            (Ord.comparing (\l -> let len = length l+                                                  in if len > 0 then+                                                        l !! (index `mod` length l)+                                                     else+                                                        Left 0)))+                    . unArbitraryOrder++instance Functor QueryDenotation where+  fmap f = QueryDenotation . (fmap . fmap . fmap) f .unQueryDenotation++instance Applicative QueryDenotation where+  pure    = QueryDenotation . pure . pure . pure+  f <*> x = QueryDenotation ((liftA2 . liftA2 . liftA2) ($)+                                (unQueryDenotation f) (unQueryDenotation x))++denotation :: O.QueryRunner columns a -> O.Query columns -> QueryDenotation a+denotation qr q = QueryDenotation (\conn -> O.runQueryExplicit qr conn q)++denotation' :: O.Query Columns -> QueryDenotation Haskells+denotation' = denotation eitherPP++denotation2 :: O.Query (Columns, Columns)+            -> QueryDenotation (Haskells, Haskells)+denotation2 = denotation (eitherPP PP.***! eitherPP)++-- { Comparing the results++compareNoSort :: Eq a+              => PGS.Connection+              -> QueryDenotation a+              -> QueryDenotation a+              -> IO Bool+compareNoSort conn one two = do+  one' <- unQueryDenotation one conn+  two' <- unQueryDenotation two conn+  return (one' == two')++compare' :: Ord a+         => PGS.Connection+         -> QueryDenotation a+         -> QueryDenotation a+         -> IO Bool+compare' conn one two = do+  one' <- unQueryDenotation one conn+  two' <- unQueryDenotation two conn+  return (sort one' == sort two')++-- }++-- { The tests++fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool+fmap' conn f (ArbitraryQuery q) = do+  compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q))+                     (onList (fmap (unArbitraryGarble f)) (denotation' q))++apply :: PGS.Connection -> ArbitraryQuery -> ArbitraryQuery -> IO Bool+apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) = do+  compare' conn (denotation2 ((,) <$> q1 <*> q2))+                ((,) <$> denotation' q1 <*> denotation' q2)++limit :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool+limit conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do+  compareNoSort conn (denotation' (O.limit l q))+                     (onList (take l) (denotation' q))++offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool+offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do+  compareNoSort conn (denotation' (O.offset l q))+                     (onList (drop l) (denotation' q))++order :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool+order conn o (ArbitraryQuery q) = do+  compareNoSort conn (denotation' (O.orderBy (arbitraryOrder o) q))+                     (onList (sortBy (arbitraryOrdering o)) (denotation' q))++distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool+distinct conn (ArbitraryQuery q) = do+  compare' conn (denotation' (O.distinctExplicit eitherPP q))+                (onList nub (denotation' q))++restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool+restrict conn (ArbitraryQuery q) = do+  compareNoSort conn (denotation' (restrictFirstBool Arrow.<<< q))+                     (onList restrictFirstBoolList (denotation' q))++-- }++-- { Running the QuickCheck++run :: PGS.Connection -> IO ()+run conn = do+  let propFmap      = (fmap . fmap) TQ.ioProperty (fmap' conn)+      propApply     = (fmap . fmap) TQ.ioProperty (apply conn)+      propLimit     = (fmap . fmap) TQ.ioProperty (limit conn)+      propOffset    = (fmap . fmap) TQ.ioProperty (offset conn)+      propOrder     = (fmap . fmap) TQ.ioProperty (order conn)+      propDistinct  = fmap          TQ.ioProperty (distinct conn)+      propRestrict  = fmap          TQ.ioProperty (restrict conn)++  let t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p++  t propFmap+  t propApply+  t propLimit+  t propOffset+  t propOrder+  t propDistinct+  t propRestrict++-- }++-- { Utilities++nub :: Ord a => [a] -> [a]+nub = Set.toList . Set.fromList++eitherPP :: (D.Default p a a', D.Default p b b',+             PP.SumProfunctor p, PP.ProductProfunctor p)+         => p [Either a b] [Either a' b']+eitherPP = PP.list (D.def PP.+++! D.def)++errorIfNotSuccess :: TQ.Result -> IO ()+errorIfNotSuccess r = case r of+  TQ.Success _ _ _ -> return ()+  _                -> error "Failed"++firstBoolOrTrue :: b -> [Either a b] -> (b, [Either a b])+firstBoolOrTrue true c = (b, c)+  where b = case Maybe.mapMaybe isBool c of+          []    -> true+          (x:_) -> x++isBool :: Either a b+       -> Maybe b+isBool (Left _)  = Nothing+isBool (Right l) = Just l++restrictFirstBool :: O.QueryArr Columns Columns+restrictFirstBool = Arrow.arr snd+      Arrow.<<< Arrow.first O.restrict+      Arrow.<<< Arrow.arr (firstBoolOrTrue (O.pgBool True))++restrictFirstBoolList :: [Haskells] -> [Haskells]+restrictFirstBoolList = map snd+                        . filter fst+                        . map (firstBoolOrTrue True)++-- }

@@ -3,6 +3,8 @@  module Main where +import qualified QuickCheck+ import           Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>)) import qualified Opaleye as O @@ -16,6 +18,7 @@ import qualified Data.String as String  import qualified System.Exit as Exit+import qualified System.Environment as Environment  import qualified Control.Applicative as A import qualified Control.Arrow as Arr@@ -35,6 +38,13 @@                                , PGS.connectPassword = "tom"                                , PGS.connectDatabase = "opaleye_test" } +connectInfoTravis :: PGS.ConnectInfo+connectInfoTravis =  PGS.ConnectInfo { PGS.connectHost = "localhost"+                                     , PGS.connectPort = 5432+                                     , PGS.connectUser = "postgres"+                                     , PGS.connectPassword = ""+                                     , PGS.connectDatabase = "opaleye_test" }+ -- }  {-@@ -115,8 +125,9 @@ table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1 +-- This is implicitly testing our ability to handle upper case letters in table names. table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)-table2 = twoIntTable "table2"+table2 = twoIntTable "TABLE2"  table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table3 = twoIntTable "table3"@@ -124,6 +135,13 @@ table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) table4 = twoIntTable "table4" +table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column  O.PGInt4))+                  (Column O.PGInt4, Column O.PGInt4)+table5 = O.Table "table5" (PP.p2 (O.optional "column1", O.optional "column2"))++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"))+ 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"))@@ -137,6 +155,9 @@ table3Q :: Query (Column O.PGInt4, Column O.PGInt4) table3Q = O.queryTable table3 +table6Q :: Query (Column O.PGText, Column O.PGText)+table6Q = O.queryTable table6+ table1dataG :: Num a => [(a, a)] table1dataG = [ (1, 100)               , (1, 100)@@ -178,14 +199,38 @@ table4columndata :: [(Column O.PGInt4, Column O.PGInt4)] table4columndata = table4dataG -dropAndCreateTable :: (String, [String]) -> PGS.Query-dropAndCreateTable (t, cols) = String.fromString drop_-  where drop_ = "DROP TABLE IF EXISTS " ++ t ++ ";"-                ++ "CREATE TABLE " ++ t+table6data :: [(String, String)]+table6data = [("xy", "a"), ("z", "a"), ("more text", "a")]++table6columndata :: [(Column O.PGText, Column O.PGText)]+table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data++-- We have to quote the table names here because upper case letters in+-- table names are treated as lower case unless the name is quoted!+dropAndCreateTable :: String -> (String, [String]) -> PGS.Query+dropAndCreateTable columnType (t, cols) = String.fromString drop_+  where drop_ = "DROP TABLE IF EXISTS \"" ++ t ++ "\";"+                ++ "CREATE TABLE \"" ++ t ++ "\""                 ++ " (" ++ commas cols ++ ");"-        integer c = ("\"" ++ c ++ "\"" ++ " integer")+        integer c = ("\"" ++ c ++ "\"" ++ " " ++ columnType)         commas = L.intercalate "," . map integer-        ++dropAndCreateTableInt :: (String, [String]) -> PGS.Query+dropAndCreateTableInt = dropAndCreateTable "integer"++dropAndCreateTableText :: (String, [String]) -> PGS.Query+dropAndCreateTableText = dropAndCreateTable "text"++-- 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!+dropAndCreateTableSerial :: (String, [String]) -> PGS.Query+dropAndCreateTableSerial (t, cols) = String.fromString drop_+  where drop_ = "DROP TABLE IF EXISTS \"" ++ t ++ "\";"+                ++ "CREATE TABLE \"" ++ t ++ "\""+                ++ " (" ++ commas cols ++ ");"+        integer c = ("\"" ++ c ++ "\"" ++ " SERIAL")+        commas = L.intercalate "," . map integer+ type Table_ = (String, [String])  -- This should ideally be derived from the table definition above@@ -194,12 +239,20 @@  -- This should ideally be derived from the table definition above tables :: [Table_]-tables = map columns2 ["table1", "table2", "table3", "table4"]+tables = map columns2 ["table1", "TABLE2", "table3", "table4"]          ++ [("keywordtable", ["column", "where"])] +serialTables :: [Table_]+serialTables = map columns2 ["table5"]+ dropAndCreateDB :: PGS.Connection -> IO ()-dropAndCreateDB conn = mapM_ execute tables-  where execute = PGS.execute_ conn . dropAndCreateTable+dropAndCreateDB conn = do+  mapM_ execute tables+  executeTextTable+  mapM_ executeSerial serialTables+  where execute = PGS.execute_ conn . dropAndCreateTableInt+        executeTextTable = (PGS.execute_ conn . dropAndCreateTableText . columns2) "table6"+        executeSerial = PGS.execute_ conn . dropAndCreateTableSerial  type Test = PGS.Connection -> IO Bool @@ -266,14 +319,14 @@ testDistinct = testG (O.distinct table1Q)                (\r -> L.sort (L.nub table1data) == L.sort r) --- FIXME: the unsafeCoerce is currently needed because the type+-- FIXME: the unsafeCoerceColumn is currently needed because the type -- changes required for aggregation are not currently dealt with by -- Opaleye. aggregateCoerceFIXME :: QueryArr (Column O.PGInt4) (Column O.PGInt8) aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME'  aggregateCoerceFIXME' :: Column a -> Column O.PGInt8-aggregateCoerceFIXME' = O.unsafeCoerce+aggregateCoerceFIXME' = O.unsafeCoerceColumn  testAggregate :: Test testAggregate = testG (Arr.second aggregateCoerceFIXME@@ -289,6 +342,18 @@                            (\(x, y) -> aggregateCoerceFIXME' x * y)                            (PP.p2 (O.sum, O.count)) +testStringArrayAggregate :: Test+testStringArrayAggregate = testG q expected+  where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q+        expected r = [(map fst table6data, minimum (map snd table6data))] == r++testStringAggregate :: Test+testStringAggregate = testG q expected+  where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q+        expected r = [(+          (foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data ,+          head (map snd table6data))] == r+ testOrderByG :: O.Order (Column O.PGInt4, Column O.PGInt4)                 -> ((Int, Int) -> (Int, Int) -> Ordering)                 -> Test@@ -450,6 +515,7 @@       then return False       else do       returned <- O.runInsertReturning conn table4 insertT returning+      _ <- O.runInsertMany conn table4 insertTMany       resultI <- runQueryTable4        return ((resultI == expectedI) && (returned == expectedR))@@ -467,8 +533,11 @@         insertT :: (Column O.PGInt4, Column O.PGInt4)         insertT = (1, 2) +        insertTMany :: [(Column O.PGInt4, Column O.PGInt4)]+        insertTMany = [(20, 30), (40, 50)]+         expectedI :: [(Int, Int)]-        expectedI = [(1, 10), (1, 2)]+        expectedI = [(1, 10), (1, 2), (20, 30), (40, 50)]         returning (x, y) = x - y         expectedR :: [Int]         expectedR = [-1]@@ -480,24 +549,59 @@   _ <- q   return True -  +testInsertSerial :: Test+testInsertSerial conn = do+  _ <- O.runInsert conn table5 (Just 10, Just 20)+  _ <- O.runInsert conn table5 (Just 30, Nothing)+  _ <- O.runInsert conn table5 (Nothing, Nothing)+  _ <- O.runInsert conn table5 (Nothing, Just 40) +  resultI <- O.runQuery conn (O.queryTable table5)++  return (resultI == expected)++  where expected :: [(Int, Int)]+        expected = [ (10, 20)+                   , (30, 1)+                   , (1, 2)+                   , (2, 40) ]+ allTests :: [Test] allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase,-            testDistinct, testAggregate, testAggregateProfunctor,+            testDistinct, testAggregate, testAggregateProfunctor, testStringAggregate,             testOrderBy, testOrderBy2, testOrderBySame, testLimit, testOffset,             testLimitOffset, testOffsetLimit, testDistinctAndAggregate,             testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin,             testDoubleValues, testDoubleUnionAll,             testLeftJoin, testLeftJoinNullable, testThreeWayProduct, testValues,             testValuesEmpty, testUnionAll, testTableFunctor, testUpdate,-            testKeywordColNames+            testKeywordColNames, testInsertSerial            ] +-- Environment.getEnv throws an exception on missing environment variable!+getEnv :: String -> IO (Maybe String)+getEnv var = do+  environment <- Environment.getEnvironment+  return (lookup var environment)++-- Using an envvar is unpleasant, but it will do for now.+travis :: IO Bool+travis = do+    travis' <- getEnv "TRAVIS"++    return (case travis' of+               Nothing    -> False+               Just "yes" -> True+               Just _     -> False)+ main :: IO () main = do-  conn <- PGS.connect connectInfo+  travis' <- travis +  let connectInfo' = if travis' then connectInfoTravis else connectInfo++  conn <- PGS.connect connectInfo'+   dropAndCreateDB conn    let insert (writeable, columndata) =@@ -507,6 +611,10 @@                , (table2, table2columndata)                , (table3, table3columndata)                , (table4, table4columndata) ]+  insert (table6, table6columndata)++  -- Need to run quickcheck after table data has been inserted+  QuickCheck.run conn    results <- mapM ($ conn) allTests 

@@ -1,12 +1,14 @@ name:            opaleye-version:         0.3.1.2+copyright:       Copyright (c) 2014-2015 Purely Agile Limited+version:         0.4.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                  typesafe and composable fashion. homepage:        https://github.com/tomjaguarpaw/haskell-opaleye+bug-reports:     https://github.com/tomjaguarpaw/haskell-opaleye/issues license:         BSD3-license-File:    LICENSE+license-file:    LICENSE author:          Purely Agile maintainer:      Purely Agile category:        Database@@ -14,32 +16,34 @@ cabal-version:   >= 1.8 extra-doc-files: *.md,                  Doc/*.md+tested-with:     GHC==7.10.1, GHC==7.8.4, GHC==7.6.3  source-repository head-  Type:     git-  Location: https://github.com/tomjaguarpaw/haskell-opaleye+  type:     git+  location: https://github.com/tomjaguarpaw/haskell-opaleye.git  library   hs-source-dirs: src   build-depends:       -- attoparsec can be removed once postgresql-simple patch in       -- Internal.RunQuery is merged upstream-      attoparsec          >= 0.10.3  && < 0.13+      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       >= 0.4.4   && < 1.4+    , contravariant       >= 1.2     && < 1.4     , postgresql-simple   >= 0.4.8.0 && < 0.5     , pretty              >= 1.1.1.0 && < 1.2-    , product-profunctors >= 0.5     && < 0.7-    , profunctors         >= 4.0     && < 4.5+    , product-profunctors >= 0.6.2   && < 0.7+    , profunctors         >= 4.0     && < 5.2     , semigroups          >= 0.13    && < 0.17     , text                >= 0.11    && < 1.3     , transformers        >= 0.3     && < 0.5     , time                >= 1.4     && < 1.6     , time-locale-compat  >= 0.1     && < 0.2     , uuid                >= 1.3     && < 1.4+    , void                >= 0.4     && < 0.8   exposed-modules: Opaleye,                    Opaleye.Aggregate,                    Opaleye.Binary,@@ -64,6 +68,7 @@                    Opaleye.Internal.Order,                    Opaleye.Internal.Optimize,                    Opaleye.Internal.PackMap,+                   Opaleye.Internal.PGTypes,                    Opaleye.Internal.PrimQuery,                    Opaleye.Internal.Print,                    Opaleye.Internal.QueryArr,@@ -84,12 +89,17 @@ test-suite test   type: exitcode-stdio-1.0   main-is: Test.hs+  other-modules: QuickCheck   hs-source-dirs: Test   build-depends:     base >= 4 && < 5,+    containers,+    contravariant,     postgresql-simple,     profunctors,     product-profunctors,+    QuickCheck,+    semigroups,     opaleye   ghc-options: -Wall 

@@ -3,9 +3,11 @@  import qualified Opaleye.Internal.Aggregate as A import           Opaleye.Internal.Aggregate (Aggregator)+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 @@ -39,11 +41,11 @@ avg = A.makeAggr HPQ.AggrAvg  -- | Maximum of a group-max :: Aggregator (C.Column a) (C.Column a)+max :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) max = A.makeAggr HPQ.AggrMax  -- | Maximum of a group-min :: Aggregator (C.Column a) (C.Column a)+min :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) min = A.makeAggr HPQ.AggrMin  boolOr :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool)@@ -51,3 +53,9 @@  boolAnd :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool) boolAnd = A.makeAggr HPQ.AggrBoolAnd++arrayAgg :: Aggregator (C.Column a) (C.Column (T.PGArray a))+arrayAgg = A.makeAggr HPQ.AggrArr++stringAgg :: C.Column T.PGText -> Aggregator (C.Column T.PGText) (C.Column T.PGText)+stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn

@@ -1,9 +1,10 @@ module Opaleye.Column (module Opaleye.Column,                        Column,                        Nullable,-                       unsafeCoerce)  where+                       unsafeCoerce,+                       unsafeCoerceColumn)  where -import           Opaleye.Internal.Column (Column, Nullable, unsafeCoerce)+import           Opaleye.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.PGTypes as T@@ -24,7 +25,7 @@ matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a)               -> Column b matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement-                                                   (f (unsafeCoerce x))+                                                   (f (unsafeCoerceColumn x))  -- | If the @Column (Nullable a)@ is NULL then return the provided -- @Column a@ otherwise return the underlying @Column a@.@@ -35,7 +36,7 @@  -- | The Opaleye equivalent of 'Data.Maybe.Just' toNullable :: Column a -> Column (Nullable a)-toNullable = unsafeCoerce+toNullable = unsafeCoerceColumn  -- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the -- provided value coerced to a nullable type.

@@ -16,6 +16,11 @@ An 'Aggregator' takes a collection of rows of type @a@, groups them, and transforms each group into a single row of type @b@. This corresponds to aggregators using @GROUP BY@ in SQL.++An 'Aggregator' corresponds closely to a 'Control.Foldl.Fold' from the+@foldl@ package.  Whereas an 'Aggregator' @a@ @b@ takes each group of+type @a@ to a single row of type @b@, a 'Control.Foldl.Fold' @a@ @b@+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@@ -30,7 +35,7 @@  runAggregator :: Applicative f => Aggregator a b               -> ((Maybe HPQ.AggrOp, HPQ.PrimExpr) -> f HPQ.PrimExpr) -> a -> f b-runAggregator (Aggregator a) = PM.packmap a+runAggregator (Aggregator a) = PM.traversePM a  aggregateU :: Aggregator a b            -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)@@ -59,5 +64,8 @@ instance PP.ProductProfunctor Aggregator where   empty = PP.defaultEmpty   (***!) = PP.defaultProfunctorProduct++instance PP.SumProfunctor Aggregator where+  Aggregator x1 +++! Aggregator x2 = Aggregator (x1 PP.+++! x2)  -- }

@@ -21,14 +21,14 @@                              HPQ.PrimExpr extractBinaryFields = PM.extractAttr "binary" -data Binaryspec columns columns' =+newtype Binaryspec columns columns' =   Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr                          (columns, columns) columns')  runBinaryspec :: Applicative f => Binaryspec columns columns'                  -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr)                  -> (columns, columns) -> f columns'-runBinaryspec (Binaryspec b) = PM.packmap b+runBinaryspec (Binaryspec b) = PM.traversePM b  binaryspecColumn :: Binaryspec (Column a) (Column a) binaryspecColumn = Binaryspec (PM.PackMap (\f (Column e, Column e')

@@ -12,8 +12,12 @@ unColumn :: Column a -> HPQ.PrimExpr unColumn (Column e) = e +{-# DEPRECATED unsafeCoerce "Use unsafeCoerceColumn instead" #-} unsafeCoerce :: Column a -> Column b-unsafeCoerce (Column e) = Column e+unsafeCoerce = unsafeCoerceColumn++unsafeCoerceColumn :: Column a -> Column b+unsafeCoerceColumn (Column e) = Column e  binOp :: HPQ.BinOp -> Column a -> Column b -> Column c binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e')

@@ -20,7 +20,7 @@                  -> Query columns -> Query columns' distinctExplicit (Distinctspec agg) = aggregate agg -data Distinctspec a b = Distinctspec (Aggregator a b)+newtype Distinctspec a b = Distinctspec (Aggregator a b)  instance Default Distinctspec (Column a) (Column a) where   def = Distinctspec groupBy@@ -40,5 +40,8 @@ instance PP.ProductProfunctor Distinctspec where   empty = PP.defaultEmpty   (***!) = PP.defaultProfunctorProduct++instance PP.SumProfunctor Distinctspec where+  Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2)  -- }

@@ -21,26 +21,31 @@                 | UnExpr    UnOp PrimExpr                 | AggrExpr  AggrOp PrimExpr                 | ConstExpr Literal-		| CaseExpr [(PrimExpr,PrimExpr)] PrimExpr+                | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr                 | ListExpr [PrimExpr]                 | ParamExpr (Maybe Name) PrimExpr                 | FunExpr Name [PrimExpr]                 | CastExpr Name PrimExpr -- ^ Cast an expression to a given type.+                | DefaultInsertExpr -- Indicate that we want to insert the+                                    -- default value into a column.+                                    -- TODO: I'm not sure this belongs+                                    -- here.  Perhaps a special type is+                                    -- needed for insert expressions.                 deriving (Read,Show)  data Literal = NullLit-	     | DefaultLit            -- ^ represents a default value-	     | BoolLit Bool-	     | StringLit String+             | DefaultLit            -- ^ represents a default value+             | BoolLit Bool+             | StringLit String              | ByteStringLit ByteString-	     | IntegerLit Integer-	     | DoubleLit Double-	     | OtherLit String       -- ^ used for hacking in custom SQL-	       deriving (Read,Show)+             | IntegerLit Integer+             | DoubleLit Double+             | OtherLit String       -- ^ used for hacking in custom SQL+               deriving (Read,Show) -data BinOp      = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq +data BinOp      = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq                 | OpAnd | OpOr-                | OpLike | OpIn +                | OpLike | OpIn                 | OpOther String                  | OpCat@@ -62,12 +67,19 @@  data AggrOp     = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax                 | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP-                | AggrBoolOr | AggrBoolAnd+                | AggrBoolOr | AggrBoolAnd | AggrArr | AggrStringAggr PrimExpr                 | AggrOther String                 deriving (Show,Read) -data OrderExpr = OrderExpr OrderOp PrimExpr +data OrderExpr = OrderExpr OrderOp PrimExpr                deriving (Show) -data OrderOp = OpAsc | OpDesc+data OrderNulls = NullsFirst | NullsLast+                deriving Show++data OrderDirection = OpAsc | OpDesc+                    deriving Show++data OrderOp = OrderOp { orderDirection :: OrderDirection+                       , orderNulls     :: OrderNulls }                deriving (Show)

@@ -2,32 +2,30 @@ --                HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License     :  BSD-style -module Opaleye.Internal.HaskellDB.Sql ( -                               SqlTable,-                               SqlColumn(..),-                               SqlName,-                               SqlOrder(..),+module Opaleye.Internal.HaskellDB.Sql where -	                       SqlUpdate(..), -	                       SqlDelete(..), -	                       SqlInsert(..),  -                               SqlExpr(..),-	                      ) where-+import qualified Data.List.NonEmpty as NEL  ----------------------------------------------------------- -- * SQL data type ----------------------------------------------------------- -type SqlTable = String+newtype SqlTable = SqlTable String deriving Show  newtype SqlColumn = SqlColumn String deriving Show  -- | A valid SQL name for a parameter. type SqlName = String -data SqlOrder = SqlAsc | SqlDesc+data SqlOrderNulls = SqlNullsFirst | SqlNullsLast+                   deriving Show++data SqlOrderDirection = SqlAsc | SqlDesc+                       deriving Show++data SqlOrder = SqlOrder { sqlOrderDirection :: SqlOrderDirection+                         , sqlOrderNulls     :: SqlOrderNulls }   deriving Show  -- | Expressions in SQL statements.@@ -38,12 +36,13 @@              | FunSqlExpr     String [SqlExpr]              | AggrFunSqlExpr String [SqlExpr] -- ^ Aggregate functions separate from normal functions.              | ConstSqlExpr   String-	     | CaseSqlExpr    [(SqlExpr,SqlExpr)] SqlExpr+             | CaseSqlExpr    [(SqlExpr,SqlExpr)] SqlExpr              | ListSqlExpr    [SqlExpr]              | ParamSqlExpr (Maybe SqlName) SqlExpr              | PlaceHolderSqlExpr              | ParensSqlExpr SqlExpr-             | CastSqlExpr String SqlExpr +             | CastSqlExpr String SqlExpr+             | DefaultSqlExpr   deriving Show  -- | Data type for SQL UPDATE statements.@@ -53,4 +52,4 @@ data SqlDelete  = SqlDelete SqlTable [SqlExpr]  --- | Data type for SQL INSERT statements.-data SqlInsert  = SqlInsert      SqlTable [SqlColumn] [SqlExpr]+data SqlInsert  = SqlInsert SqlTable [SqlColumn] (NEL.NonEmpty [SqlExpr])

@@ -5,15 +5,18 @@ module Opaleye.Internal.HaskellDB.Sql.Default  where  import Opaleye.Internal.HaskellDB.PrimQuery+import qualified Opaleye.Internal.HaskellDB.PrimQuery as PQ import Opaleye.Internal.HaskellDB.Sql import Opaleye.Internal.HaskellDB.Sql.Generate+import qualified Opaleye.Internal.HaskellDB.Sql as Sql import Opaleye.Internal.Tag (tagWith) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Base16 as Base16+import qualified Data.List.NonEmpty as NEL  mkSqlGenerator :: SqlGenerator -> SqlGenerator-mkSqlGenerator gen = SqlGenerator +mkSqlGenerator gen = SqlGenerator     {      sqlUpdate      = defaultSqlUpdate      gen,      sqlDelete      = defaultSqlDelete      gen,@@ -28,43 +31,52 @@   toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)-toSqlOrder gen (OrderExpr o e) = (sqlExpr gen e, o')-    where o' = case o of-                 OpAsc  -> SqlAsc-                 OpDesc -> SqlDesc+toSqlOrder gen (OrderExpr o e) =+  (sqlExpr gen e, Sql.SqlOrder { sqlOrderDirection = o'+                               , sqlOrderNulls     = orderNulls' })+    where o' = case PQ.orderDirection o of+            PQ.OpAsc  -> Sql.SqlAsc+            PQ.OpDesc -> Sql.SqlDesc+          orderNulls' = case PQ.orderNulls o of+            PQ.NullsFirst -> Sql.SqlNullsFirst+            PQ.NullsLast  -> Sql.SqlNullsLast ++toSqlColumn :: Attribute -> SqlColumn+toSqlColumn attr = SqlColumn attr+ toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]-toSqlAssoc gen = map (\(attr,expr) -> (SqlColumn attr, sqlExpr gen expr))+toSqlAssoc gen = map (\(attr,expr) -> (toSqlColumn attr, sqlExpr gen expr))  -defaultSqlUpdate :: SqlGenerator +defaultSqlUpdate :: SqlGenerator                  -> TableName  -- ^ Name of the table to update.-	         -> [PrimExpr] -- ^ Conditions which must all be true for a row+                 -> [PrimExpr] -- ^ Conditions which must all be true for a row                                --   to be updated.                  -> Assoc -- ^ Update the data with this.-	         -> SqlUpdate+                 -> SqlUpdate defaultSqlUpdate gen name criteria assigns-        = SqlUpdate name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria) +        = SqlUpdate (SqlTable name) (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria)  -defaultSqlInsert :: SqlGenerator -                 -> TableName -- ^ Name of the table-	         -> Assoc -- ^ What to insert.-	         -> SqlInsert-defaultSqlInsert gen table assoc = SqlInsert table cs es-    where (cs,es) = unzip (toSqlAssoc gen assoc)-+defaultSqlInsert :: SqlGenerator+                 -> TableName+                 -> [Attribute]+                 -> NEL.NonEmpty [PrimExpr]+                 -> SqlInsert+defaultSqlInsert gen name attrs exprs =+  SqlInsert (SqlTable name) (map toSqlColumn attrs) ((fmap . map) (sqlExpr gen) exprs) -defaultSqlDelete :: SqlGenerator +defaultSqlDelete :: SqlGenerator                  -> TableName -- ^ Name of the table-	         -> [PrimExpr] -- ^ Criteria which must all be true for a row+                 -> [PrimExpr] -- ^ Criteria which must all be true for a row                                --   to be deleted.-	         -> SqlDelete-defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)+                 -> SqlDelete+defaultSqlDelete gen name criteria = SqlDelete (SqlTable name) (map (sqlExpr gen) criteria)   defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr-defaultSqlExpr gen expr = +defaultSqlExpr gen expr =     case expr of       AttrExpr (Symbol a t) -> ColumnSqlExpr (SqlColumn (tagWith t a))       BaseTableAttrExpr a -> ColumnSqlExpr (SqlColumn a)@@ -99,39 +111,49 @@                                 UnOpFun     -> FunSqlExpr op' [e']                                 UnOpPrefix  -> PrefixSqlExpr op' (ParensSqlExpr e')                                 UnOpPostfix -> PostfixSqlExpr op' e'+      -- TODO: The current arrangement whereby the delimeter parameter+      -- of string_agg is in the AggrStringAggr constructor, but the+      -- parameter being aggregated is not, seems unsatisfactory+      -- 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-                           in AggrFunSqlExpr op' [e']+                              moreAggrFunParams = case op of+                                AggrStringAggr primE -> [sqlExpr gen primE]+                                _ -> []+                           in AggrFunSqlExpr op' (e' : moreAggrFunParams)       ConstExpr l      -> ConstSqlExpr (sqlLiteral gen l)-      CaseExpr cs e    -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] +      CaseExpr cs e    -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs]                               e'  = sqlExpr gen e                            in CaseSqlExpr cs' e'       ListExpr es      -> ListSqlExpr (map (sqlExpr gen) es)       ParamExpr n _    -> ParamSqlExpr n PlaceHolderSqlExpr       FunExpr n exprs  -> FunSqlExpr n (map (sqlExpr gen) exprs)       CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1)+      DefaultInsertExpr -> DefaultSqlExpr  showBinOp :: BinOp -> String-showBinOp  OpEq         = "=" -showBinOp  OpLt         = "<" -showBinOp  OpLtEq       = "<=" -showBinOp  OpGt         = ">" -showBinOp  OpGtEq       = ">=" -showBinOp  OpNotEq      = "<>" -showBinOp  OpAnd        = "AND"  -showBinOp  OpOr         = "OR" -showBinOp  OpLike       = "LIKE" -showBinOp  OpIn         = "IN" +showBinOp  OpEq         = "="+showBinOp  OpLt         = "<"+showBinOp  OpLtEq       = "<="+showBinOp  OpGt         = ">"+showBinOp  OpGtEq       = ">="+showBinOp  OpNotEq      = "<>"+showBinOp  OpAnd        = "AND"+showBinOp  OpOr         = "OR"+showBinOp  OpLike       = "LIKE"+showBinOp  OpIn         = "IN" showBinOp  (OpOther s)  = s-showBinOp  OpCat        = "||" -showBinOp  OpPlus       = "+" -showBinOp  OpMinus      = "-" -showBinOp  OpMul        = "*" -showBinOp  OpDiv        = "/" -showBinOp  OpMod        = "MOD" -showBinOp  OpBitNot     = "~" -showBinOp  OpBitAnd     = "&" -showBinOp  OpBitOr      = "|" +showBinOp  OpCat        = "||"+showBinOp  OpPlus       = "+"+showBinOp  OpMinus      = "-"+showBinOp  OpMul        = "*"+showBinOp  OpDiv        = "/"+showBinOp  OpMod        = "MOD"+showBinOp  OpBitNot     = "~"+showBinOp  OpBitAnd     = "&"+showBinOp  OpBitOr      = "|" showBinOp  OpBitXor     = "^" showBinOp  OpAsg        = "=" @@ -151,22 +173,24 @@   showAggrOp :: AggrOp -> String-showAggrOp AggrCount    = "COUNT" -showAggrOp AggrSum      = "SUM" -showAggrOp AggrAvg      = "AVG" -showAggrOp AggrMin      = "MIN" -showAggrOp AggrMax      = "MAX" -showAggrOp AggrStdDev   = "StdDev" -showAggrOp AggrStdDevP  = "StdDevP" -showAggrOp AggrVar      = "Var" -showAggrOp AggrVarP     = "VarP"                -showAggrOp AggrBoolAnd  = "BOOL_AND"-showAggrOp AggrBoolOr   = "BOOL_OR"-showAggrOp (AggrOther s)        = s+showAggrOp AggrCount          = "COUNT"+showAggrOp AggrSum            = "SUM"+showAggrOp AggrAvg            = "AVG"+showAggrOp AggrMin            = "MIN"+showAggrOp AggrMax            = "MAX"+showAggrOp AggrStdDev         = "StdDev"+showAggrOp AggrStdDevP        = "StdDevP"+showAggrOp AggrVar            = "Var"+showAggrOp AggrVarP           = "VarP"+showAggrOp AggrBoolAnd        = "BOOL_AND"+showAggrOp AggrBoolOr         = "BOOL_OR"+showAggrOp AggrArr            = "ARRAY_AGG"+showAggrOp (AggrStringAggr _) = "STRING_AGG"+showAggrOp (AggrOther s)      = s   defaultSqlLiteral :: SqlGenerator -> Literal -> String-defaultSqlLiteral _ l = +defaultSqlLiteral _ l =     case l of       NullLit       -> "NULL"       DefaultLit    -> "DEFAULT"@@ -186,7 +210,7 @@ -- | Quote a string and escape characters that need escaping --   We use Postgres "escape strings", i.e. strings prefixed --   with E, to ensure that escaping with backslash is valid.-quote :: String -> String +quote :: String -> String quote s = "E'" ++ concatMap escape s ++ "'"  -- | Escape characters that need escaping

@@ -7,12 +7,13 @@ import Opaleye.Internal.HaskellDB.PrimQuery import Opaleye.Internal.HaskellDB.Sql +import qualified Data.List.NonEmpty as NEL  data SqlGenerator = SqlGenerator     {      sqlUpdate      :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate,      sqlDelete      :: TableName -> [PrimExpr] -> SqlDelete,-     sqlInsert      :: TableName -> Assoc -> SqlInsert,+     sqlInsert      :: TableName -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert,      sqlExpr        :: PrimExpr -> SqlExpr,      sqlLiteral     :: Literal -> String,      -- | Turn a string into a quoted string. Quote characters

@@ -2,24 +2,27 @@ --                HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License     :  BSD-style -module Opaleye.Internal.HaskellDB.Sql.Print ( +module Opaleye.Internal.HaskellDB.Sql.Print (                                      ppUpdate,-                                     ppDelete, +                                     ppDelete,                                      ppInsert,                                      ppSqlExpr,                                      ppWhere,                                      ppGroupBy,                                      ppOrderBy,+                                     ppTable,                                      ppAs,                                      commaV,                                      commaH-	                            ) where+                                    ) where  import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),                                SqlExpr(..), SqlOrder(..), SqlInsert(..),-                               SqlUpdate(..))+                               SqlUpdate(..), SqlTable(..))+import qualified Opaleye.Internal.HaskellDB.Sql as Sql  import Data.List (intersperse)+import qualified Data.List.NonEmpty as NEL import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, doubleQuotes,                                   empty, equals, hcat, hsep, parens, punctuate,                                   text, vcat)@@ -27,7 +30,7 @@  ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty-ppWhere es = text "WHERE" +ppWhere es = text "WHERE"              <+> hsep (intersperse (text "AND")                        (map (parens . ppSqlExpr) es)) @@ -38,25 +41,41 @@     ppGroupAttrs cs = commaV nameOrExpr cs     nameOrExpr :: SqlExpr -> Doc     nameOrExpr (ColumnSqlExpr (SqlColumn col)) = text col-    nameOrExpr expr = parens (ppSqlExpr expr)-    +    -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column+    -- Any identity function will do+    --  nameOrExpr expr = parens (ppSqlExpr expr)+    nameOrExpr expr = text "COALESCE" <+> parens (ppSqlExpr expr)+ ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord     where-      ppOrd (e,o) = ppSqlExpr e <+> ppSqlOrder o-      ppSqlOrder :: SqlOrder -> Doc-      ppSqlOrder SqlAsc = text "ASC"-      ppSqlOrder SqlDesc = text "DESC"+    -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column+    -- Any identity function will do+    --   ppOrd (e,o) = ppSqlExpr e <+> ppSqlDirection o <+> ppSqlNulls o+      ppOrd (e,o) = text "COALESCE"+                      <+> parens (ppSqlExpr e)+                      <+> ppSqlDirection o+                      <+> ppSqlNulls o +ppSqlDirection :: Sql.SqlOrder -> Doc+ppSqlDirection x = text $ case Sql.sqlOrderDirection x of+  Sql.SqlAsc  -> "ASC"+  Sql.SqlDesc -> "DESC"++ppSqlNulls :: Sql.SqlOrder -> Doc+ppSqlNulls x = text $ case Sql.sqlOrderNulls x of+        Sql.SqlNullsFirst -> "NULLS FIRST"+        Sql.SqlNullsLast  -> "NULLS LAST"+ ppAs :: String -> Doc -> Doc-ppAs alias expr    | null alias    = expr                               -                   | otherwise     = expr <+> (hsep . map text) ["as",alias]+ppAs alias expr    | null alias    = expr+                   | otherwise     = expr <+> hsep [text "as", doubleQuotes (text alias)]   ppUpdate :: SqlUpdate -> Doc-ppUpdate (SqlUpdate name assigns criteria)-        = text "UPDATE" <+> text name+ppUpdate (SqlUpdate table assigns criteria)+        = text "UPDATE" <+> ppTable table         $$ text "SET" <+> commaV ppAssign assigns         $$ ppWhere criteria     where@@ -64,16 +83,16 @@   ppDelete :: SqlDelete -> Doc-ppDelete (SqlDelete name criteria) =-    text "DELETE FROM" <+> text name $$ ppWhere criteria+ppDelete (SqlDelete table criteria) =+    text "DELETE FROM" <+> ppTable table $$ ppWhere criteria   ppInsert :: SqlInsert -> Doc- ppInsert (SqlInsert table names values)-    = text "INSERT INTO" <+> text table +    = text "INSERT INTO" <+> ppTable table       <+> parens (commaV ppColumn names)-      $$ text "VALUES" <+> parens (commaV ppSqlExpr values)+      $$ text "VALUES" <+> commaV (\v -> parens (commaV ppSqlExpr v))+                                  (NEL.toList values)  -- If we wanted to make the SQL slightly more readable this would be -- one easy place to do it.  Currently we wrap all column references@@ -83,13 +102,17 @@ ppColumn :: SqlColumn -> Doc ppColumn (SqlColumn s) = doubleQuotes (text s) +-- Postgres treats upper case letters in table names as lower case,+-- unless the name is quoted!+ppTable :: SqlTable -> Doc+ppTable (SqlTable s) = doubleQuotes (text s)  ppSqlExpr :: SqlExpr -> Doc ppSqlExpr expr =     case expr of       ColumnSqlExpr c     -> ppColumn c       ParensSqlExpr e -> parens (ppSqlExpr e)-      BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2 +      BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2       PrefixSqlExpr op e  -> text op <+> ppSqlExpr e       PostfixSqlExpr op e -> ppSqlExpr e <+> text op       FunSqlExpr f es     -> text f <> parens (commaH ppSqlExpr es)@@ -97,13 +120,13 @@       ConstSqlExpr c      -> text c       CaseSqlExpr cs el   -> text "CASE" <+> vcat (map ppWhen cs)                              <+> text "ELSE" <+> ppSqlExpr el <+> text "END"-          where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w +          where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w                                <+> text "THEN" <+> ppSqlExpr t       ListSqlExpr es      -> parens (commaH ppSqlExpr es)       ParamSqlExpr _ v -> ppSqlExpr v       PlaceHolderSqlExpr -> text "?"       CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ)-    +      DefaultSqlExpr    -> text "DEFAULT"  commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f

@@ -14,3 +14,8 @@  (.::) :: (r -> z) -> (a -> b -> c -> d -> r) -> a -> b -> c -> d -> z (.::) f g a b c d = f (g a b c d)++infixr 8 .::.++(.::.) :: (r -> z) -> (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> z+(.::.) f g a b c d e = f (g a b c d e)

@@ -13,7 +13,7 @@  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -data NullMaker a b = NullMaker (a -> b)+newtype NullMaker a b = NullMaker (a -> b)  toNullable :: NullMaker a b -> a -> b toNullable (NullMaker f) = f@@ -23,10 +23,10 @@ extractLeftJoinFields n = PM.extractAttr ("result" ++ show n ++ "_")  instance D.Default NullMaker (Column a) (Column (Nullable a)) where-  def = NullMaker C.unsafeCoerce+  def = NullMaker C.unsafeCoerceColumn  instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where-  def = NullMaker C.unsafeCoerce+  def = NullMaker C.unsafeCoerceColumn  -- { Boilerplate instances 

@@ -7,13 +7,10 @@  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Data.Functor.Contravariant as C+import qualified Data.Functor.Contravariant.Divisible as Divisible import qualified Data.Profunctor as P import qualified Data.Monoid as M--data SingleOrder a = SingleOrder HPQ.OrderOp (a -> HPQ.PrimExpr)--instance C.Contravariant SingleOrder where-  contramap f (SingleOrder op g) = SingleOrder op (P.lmap f g)+import qualified Data.Void as Void  {-| An `Order` represents an expression to order on and a sort@@ -21,24 +18,37 @@ `Data.Monoid.mappend`.  If two rows are equal according to the first `Order`, the second is used, and so on. -}-newtype Order a = Order [SingleOrder a] +-- Like the (columns -> RowParser haskells) field of QueryRunner this+-- type is "too big".  We never actually look at the 'a' (in the+-- QueryRunner case the 'colums') except to check the "structure".+-- This is so we can support a SumProfunctor instance.+newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)])+ instance C.Contravariant Order where-  contramap f (Order xs) = Order (fmap (C.contramap f) xs)+  contramap f (Order g) = Order (P.lmap f g)  instance M.Monoid (Order a) where   mempty = Order M.mempty   Order o `mappend` Order o' = Order (o `M.mappend` o') +instance Divisible.Divisible Order where+  divide f o o' = M.mappend (C.contramap (fst . f) o)+                            (C.contramap (snd . f) o')+  conquer = M.mempty++instance Divisible.Decidable Order where+  lose f = C.contramap f (Order Void.absurd)+  choose f (Order o) (Order o') = C.contramap f (Order (either o o'))+ order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a-order op f = C.contramap f (Order [SingleOrder op IC.unColumn])+order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f)  orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) orderByU os (columns, primQ, t) = (columns, primQ', t)   where primQ' = PQ.Order orderExprs primQ         Order sos = os-        orderExprs = map (\(SingleOrder op f)-                          -> HPQ.OrderExpr op (f columns)) sos+        orderExprs = map (uncurry HPQ.OrderExpr) (sos columns)  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)

@@ -0,0 +1,30 @@+module Opaleye.Internal.PGTypes where++import           Opaleye.Internal.Column (Column(Column))+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ++import qualified Data.Text as SText+import qualified Data.Text.Encoding as STextEncoding+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LTextEncoding+import qualified Data.ByteString as SByteString+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.Time as Time+import qualified Data.Time.Locale.Compat as Locale++unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c+unsafePgFormatTime typeName formatString = castToType typeName . format+  where format = Time.formatTime Locale.defaultTimeLocale formatString++literalColumn :: HPQ.Literal -> Column a+literalColumn = Column . HPQ.ConstExpr++castToType :: HPQ.Name -> String -> Column c+castToType typeName =+    Column . HPQ.CastExpr typeName . HPQ.ConstExpr . HPQ.OtherLit++strictDecodeUtf8 :: SByteString.ByteString -> String+strictDecodeUtf8 = SText.unpack . STextEncoding.decodeUtf8++lazyDecodeUtf8 :: LByteString.ByteString -> String+lazyDecodeUtf8 = LText.unpack . LTextEncoding.decodeUtf8

@@ -28,18 +28,41 @@ -- and share them between many different restrictions of f.  For -- example, TableColumnMaker is like a Setter so we would restrict f -- to the Distributive case.++-- | A 'PackMap' @a@ @b@ @s@ @t@ encodes how an @s@ contains an+-- updatable sequence of @a@ inside it.  Each @a@ in the sequence can+-- be updated to a @b@ (and the @s@ changes to a @t@ to reflect this+-- change of type).+--+-- 'PackMap' is just like a @Traversal@ from the lens package.+-- 'PackMap' has a different order of arguments to @Traversal@ because+-- it typically needs to be made a 'Profunctor' (and indeed+-- '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) -packmap :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t-packmap (PackMap f) = f+-- | 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+-- 'Applicative' action.+--+-- 'traversePM' is just like @traverse@ from the @lens@ package.+-- 'traversePM' used to be called @packmap@.+traversePM :: Applicative f => PackMap a b s t -> (a -> f b) -> s -> f t+traversePM (PackMap f) = f -over :: PackMap a b s t -> (a -> b) -> s -> t-over p f = I.runIdentity . packmap p (I.Identity . f)+-- | Modify the targeted occurrences of @a@ in @s@ with @b@ (changing+-- the @s@ to a @t@ in the process).+--+-- 'overPM' is just like @over@ from the @lens@ pacakge.+overPM :: PackMap a b s t -> (a -> b) -> s -> t+overPM p f = I.runIdentity . traversePM p (I.Identity . f)  --- { A helpful monad for writing columns in the AST+-- { +-- | A helpful monad for writing columns in the AST type PM a = State.State (a, Int)  new :: PM a String@@ -62,23 +85,35 @@  -- { General functions for writing columns in the AST --- This one ignores the 'a' when making the internal column name.-extractAttr :: String -> T.Tag -> a-               -> PM [(HPQ.Symbol, a)] HPQ.PrimExpr-extractAttr s = extractAttrPE (const (s ++))---- This one can make the internal column name depend on the 'a' in--- question (probably a PrimExpr)-extractAttrPE :: (a -> String -> String) -> T.Tag -> a-               -> PM [(HPQ.Symbol, a)] HPQ.PrimExpr+-- | Make a fresh name for an input value (the variable @primExpr@+-- type is typically actually a 'HPQ.PrimExpr') based on the supplied+-- function and the unique 'T.Tag' that is used as part of our+-- @QueryArr@.+--+-- Add the fresh name and the input value it refers to to the list in+-- the state parameter.+extractAttrPE :: (primExpr -> String -> String) -> T.Tag -> primExpr+               -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr extractAttrPE mkName t pe = do   i <- new   let s = HPQ.Symbol (mkName pe i) t   write (s, pe)   return (HPQ.AttrExpr s) +-- | As 'extractAttrPE' but ignores the 'primExpr' when making the+-- fresh column name and just uses the supplied 'String' and 'T.Tag'.+extractAttr :: String -> T.Tag -> primExpr+               -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr+extractAttr s = extractAttrPE (const (s ++))+ -- } +eitherFunction :: Functor f+               => (a -> f b)+               -> (a' -> f b')+               -> Either a a'+               -> f (Either b b')+eitherFunction f g = fmap (either (fmap Left) (fmap Right)) (f PP.+++! g)  -- { @@ -98,5 +133,10 @@ instance ProductProfunctor (PackMap a b) where   empty = PP.defaultEmpty   (***!) = 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  -- }

@@ -23,7 +23,7 @@                | Aggregate [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] PrimQuery                | Order [HPQ.OrderExpr] PrimQuery                | Limit LimitOp PrimQuery-               | Join JoinType [(Symbol, HPQ.PrimExpr)] HPQ.PrimExpr PrimQuery PrimQuery+               | Join JoinType HPQ.PrimExpr PrimQuery PrimQuery                | Values [Symbol] [[HPQ.PrimExpr]]                | Binary BinOp [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery, PrimQuery)                  deriving Show@@ -34,7 +34,7 @@                        , [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> p -> p                        , [HPQ.OrderExpr] -> p -> p                        , LimitOp -> p -> p-                       , JoinType -> [(Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> p -> p -> p+                       , JoinType -> HPQ.PrimExpr -> p -> p -> p                        , [Symbol] -> [[HPQ.PrimExpr]] -> p                        , BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p                        )@@ -49,7 +49,7 @@           Aggregate aggrs pq         -> aggregate aggrs (self pq)           Order pes pq               -> order pes (self pq)           Limit op pq                -> limit op (self pq)-          Join j pes cond q1 q2      -> join j pes cond (self q1) (self q2)+          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

@@ -14,10 +14,13 @@  import           Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,                                             parens)+import qualified Data.List.NonEmpty as NEL +type TableAlias = String+ ppSql :: Select -> Doc ppSql (SelectFrom s) = ppSelectFrom s-ppSql (Table name) = text name+ppSql (Table table) = HPrint.ppTable table ppSql (SelectJoin j) = ppSelectJoin j ppSql (SelectValues v) = ppSelectValues v ppSql (SelectBinary v) = ppSelectBinary v@@ -34,8 +37,7 @@   ppSelectJoin :: Join -> Doc-ppSelectJoin j = text "SELECT"-                 <+> ppAttrs (Sql.jAttrs j)+ppSelectJoin j = text "SELECT *"                  $$  text "FROM"                  $$  ppTable (tableAlias 1 s1)                  $$  ppJoinType (Sql.jJoinType j)@@ -58,9 +60,9 @@ ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" -ppAttrs :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)] -> Doc-ppAttrs [] = text "*"-ppAttrs xs = HPrint.commaV nameAs xs+ppAttrs :: Sql.SelectAttrs -> Doc+ppAttrs Sql.Star             = text "*"+ppAttrs (Sql.SelectAttrs xs) = (HPrint.commaV nameAs . NEL.toList) xs  -- This is pretty much just nameAs from HaskellDB nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc@@ -71,21 +73,21 @@ ppTables [] = empty ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts) -tableAlias :: Int -> Select -> (HSql.SqlTable, Select)+tableAlias :: Int -> Select -> (TableAlias, Select) tableAlias i select = ("T" ++ show i, select)  -- TODO: duplication with ppSql-ppTable :: (HSql.SqlTable, Select) -> Doc+ppTable :: (TableAlias, Select) -> Doc ppTable (alias, select) = case select of-  Table name -> HPrint.ppAs alias (text name)+  Table table -> HPrint.ppAs alias (HPrint.ppTable table)   SelectFrom selectFrom -> HPrint.ppAs alias (parens (ppSelectFrom selectFrom))   SelectJoin slj -> HPrint.ppAs alias (parens (ppSelectJoin slj))   SelectValues slv -> HPrint.ppAs alias (parens (ppSelectValues slv))   SelectBinary slb -> HPrint.ppAs alias (parens (ppSelectBinary slb)) -ppGroupBy :: [HSql.SqlExpr] -> Doc-ppGroupBy [] = empty-ppGroupBy xs = HPrint.ppGroupBy xs+ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc+ppGroupBy Nothing   = empty+ppGroupBy (Just xs) = HPrint.ppGroupBy (NEL.toList xs)  ppLimit :: Maybe Int -> Doc ppLimit Nothing = empty@@ -110,5 +112,11 @@ ppInsertReturning :: Sql.Returning HSql.SqlInsert -> Doc ppInsertReturning (Sql.Returning insert returnExprs) =   HPrint.ppInsert insert+  $$ text "RETURNING"+  <+> HPrint.commaV HPrint.ppSqlExpr returnExprs++ppUpdateReturning :: Sql.Returning HSql.SqlUpdate -> Doc+ppUpdateReturning (Sql.Returning update returnExprs) =+  HPrint.ppUpdate update   $$ text "RETURNING"   <+> HPrint.commaV HPrint.ppSqlExpr returnExprs

@@ -31,13 +31,14 @@ runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag) runSimpleQueryArr f (a, t) = runQueryArr f (a, PQ.Unit, t) +runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag)+runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start)+ runQueryArrUnpack :: U.Unpackspec a b                   -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag) runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag)-  where (columns, primQ, endTag) = runSimpleQueryArr q ((), Tag.start)-        f pe = ([pe], pe)-        primExprs :: [HPQ.PrimExpr]-        (primExprs, _) = U.runUnpackspec unpackspec f columns+  where (columns, primQ, endTag) = runSimpleQueryArrStart q ()+        primExprs = U.collectPEs unpackspec columns  first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3) first3 f (a1, a2, a3) = (f a1, a2, a3)

@@ -2,7 +2,7 @@  module Opaleye.Internal.RunQuery where -import           Control.Applicative (Applicative, pure, (<*>))+import           Control.Applicative (Applicative, pure, (<*>), liftA2)  import           Database.PostgreSQL.Simple.Internal (RowParser) import           Database.PostgreSQL.Simple.FromField (FieldParser, FromField,@@ -12,9 +12,11 @@  import           Opaleye.Column (Column) import           Opaleye.Internal.Column (Nullable)+import qualified Opaleye.Internal.PackMap as PackMap import qualified Opaleye.Column as C import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.PGTypes as T+import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)  import qualified Data.Profunctor as P import           Data.Profunctor (dimap)@@ -28,6 +30,7 @@ import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Time as Time+import qualified Data.String as String import           Data.UUID (UUID) import           GHC.Int (Int64) @@ -48,27 +51,45 @@  -- } --- We introduce 'QueryRunnerColumn' which is *not* a Product--- Profunctor because it is the only way I know of to get the instance--- generation to work for non-Nullable and Nullable types at once.-data QueryRunnerColumn coltype haskell =-  QueryRunnerColumn (U.Unpackspec (Column coltype) ()) (FieldParser haskell)+-- | A 'QueryRunnerColumn' @pgType@ @haskellType@ encodes how to turn+-- a value of Postgres type @pgType@ into a value of Haskell type+-- @haskellType@.  For example a value of type 'QueryRunnerColumn'+-- 'T.PGText' 'String' encodes how to turn a 'PGText' result from the+-- database into a Haskell 'String'. -data QueryRunner columns haskells = QueryRunner (U.Unpackspec columns ())-                                                (RowParser haskells)+-- This is *not* a Product Profunctor because it is the only way I+-- know of to get the instance generation to work for non-Nullable and+-- Nullable types at once.+data QueryRunnerColumn pgType haskellType =+  QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType) +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+              (columns -> Bool)+              -- ^ Have we actually requested any columns?  If we+              -- asked for zero columns then the SQL generator will+              -- have to put a dummy 0 into the SELECT statement,+              -- since we can't select zero columns.  In that case we+              -- have to make sure we read a single Int.+ fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn coltype haskell fieldQueryRunnerColumn =   QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) fromField  queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b-queryRunner qrc = QueryRunner u (fieldWith fp)+queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True)     where QueryRunnerColumn u fp = qrc  queryRunnerColumnNullable :: QueryRunnerColumn a b                        -> QueryRunnerColumn (Nullable a) (Maybe b) queryRunnerColumnNullable qr =-  QueryRunnerColumn (P.lmap C.unsafeCoerce u) (fromField' fp)+  QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp)   where QueryRunnerColumn u fp = qr         fromField' :: FieldParser a -> FieldParser (Maybe a)         fromField' _ _ Nothing = pure Nothing@@ -89,8 +110,11 @@ -- { Instances that must be provided once for each type.  Instances --   for Nullable are derived automatically from these. -class QueryRunnerColumnDefault a b where-  queryRunnerColumnDefault :: QueryRunnerColumn a b+-- | A 'QueryRunnerColumnDefault' @pgType@ @haskellType@ represents+-- the default way to turn a @pgType@ result from the database into a+-- Haskell value of type @haskelType@.+class QueryRunnerColumnDefault pgType haskellType where+  queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType  instance QueryRunnerColumnDefault T.PGInt4 Int where   queryRunnerColumnDefault = fieldQueryRunnerColumn@@ -140,10 +164,18 @@ instance QueryRunnerColumnDefault T.PGCitext (CI.CI LT.Text) where   queryRunnerColumnDefault = fieldQueryRunnerColumn +instance QueryRunnerColumnDefault T.PGJson String where+  queryRunnerColumnDefault =+    QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonFieldParser++instance QueryRunnerColumnDefault T.PGJsonb String where+  queryRunnerColumnDefault =+    QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) jsonbFieldParser+ -- No CI String instance since postgresql-simple doesn't define FromField (CI String)  arrayColumn :: Column (T.PGArray a) -> Column a-arrayColumn = C.unsafeCoerce+arrayColumn = C.unsafeCoerceColumn  instance (Typeable b, QueryRunnerColumnDefault a b) =>          QueryRunnerColumnDefault (T.PGArray a) [b] where@@ -155,21 +187,31 @@ -- Boilerplate instances  instance Functor (QueryRunner c) where-  fmap f (QueryRunner u r) = QueryRunner u (fmap f r)+  fmap f (QueryRunner u r b) = QueryRunner u ((fmap . fmap) f r) b  -- TODO: Seems like this one should be simpler! instance Applicative (QueryRunner c) where-  pure = QueryRunner (P.lmap (const ()) PP.empty) . pure-  QueryRunner uf rf <*> QueryRunner ux rx =-    QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) (rf <*> rx)+  pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const False)+         . pure+         . pure+  QueryRunner uf rf bf <*> QueryRunner ux rx bx =+    QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (||) bf bx)  instance P.Profunctor QueryRunner where-  dimap f g (QueryRunner u r) = QueryRunner (P.lmap f u) (fmap g r)+  dimap f g (QueryRunner u r b) =+    QueryRunner (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b)  instance PP.ProductProfunctor QueryRunner where   empty = PP.defaultEmpty   (***!) = PP.defaultProfunctorProduct +instance PP.SumProfunctor QueryRunner where+  f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu))+                         (PackMap.eitherFunction fr gr)+                         (either fb gb)+    where QueryRunner fu fr fb = f+          QueryRunner gu gr gb = g+ -- }  -- { Annoying postgresql-simple patch.  Delete this when it is merged upstream.@@ -189,10 +231,10 @@           _ -> returnError Incompatible f ""  fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])-fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim+fromArray fieldParser tInfo f = sequence . (parseIt <$>) <$> array delim   where-    delim = typdelim (typelem typeInfo)-    fElem = f{ typeOid = typoid (typelem typeInfo) }+    delim = typdelim (typelem tInfo)+    fElem = f{ typeOid = typoid (typelem tInfo) }      parseIt item =         fieldParser f' $ if item' == fromString "NULL" then Nothing else Just item'@@ -200,5 +242,26 @@         item' = fmt delim item         f' | Arrays.Array _ <- item = f            | otherwise              = fElem++-- }++-- { Allow @postgresql-simple@ conversions from JSON types to 'String'++jsonFieldParser, jsonbFieldParser :: FieldParser String+jsonFieldParser  = jsonFieldTypeParser (String.fromString "json")+jsonbFieldParser = jsonFieldTypeParser (String.fromString "jsonb")++-- typenames, not type Oids are used in order to avoid creating+-- a dependency on 'Database.PostgreSQL.LibPQ'+jsonFieldTypeParser :: SBS.ByteString -> FieldParser String+jsonFieldTypeParser jsonTypeName field mData = do+    ti <- typeInfo field+    if TI.typname ti == jsonTypeName+       then convert+       else returnError Incompatible field "types incompatible"+  where+    convert = case mData of+        Just bs -> pure $ IPT.strictDecodeUtf8 bs+        _       -> returnError UnexpectedNull field ""  -- }

@@ -23,11 +23,16 @@             | SelectBinary Binary             deriving Show +data SelectAttrs =+    Star+  | SelectAttrs (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn))+  deriving Show+ data From = From {-  attrs     :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],+  attrs     :: SelectAttrs,   tables    :: [Select],   criteria  :: [HSql.SqlExpr],-  groupBy   :: [HSql.SqlExpr],+  groupBy   :: Maybe (NEL.NonEmpty HSql.SqlExpr),   orderBy   :: [(HSql.SqlExpr, HSql.SqlOrder)],   limit     :: Maybe Int,   offset    :: Maybe Int@@ -36,14 +41,13 @@  data Join = Join {   jJoinType   :: JoinType,-  jAttrs      :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],   jTables     :: (Select, Select),   jCond       :: HSql.SqlExpr   }                 deriving Show  data Values = Values {-  vAttrs  :: [(HSql.SqlExpr, Maybe HSql.SqlColumn)],+  vAttrs  :: SelectAttrs,   vValues :: [[HSql.SqlExpr]] } deriving Show @@ -65,19 +69,19 @@                      values, binary)  sql :: ([HPQ.PrimExpr], PQ.PrimQuery, T.Tag) -> Select-sql (pes, pq, t) = SelectFrom $ newSelect { attrs = makeAttrs pes+sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes))                                           , tables = [pqSelect] }   where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq         makeAttrs = flip (zipWith makeAttr) [1..]         makeAttr pe i = sqlBinding (Symbol ("result" ++ show (i :: Int)) t, pe)  unit :: Select-unit = SelectFrom newSelect { attrs  = [(HSql.ConstSqlExpr "0", Nothing)] }+unit = SelectFrom newSelect { attrs  = SelectAttrs (ensureColumns []) }  baseTable :: String -> [(Symbol, HPQ.PrimExpr)] -> Select baseTable name columns = SelectFrom $-    newSelect { attrs = map sqlBinding columns-              , tables = [Table name] }+    newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))+              , tables = [Table (HSql.SqlTable name)] }  product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select product ss pes = SelectFrom $@@ -85,12 +89,27 @@               , criteria = map sqlExpr pes }  aggregate :: [(Symbol, (Maybe HPQ.AggrOp, HPQ.PrimExpr))] -> Select -> Select-aggregate aggrs s = SelectFrom $ newSelect { attrs = map attr aggrs+aggregate aggrs s = SelectFrom $ newSelect { attrs = SelectAttrs+                                               (ensureColumns (map attr aggrs))                                            , tables = [s]-                                           , groupBy = groupBy' }-  where groupBy' = (map sqlExpr+                                           , groupBy = (Just . groupBy') aggrs }+  where --- Grouping by an empty list is not the identity function!+        --- In fact it forms one single group.  Syntactically one+        --- cannot group by nothing in SQL, so we just group by a+        --- constant instead.  Because "GROUP BY 0" means group by the+        --- zeroth column, we instead use an expression rather than a+        --- constant.+        handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr+        handleEmpty =+          M.fromMaybe (return (HSql.FunSqlExpr "COALESCE" [HSql.ConstSqlExpr "0"]))+          . NEL.nonEmpty++        groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]+                 -> NEL.NonEmpty HSql.SqlExpr+        groupBy' = (handleEmpty+                    . map sqlExpr                     . map expr-                    . filter (M.isNothing . aggrOp)) aggrs+                    . filter (M.isNothing . aggrOp))         attr = sqlBinding . Arr.second (uncurry aggrExpr)         expr (_, (_, e)) = e         aggrOp (_, (x, _)) = x@@ -113,30 +132,29 @@           PQ.OffsetOp n        -> (Nothing, Just n)           PQ.LimitOffsetOp l o -> (Just l, Just o) -join :: PQ.JoinType -> [(Symbol, HPQ.PrimExpr)] -> HPQ.PrimExpr -> Select -> Select-     -> Select-join j columns cond s1 s2 = SelectJoin Join { jJoinType = joinType j-                                            , jAttrs = mkAttrs columns-                                            , jTables = (s1, s2)-                                            , jCond = sqlExpr cond }-  where mkAttrs = map sqlBinding+join :: PQ.JoinType -> HPQ.PrimExpr -> Select -> Select -> Select+join j cond s1 s2 = SelectJoin Join { jJoinType = joinType j+                                    , jTables = (s1, s2)+                                    , jCond = sqlExpr cond }  -- 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 columns pes = SelectValues Values { vAttrs  = mkColumns columns+values columns pes = SelectValues Values { vAttrs  = SelectAttrs (mkColumns columns)                                          , vValues = (map . map) sqlExpr pes }-  where mkColumns = zipWith (flip (curry (sqlBinding . Arr.second mkColumn))) [1..]+  where mkColumns = ensureColumns . zipWith (flip (curry (sqlBinding . Arr.second mkColumn))) [1..]         mkColumn i = (HPQ.BaseTableAttrExpr . ("column" ++) . show) (i::Int)  binary :: PQ.BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))]        -> (Select, Select) -> Select binary op pes (select1, select2) = SelectBinary Binary {   bOp = binOp op,-  bSelect1 = SelectFrom newSelect { attrs = map (mkColumn fst) pes,+  bSelect1 = SelectFrom newSelect { attrs = SelectAttrs+                                      (ensureColumns (map (mkColumn fst) pes)),                                     tables = [select1] },-  bSelect2 = SelectFrom newSelect { attrs = map (mkColumn snd) pes,+  bSelect2 = SelectFrom newSelect { attrs = SelectAttrs+                                      (ensureColumns (map (mkColumn snd) pes)),                                     tables = [select2] }   }   where mkColumn e = sqlBinding . Arr.second e@@ -152,10 +170,10 @@  newSelect :: From newSelect = From {-  attrs     = [],+  attrs     = Star,   tables    = [],   criteria  = [],-  groupBy   = [],+  groupBy   = Nothing,   orderBy   = [],   limit     = Nothing,   offset    = Nothing@@ -167,3 +185,8 @@ sqlBinding :: (Symbol, HPQ.PrimExpr) -> (HSql.SqlExpr, Maybe HSql.SqlColumn) sqlBinding (Symbol sym t, pe) =   (sqlExpr pe, Just (HSql.SqlColumn (T.tagWith t sym)))++ensureColumns :: [(HSql.SqlExpr, Maybe a)]+              -> NEL.NonEmpty (HSql.SqlExpr, Maybe a)+ensureColumns = M.fromMaybe (return (HSql.ConstSqlExpr "0", Nothing))+                . NEL.nonEmpty

@@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}  module Opaleye.Internal.Table where -import           Opaleye.Internal.Column (Column(Column))+import           Opaleye.Internal.Column (Column, unColumn) import qualified Opaleye.Internal.TableMaker as TM import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.PrimQuery as PQ@@ -10,10 +11,14 @@  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Data.Functor.Identity as I import           Data.Profunctor (Profunctor, dimap, lmap) import           Data.Profunctor.Product (ProductProfunctor, empty, (***!)) import qualified Data.Profunctor.Product as PP+import qualified Data.List.NonEmpty as NEL+import           Data.Monoid (Monoid, mempty, mappend) import           Control.Applicative (Applicative, pure, (<*>), liftA2)+import qualified Control.Arrow as Arr  -- | Define a table as follows, where \"id\", \"color\", \"location\", -- \"quantity\" and \"radius\" are the tables columns in Postgres and@@ -48,14 +53,18 @@  data View columns = View columns --- If we switch to a more lens-like approach to PackMap this should be--- the equivalent of a Fold- -- There's no reason the second parameter should exist except that we -- use ProductProfunctors more than ProductContravariants so it makes -- things easier if we make it one of the former.-data Writer columns dummy =-  Writer (PM.PackMap (HPQ.PrimExpr, String) () columns ())+--+-- Writer has become very mysterious.  I really couldn't tell you what+-- it means.  It seems to be saying that a `Writer` tells you how an+-- `f columns` contains a list of `(f HPQ.PrimExpr, String)`, i.e. how+-- it contains each column: a column header and the entries in this+-- column for all the rows.+newtype Writer columns dummy =+  Writer (forall f. Functor f =>+          PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())  queryTable :: TM.ColumnMaker viewColumns columns             -> Table writerColumns viewColumns@@ -83,18 +92,36 @@  runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)] runWriter (Writer (PM.PackMap f)) columns = outColumns-  where extractColumns t = ([t], ())-        (outColumns, ()) = f extractColumns columns+  where (outColumns, ()) = f extract (I.Identity columns)+        extract (pes, s) = ([(I.runIdentity pes, s)], ()) +-- This works more generally for any "zippable", that is an+-- Applicative that satisfies+--+--    x == (,) <$> fmap fst x <*> fmap snd x+--+-- However, I'm unaware of a typeclass for this.+runWriter' :: Writer columns columns' -> NEL.NonEmpty columns -> (NEL.NonEmpty [HPQ.PrimExpr], [String])+runWriter' (Writer (PM.PackMap f)) columns = Arr.first unZip outColumns+  where (outColumns, ()) = f extract columns+        extract (pes, s) = ((Zip (fmap return pes), [s]), ())++data Zip a = Zip { unZip :: NEL.NonEmpty [a] }++instance Monoid (Zip a) where+  mempty = Zip mempty'+    where mempty' = [] `NEL.cons` mempty'+  Zip xs `mappend` Zip ys = Zip (NEL.zipWith (++) xs ys)+ required :: String -> Writer (Column a) (Column a) required columnName =-  Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName)))+  Writer (PM.PackMap (\f columns -> f (fmap unColumn columns, columnName)))  optional :: String -> Writer (Maybe (Column a)) (Column a) optional columnName =-  Writer (PM.PackMap (\f c -> case c of-                         Nothing -> pure ()-                         Just (Column primExpr) -> f (primExpr, columnName)))+  Writer (PM.PackMap (\f columns -> f (fmap maybeUnColumn columns, columnName)))+  where maybeUnColumn Nothing = HPQ.DefaultInsertExpr+        maybeUnColumn (Just column) = unColumn column  -- { @@ -108,7 +135,7 @@   Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)  instance Profunctor Writer where-  dimap f _ (Writer h) = Writer (lmap f h)+  dimap f _ (Writer h) = Writer (lmap (fmap f) h)  instance ProductProfunctor Writer where   empty = PP.defaultEmpty

@@ -26,13 +26,13 @@  runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->                        strings -> tablecolumns-runViewColumnMaker (ViewColumnMaker f) = PM.over f id+runViewColumnMaker (ViewColumnMaker f) = PM.overPM f id  runColumnMaker :: Applicative f                   => ColumnMaker tablecolumns columns                   -> (HPQ.PrimExpr -> f HPQ.PrimExpr)                   -> tablecolumns -> f columns-runColumnMaker (ColumnMaker f) = PM.packmap f+runColumnMaker (ColumnMaker f) = PM.traversePM f  -- There's surely a way of simplifying this implementation tableColumn :: ViewColumnMaker String (C.Column a)

@@ -1,6 +1,6 @@ module Opaleye.Internal.Tag where -data Tag = UnsafeTag Int deriving (Read, Show)+newtype Tag = UnsafeTag Int deriving (Read, Show)  start :: Tag start = UnsafeTag 1

@@ -15,18 +15,43 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ  newtype Unpackspec columns columns' =+  -- | An 'Unpackspec' @columns@ @columns'@ allows you to extract and+  -- modify a sequence of 'HPQ.PrimExpr's inside a value of type+  -- @columns@.+  --+  -- For example, the 'Default' instance of type 'Unpackspec' @(Column+  -- a, Column b)@ @(Column a, Column b)@ allows you to manipulate or+  -- extract the two 'HPQ.PrimExpr's inside a @(Column a, Column b)@.  The+  -- 'Default' instance of type @Foo (Column a) (Column b) (Column c)@+  -- will allow you to manipulate or extract the three 'HPQ.PrimExpr's+  -- contained therein (for a user-defined product type @Foo@, assuming+  -- the @makeAdaptorAndInstance@ splice from+  -- @Data.Profunctor.Product.TH@ has been run).+  --+  -- You can create 'Unpackspec's by hand using 'unpackspecColumn' and+  -- the 'Profunctor', 'ProductProfunctor' and 'SumProfunctor'+  -- operations.  However, in practice users should almost never need+  -- to create or manipulate them.  Typically they will be created+  -- automatically by the 'D.Default' instance.   Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') +-- | Target the single 'HPQ.PrimExpr' inside a 'C.Column' unpackspecColumn :: Unpackspec (C.Column a) (C.Column a) unpackspecColumn = Unpackspec                    (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe))) +-- | Modify all the targeted 'HPQ.PrimExpr's runUnpackspec :: Applicative f                  => Unpackspec columns b                  -> (HPQ.PrimExpr -> f HPQ.PrimExpr)                  -> columns -> f b-runUnpackspec (Unpackspec f) = PM.packmap f+runUnpackspec (Unpackspec f) = PM.traversePM f +-- | Extract all the targeted 'HPQ.PrimExpr's+collectPEs :: Unpackspec s t -> s -> [HPQ.PrimExpr]+collectPEs unpackspec = fst . runUnpackspec unpackspec f+  where f pe = ([pe], pe)+ instance D.Default Unpackspec (C.Column a) (C.Column a) where   def = unpackspecColumn @@ -47,5 +72,8 @@ instance ProductProfunctor Unpackspec where   empty = PP.defaultEmpty   (***!) = PP.defaultProfunctorProduct++instance PP.SumProfunctor Unpackspec where+  Unpackspec x1 +++! Unpackspec x2 = Unpackspec (x1 PP.+++! x2)  --}

@@ -68,12 +68,12 @@                    -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr extractValuesField = PM.extractAttr "values" -data Valuesspec columns columns' =+newtype Valuesspec columns columns' =   Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')  runValuesspec :: Applicative f => Valuesspec columns columns'               -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'-runValuesspec (Valuesspec v) f = PM.packmap v f ()+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))))

@@ -6,7 +6,6 @@ import qualified Opaleye.Internal.Join as J import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.PackMap as PM import           Opaleye.QueryArr (Query) import qualified Opaleye.Internal.QueryArr as Q import           Opaleye.Internal.Column (Column(Column))@@ -35,23 +34,21 @@           -> Query (columnsA, nullableColumnsB) leftJoin = leftJoinExplicit D.def D.def D.def +-- We don't actually need the Unpackspecs any more, but I'm going to+-- leave them here in case they're ever needed again.  I don't want to+-- have to break the API to add them back. leftJoinExplicit :: U.Unpackspec columnsA columnsA                  -> U.Unpackspec columnsB columnsB                  -> J.NullMaker columnsB nullableColumnsB                  -> Query columnsA -> Query columnsB                  -> ((columnsA, columnsB) -> Column T.PGBool)                  -> Query (columnsA, nullableColumnsB)-leftJoinExplicit unpackA unpackB nullmaker qA qB cond = Q.simpleQueryArr q where-  q ((), startTag) = ((newColumnsA, nullableColumnsB), primQueryR, T.next endTag)+leftJoinExplicit _ _ nullmaker qA qB cond = Q.simpleQueryArr q where+  q ((), startTag) = ((columnsA, nullableColumnsB), primQueryR, T.next endTag)     where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)           (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag) -          (newColumnsA, ljPEsA) =-            PM.run (U.runUnpackspec unpackA (J.extractLeftJoinFields 1 endTag) columnsA)-          (newColumnsB, ljPEsB) =-            PM.run (U.runUnpackspec unpackB (J.extractLeftJoinFields 2 endTag) columnsB)--          nullableColumnsB = J.toNullable nullmaker newColumnsB+          nullableColumnsB = J.toNullable nullmaker columnsB            Column cond' = cond (columnsA, columnsB)-          primQueryR = PQ.Join PQ.LeftJoin (ljPEsA ++ ljPEsB) cond' primQueryA primQueryB+          primQueryR = PQ.Join PQ.LeftJoin cond' primQueryA primQueryB

@@ -10,11 +10,10 @@ import qualified Opaleye.Table as T import qualified Opaleye.Internal.Table as TI import           Opaleye.Internal.Column (Column(Column))-import           Opaleye.Internal.Helpers ((.:), (.:.), (.::))+import           Opaleye.Internal.Helpers ((.:), (.:.), (.::), (.::.)) import qualified Opaleye.Internal.Unpackspec as U import           Opaleye.PGTypes (PGBool) -import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD@@ -26,12 +25,10 @@  import           Data.Int (Int64) import           Data.String (fromString)+import qualified Data.List.NonEmpty as NEL  arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert-arrangeInsert (T.Table tableName (TI.TableProperties writer _)) columns = insert-  where outColumns' = (map (\(x, y) -> (y, x))-                       . TI.runWriter writer) columns-        insert = SG.sqlInsert SD.defaultSqlGenerator tableName outColumns'+arrangeInsert t c = arrangeInsertMany t (return c)  arrangeInsertSql :: T.Table columns a -> columns -> String arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert@@ -39,6 +36,24 @@ runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql +arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert+arrangeInsertMany (T.Table tableName (TI.TableProperties writer _)) columns = insert+  where (columnExprs, columnNames) = TI.runWriter' writer columns+        insert = SG.sqlInsert SD.defaultSqlGenerator+                      tableName columnNames columnExprs++arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String+arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany++runInsertMany :: PGS.Connection+              -> T.Table columns columns'+              -> [columns]+              -> IO Int64+runInsertMany conn table columns = case NEL.nonEmpty columns of+  -- Inserting the empty list is just the same as returning 0+  Nothing       -> return 0+  Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) table columns'+ arrangeUpdate :: T.Table columnsW columnsR               -> (columnsR -> columnsW) -> (columnsR -> Column PGBool)               -> HSql.SqlUpdate@@ -73,7 +88,7 @@           -> IO Int64 runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql -arrangeInsertReturning :: U.Unpackspec returned returned+arrangeInsertReturning :: U.Unpackspec returned ignored                        -> T.Table columnsW columnsR                        -> columnsW                        -> (columnsR -> returned)@@ -82,14 +97,10 @@   Sql.Returning insert returningSEs   where insert = arrangeInsert table columns         TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table-        returning = returningf columnsR-        -- TODO: duplication with runQueryArrUnpack-        f pe = ([pe], pe)-        returningPEs :: [HPQ.PrimExpr]-        (returningPEs, _) = U.runUnpackspec unpackspec f returning+        returningPEs = U.collectPEs unpackspec (returningf columnsR)         returningSEs = map Sql.sqlExpr returningPEs -arrangeInsertReturningSql :: U.Unpackspec returned returned+arrangeInsertReturningSql :: U.Unpackspec returned ignored                           -> T.Table columnsW columnsR                           -> columnsW                           -> (columnsR -> returned)@@ -99,26 +110,74 @@                             .:: arrangeInsertReturning  runInsertReturningExplicit :: RQ.QueryRunner returned haskells-                           -> U.Unpackspec returned returned-                           -> PGS.Connection-                           -> T.Table columnsW columnsR-                           -> columnsW-                           -> (columnsR -> returned)-                           -> IO [haskells]-runInsertReturningExplicit qr u conn = PGS.queryWith_ rowParser conn-                                       . fromString-                                       .:. arrangeInsertReturningSql u-  where IRQ.QueryRunner _ rowParser = qr+                            -> PGS.Connection+                            -> T.Table columnsW columnsR+                            -> columnsW+                            -> (columnsR -> returned)+                            -> IO [haskells]+runInsertReturningExplicit qr conn t w r = PGS.queryWith_ (rowParser (r v)) conn+                                             (fromString+                                             (arrangeInsertReturningSql u t w r))+  where IRQ.QueryRunner u rowParser _ = qr+        --- ^^ TODO: need to make sure we're not trying to read zero rows+        TI.Table _ (TI.TableProperties _ (TI.View v)) = t+        -- This method of getting hold of the return type feels a bit+        -- suspect.  I haven't checked it for validity.  -- | @runInsertReturning@'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 -- @runInsertReturning@.-runInsertReturning :: (D.Default RQ.QueryRunner returned haskells,-                       D.Default U.Unpackspec returned returned)+runInsertReturning :: (D.Default RQ.QueryRunner returned haskells)                       => PGS.Connection                       -> T.Table columnsW columnsR                       -> columnsW                       -> (columnsR -> returned)                       -> IO [haskells]-runInsertReturning = runInsertReturningExplicit D.def D.def+runInsertReturning = runInsertReturningExplicit D.def++arrangeUpdateReturning :: U.Unpackspec returned ignored+                       -> T.Table columnsW columnsR+                       -> (columnsR -> columnsW)+                       -> (columnsR -> Column PGBool)+                       -> (columnsR -> returned)+                       -> Sql.Returning HSql.SqlUpdate+arrangeUpdateReturning unpackspec table updatef cond returningf =+  Sql.Returning update returningSEs+  where update = arrangeUpdate table updatef cond+        TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table+        returningPEs = U.collectPEs unpackspec (returningf columnsR)+        returningSEs = map Sql.sqlExpr returningPEs++arrangeUpdateReturningSql :: U.Unpackspec returned ignored+                       -> T.Table columnsW columnsR+                       -> (columnsR -> columnsW)+                       -> (columnsR -> Column PGBool)+                       -> (columnsR -> returned)+                       -> String+arrangeUpdateReturningSql = show+                            . Print.ppUpdateReturning+                            .::. arrangeUpdateReturning++runUpdateReturningExplicit :: RQ.QueryRunner returned haskells+                           -> PGS.Connection+                           -> T.Table columnsW columnsR+                           -> (columnsR -> columnsW)+                           -> (columnsR -> Column PGBool)+                           -> (columnsR -> returned)+                           -> IO [haskells]+runUpdateReturningExplicit qr conn t update cond r =+  PGS.queryWith_ (rowParser (r v)) conn+                 (fromString (arrangeUpdateReturningSql u t update cond r))+  where IRQ.QueryRunner u rowParser _ = qr+        --- ^^ TODO: need to make sure we're not trying to read zero rows+        TI.Table _ (TI.TableProperties _ (TI.View v)) = t++runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells)+                      => PGS.Connection+                      -> T.Table columnsW columnsR+                      -> (columnsR -> columnsW)+                      -> (columnsR -> Column PGBool)+                      -> (columnsR -> returned)+                      -> IO [haskells]+runUpdateReturning = runUpdateReturningExplicit D.def

@@ -1,10 +1,13 @@ module Opaleye.Operators (module Opaleye.Operators) where +import qualified Data.Foldable as F+ import           Opaleye.Internal.Column (Column(Column), unsafeCase_,                                           unsafeIfThenElse, unsafeGt, unsafeEq) import qualified Opaleye.Internal.Column as C import           Opaleye.Internal.QueryArr (QueryArr(QueryArr)) import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Order as Ord import qualified Opaleye.PGTypes as T  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ@@ -28,19 +31,19 @@ (./=) = C.binOp HPQ.OpNotEq  infix 4 .>-(.>) :: Column a -> Column a -> Column T.PGBool+(.>) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.>) = unsafeGt  infix 4 .<-(.<) :: Column a -> Column a -> Column T.PGBool+(.<) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.<) = C.binOp HPQ.OpLt  infix 4 .<=-(.<=) :: Column a -> Column a -> Column T.PGBool+(.<=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.<=) = C.binOp HPQ.OpLtEq  infix 4 .>=-(.>=) :: Column a -> Column a -> Column T.PGBool+(.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool (.>=) = C.binOp HPQ.OpGtEq  case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a@@ -71,3 +74,9 @@  like :: Column T.PGText -> Column T.PGText -> Column T.PGBool like = C.binOp HPQ.OpLike++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

@@ -4,22 +4,52 @@ import           Opaleye.QueryArr (Query) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Order as O+import qualified Opaleye.PGTypes as T  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -{-| Order the rows of a `Query` according to the `Order`. -}+{-| Order the rows of a `Query` according to the `Order`.++@+import Data.Monoid (\<\>)++\-- Order by the first column ascending.  When first columns are equal+\-- order by second column descending.+example :: 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText')+        -> 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText')+example = 'orderBy' ('asc' fst \<\> 'desc' snd)+@++-} orderBy :: O.Order a -> Query a -> Query a orderBy os q =   Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q)  -- | Specify an ascending ordering by the given expression.-asc :: (a -> C.Column b) -> O.Order a-asc = O.order HPQ.OpAsc+--   (Any NULLs appear last)+asc :: PGOrd b => (a -> C.Column b) -> O.Order a+asc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc+                          , HPQ.orderNulls     = HPQ.NullsLast }  -- | Specify an descending ordering by the given expression.-desc :: (a -> C.Column b) -> O.Order a-desc = O.order HPQ.OpDesc+--   (Any NULLs appear first)+desc :: PGOrd b => (a -> C.Column b) -> O.Order a+desc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc+                           , HPQ.orderNulls     = HPQ.NullsFirst } +-- | Specify an ascending ordering by the given expression.+--   (Any NULLs appear first)+ascNullsFirst :: PGOrd b => (a -> C.Column b) -> O.Order a+ascNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc+                                    , HPQ.orderNulls     = HPQ.NullsFirst }+++-- | Specify an descending ordering by the given expression.+--   (Any NULLs appear last)+descNullsLast :: PGOrd b => (a -> C.Column b) -> O.Order a+descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc+                                    , HPQ.orderNulls     = HPQ.NullsLast }+ {- | Limit the results of the given query to the given maximum number of items.@@ -33,3 +63,20 @@ -} offset :: Int -> Query a -> Query a offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)++-- | Typeclass for Postgres types which support ordering operations.+class PGOrd a where++instance PGOrd T.PGBool+instance PGOrd T.PGDate+instance PGOrd T.PGFloat8+instance PGOrd T.PGFloat4+instance PGOrd T.PGInt8+instance PGOrd T.PGInt4+instance PGOrd T.PGInt2+instance PGOrd T.PGNumeric+instance PGOrd T.PGText+instance PGOrd T.PGTime+instance PGOrd T.PGTimestamptz+instance PGOrd T.PGTimestamp+instance PGOrd T.PGCitext

@@ -1,11 +1,13 @@ {-# LANGUAGE EmptyDataDecls #-} -module Opaleye.PGTypes where+module Opaleye.PGTypes (module Opaleye.PGTypes) where -import           Opaleye.Internal.Column (Column(Column))+import           Opaleye.Internal.Column (Column) import qualified Opaleye.Internal.Column as C+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 Data.CaseInsensitive as CI import qualified Data.Text as SText@@ -13,7 +15,6 @@ import qualified Data.ByteString as SByteString import qualified Data.ByteString.Lazy as LByteString import qualified Data.Time as Time-import qualified Data.Time.Locale.Compat as Locale import qualified Data.UUID as UUID  import           Data.Int (Int64)@@ -34,6 +35,8 @@ data PGCitext data PGArray a data PGBytea+data PGJson+data PGJsonb  instance C.PGNum PGFloat8 where   pgFromInteger = pgDouble . fromInteger@@ -48,67 +51,91 @@   pgFromRational = pgDouble . fromRational  literalColumn :: HPQ.Literal -> Column a-literalColumn = Column . HPQ.ConstExpr+literalColumn = IPT.literalColumn+{-# WARNING literalColumn+    "'literalColumn' has been moved to Opaleye.Internal.PGTypes"+  #-}  pgString :: String -> Column PGText-pgString = literalColumn . HPQ.StringLit+pgString = IPT.literalColumn . HPQ.StringLit  pgLazyByteString :: LByteString.ByteString -> Column PGBytea-pgLazyByteString = literalColumn . HPQ.ByteStringLit . LByteString.toStrict+pgLazyByteString = IPT.literalColumn . HPQ.ByteStringLit . LByteString.toStrict  pgStrictByteString :: SByteString.ByteString -> Column PGBytea-pgStrictByteString = literalColumn . HPQ.ByteStringLit+pgStrictByteString = IPT.literalColumn . HPQ.ByteStringLit  pgStrictText :: SText.Text -> Column PGText-pgStrictText = literalColumn . HPQ.StringLit . SText.unpack+pgStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack  pgLazyText :: LText.Text -> Column PGText-pgLazyText = literalColumn . HPQ.StringLit . LText.unpack+pgLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack  pgInt4 :: Int -> Column PGInt4-pgInt4 = literalColumn . HPQ.IntegerLit . fromIntegral+pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral  pgInt8 :: Int64 -> Column PGInt8-pgInt8 = literalColumn . HPQ.IntegerLit . fromIntegral+pgInt8 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral  pgDouble :: Double -> Column PGFloat8-pgDouble = literalColumn . HPQ.DoubleLit+pgDouble = IPT.literalColumn . HPQ.DoubleLit  pgBool :: Bool -> Column PGBool-pgBool = literalColumn . HPQ.BoolLit+pgBool = IPT.literalColumn . HPQ.BoolLit  pgUUID :: UUID.UUID -> Column PGUuid-pgUUID = C.unsafeCoerce . pgString . UUID.toString+pgUUID = C.unsafeCoerceColumn . pgString . UUID.toString --- Internal use only! unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c-unsafePgFormatTime typeName formatString = Column-                                     . HPQ.CastExpr typeName-                                     . HPQ.ConstExpr-                                     . HPQ.OtherLit-                                     . format-  where format = Time.formatTime Locale.defaultTimeLocale formatString+unsafePgFormatTime = IPT.unsafePgFormatTime+{-# WARNING unsafePgFormatTime+    "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes"+  #-}  pgDay :: Time.Day -> Column PGDate-pgDay = unsafePgFormatTime "date" "'%F'"+pgDay = IPT.unsafePgFormatTime "date" "'%F'"  pgUTCTime :: Time.UTCTime -> Column PGTimestamptz-pgUTCTime = unsafePgFormatTime "timestamptz" "'%FT%TZ'"+pgUTCTime = IPT.unsafePgFormatTime "timestamptz" "'%FT%TZ'"  pgLocalTime :: Time.LocalTime -> Column PGTimestamp-pgLocalTime = unsafePgFormatTime "timestamp" "'%FT%T'"+pgLocalTime = IPT.unsafePgFormatTime "timestamp" "'%FT%T'"  pgTimeOfDay :: Time.TimeOfDay -> Column PGTime-pgTimeOfDay = unsafePgFormatTime "time" "'%T'"+pgTimeOfDay = IPT.unsafePgFormatTime "time" "'%T'"  -- "We recommend not using the type time with time zone" -- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html   pgCiStrictText :: CI.CI SText.Text -> Column PGCitext-pgCiStrictText = literalColumn . HPQ.StringLit . SText.unpack . CI.original+pgCiStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack . CI.original  pgCiLazyText :: CI.CI LText.Text -> Column PGCitext-pgCiLazyText = literalColumn . HPQ.StringLit . LText.unpack . CI.original+pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original  -- No CI String instance since postgresql-simple doesn't define FromField (CI String)++-- The json data type was introduced in PostgreSQL version 9.2+-- JSON values must be SQL string quoted+pgJSON :: String -> Column PGJson+pgJSON = IPT.castToType "json" . HSD.quote++pgStrictJSON :: SByteString.ByteString -> Column PGJson+pgStrictJSON = pgJSON . IPT.strictDecodeUtf8++pgLazyJSON :: LByteString.ByteString -> Column PGJson+pgLazyJSON = pgJSON . IPT.lazyDecodeUtf8++-- The jsonb data type was introduced in PostgreSQL version 9.4+-- JSONB values must be SQL string quoted+--+-- TODO: We need to add literal JSON and JSONB types.+pgJSONB :: String -> Column PGJsonb+pgJSONB = IPT.castToType "jsonb" . HSD.quote++pgStrictJSONB :: SByteString.ByteString -> Column PGJsonb+pgStrictJSONB = pgJSONB . IPT.strictDecodeUtf8++pgLazyJSONB :: LByteString.ByteString -> Column PGJsonb+pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8

@@ -3,9 +3,11 @@ module Opaleye.RunQuery (module Opaleye.RunQuery,                          QueryRunner,                          IRQ.QueryRunnerColumn,+                         IRQ.QueryRunnerColumnDefault (..),                          IRQ.fieldQueryRunnerColumn) where  import qualified Database.PostgreSQL.Simple as PGS+import qualified Database.PostgreSQL.Simple.FromRow as FR import qualified Data.String as String  import           Opaleye.Column (Column)@@ -13,10 +15,13 @@ import           Opaleye.QueryArr (Query) import           Opaleye.Internal.RunQuery (QueryRunner(QueryRunner)) import qualified Opaleye.Internal.RunQuery as IRQ+import qualified Opaleye.Internal.QueryArr as Q  import qualified Data.Profunctor as P import qualified Data.Profunctor.Product.Default as D +import           Control.Applicative ((*>))+ -- | @runQuery@'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@@ -47,10 +52,20 @@                  -> PGS.Connection                  -> Query columns                  -> IO [haskells]-runQueryExplicit (QueryRunner u rowParser) conn q =-  PGS.queryWith_ rowParser conn sql+runQueryExplicit (QueryRunner u rowParser nonZeroColumns) conn q =+  PGS.queryWith_ parser conn sql   where sql :: PGS.Query         sql = String.fromString (S.showSqlForPostgresExplicit u q)+        -- FIXME: We're doing work twice here+        (b, _, _) = Q.runSimpleQueryArrStart q ()+        parser = if nonZeroColumns b+                 then rowParser b+                 else (FR.fromRow :: FR.RowParser (PGS.Only Int)) *> rowParser b+                 -- If we are selecting zero columns then the SQL+                 -- generator will have to put a dummy 0 into the+                 -- SELECT statement, since we can't select zero+                 -- columns.  In that case we have to make sure we+                 -- read a single Int.  -- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on --   your own datatypes.  For example:

@@ -9,14 +9,12 @@ import           Opaleye.Internal.Column (Column(Column)) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Table as T-import           Opaleye.Internal.Table (View(View), Writer(Writer),-                                         Table, TableProperties)+import           Opaleye.Internal.Table (View(View), Table, Writer,+                                         TableProperties) import qualified Opaleye.Internal.TableMaker as TM import qualified Opaleye.Internal.Tag as Tag-import qualified Opaleye.Internal.PackMap as PM  import qualified Data.Profunctor.Product.Default as D-import           Control.Applicative (Applicative, pure)  import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ @@ -44,12 +42,10 @@  required :: String -> TableProperties (Column a) (Column a) required columnName = T.TableProperties-  (Writer (PM.PackMap (\f (Column primExpr) -> f (primExpr, columnName))))+  (T.required columnName)   (View (Column (HPQ.BaseTableAttrExpr columnName)))  optional :: String -> TableProperties (Maybe (Column a)) (Column a) optional columnName = T.TableProperties-  (Writer (PM.PackMap (\f c -> case c of-                          Nothing -> pure ()-                          Just (Column primExpr) -> f (primExpr, columnName))))+  (T.optional columnName)   (View (Column (HPQ.BaseTableAttrExpr columnName)))