opaleye 0.4.0.0 → 0.4.1.0

raw patch · 21 files changed

+354/−90 lines, 21 filesdep +multisetdep ~postgresql-simpledep ~semigroupsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: multiset

Dependency ranges changed: postgresql-simple, semigroups

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−2
• README.md +1/−1
• Test/QuickCheck.hs +116/−27
• Test/Test.hs +9/−2
• opaleye.cabal +3/−1
• src/Opaleye.hs +2/−0
• src/Opaleye/Column.hs +4/−2
• src/Opaleye/Constant.hs +117/−0
• src/Opaleye/Internal/Column.hs +4/−0
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +1/−0
• src/Opaleye/Internal/HaskellDB/Sql.hs +1/−0
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +1/−0
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +15/−12
• src/Opaleye/Internal/Order.hs +5/−1
• src/Opaleye/Internal/Print.hs +10/−10
• src/Opaleye/Internal/RunQuery.hs +19/−3
• src/Opaleye/Internal/Sql.hs +12/−5
• src/Opaleye/Internal/Table.hs +1/−0
• src/Opaleye/Manipulation.hs +8/−8
• src/Opaleye/PGTypes.hs +5/−4
• src/Opaleye/RunQuery.hs +6/−12

@@ -1,3 +1,15 @@+## 0.4.1.0++* Added `Opaleye.Constant` for lifting constant values+* Support microseconds in `pgLocalTime`, `pgTimeOfDay` and `pgUTCTime`+* Added `unsafeCompositeField` to help with defining composite types+* `Order` is an instance of `Semigroup`++Thanks to Adam Bergmark and Matt Wraith for helping with these+changes.++## 0.4.0.0+ * Added `runUpdateReturning` * Ordering operators and `max` and `min` aggregators are now restricted to a typeclass * Added `stringAgg` and `arrayAgg` aggregations.@@ -6,8 +18,8 @@ * Added JSON types * Added `runInsertMany` -Thanks to Travis Staton, Jakub Ryška and Christopher Lewis for helping-with these changes.+Thanks to Travis Staton, Jakub Ryška and Christopher Lewis for+helping with these changes.  ## 0.3.1.2 

@@ -1,6 +1,6 @@ # 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+Opaleye is a Haskell library that provides an SQL-generating embedded domain specific language for targeting Postgres.  You need Opaleye if you want to use Haskell to write typesafe and composable code to query a Postgres database.

@@ -8,7 +8,9 @@ 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           Data.List (sort)+import qualified Data.List as List+import qualified Data.MultiSet as MultiSet import qualified Data.Profunctor.Product as PP import qualified Data.Functor.Contravariant.Divisible as Divisible import qualified Data.Monoid as Monoid@@ -35,8 +37,11 @@ type Columns = [Either (O.Column O.PGInt4) (O.Column O.PGBool)] type Haskells = [Either Int Bool] +columnsOfHaskells :: Haskells -> Columns+columnsOfHaskells = O.constantExplicit eitherPP+ newtype ArbitraryQuery   = ArbitraryQuery (O.Query Columns)-newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Columns }+newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Haskells }                         deriving Show newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int                             deriving Show@@ -58,8 +63,12 @@  instance TQ.Arbitrary ArbitraryQuery where   arbitrary = TQ.oneof [-      (ArbitraryQuery . pure . unArbitraryColumns)+      (ArbitraryQuery . pure . columnsOfHaskells . unArbitraryColumns)         <$> TQ.arbitrary+    , do+        ArbitraryQuery q1 <- TQ.arbitrary+        ArbitraryQuery q2 <- TQ.arbitrary+        aq ((++) <$> q1 <*> q2)     , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1)))     , do         ArbitraryQuery q <- TQ.arbitrary@@ -92,7 +101,7 @@ 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]))+                             ++ map (return . Right) [False, True]))     return (ArbitraryColumns l)  instance TQ.Arbitrary ArbitraryPositiveInt where@@ -182,6 +191,7 @@  -- { Comparing the results +-- compareNoSort is stronger than compare' so prefer to use it where possible compareNoSort :: Eq a               => PGS.Connection               -> QueryDenotation a@@ -202,10 +212,27 @@   two' <- unQueryDenotation two conn   return (sort one' == sort two') +compareSortedBy :: Ord a+                => (a -> a -> Ord.Ordering)+                -> PGS.Connection+                -> QueryDenotation a+                -> QueryDenotation a+                -> IO Bool+compareSortedBy o conn one two = do+  one' <- unQueryDenotation one conn+  two' <- unQueryDenotation two conn+  return ((sort one' == sort two')+          && (isSortedBy o one'))+ -- }  -- { The tests +columns :: PGS.Connection -> ArbitraryColumns -> IO Bool+columns conn (ArbitraryColumns c) =+  compareNoSort conn (denotation' (pure (columnsOfHaskells c)))+                     (pure c)+ fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool fmap' conn f (ArbitraryQuery q) = do   compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q))@@ -216,11 +243,40 @@   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))+-- When combining arbitrary queries with the applicative product <*>+-- the limit of the denotation is not always the denotation of the+-- limit.  Without some ordering applied before the limit the returned+-- rows can vary.  If an ordering is applied beforehand we can check+-- the invariant that the returned rows always compare smaller than+-- the remainder under the applied ordering.+--+-- Strangely the same caveat doesn't apply to offset.+limit :: PGS.Connection+      -> ArbitraryPositiveInt+      -> ArbitraryQuery+      -> ArbitraryOrder+      -> IO Bool+limit conn (ArbitraryPositiveInt l) (ArbitraryQuery q) o = do+  let q' = O.limit l (O.orderBy (arbitraryOrder o) q) +  one' <- unQueryDenotation (denotation' q') conn+  two' <- unQueryDenotation (denotation' q) conn++  let remainder = MultiSet.fromList two'+                  `MultiSet.difference`+                  MultiSet.fromList one'+      maxChosen :: Maybe Haskells+      maxChosen = maximumBy (arbitraryOrdering o) one'+      minRemain :: Maybe Haskells+      minRemain = minimumBy (arbitraryOrdering o) (MultiSet.toList remainder)+      cond :: Maybe Bool+      cond = lteBy (arbitraryOrdering o) <$> maxChosen <*> minRemain+      condBool :: Bool+      condBool = Maybe.fromMaybe True cond++  return ((length one' == min l (length two'))+          && condBool)+ offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do   compareNoSort conn (denotation' (O.offset l q))@@ -228,18 +284,23 @@  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))+  compareSortedBy (arbitraryOrdering o)+                  conn+                  (denotation' (O.orderBy (arbitraryOrder o) q))+                  (denotation' q)  distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool distinct conn (ArbitraryQuery q) = do   compare' conn (denotation' (O.distinctExplicit eitherPP q))                 (onList nub (denotation' q)) +-- When we added <*> to the arbitrary queries we started getting some+-- consequences to do with the order of the returned rows and so+-- restrict had to start being compared sorted. restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool restrict conn (ArbitraryQuery q) = do-  compareNoSort conn (denotation' (restrictFirstBool Arrow.<<< q))-                     (onList restrictFirstBoolList (denotation' q))+  compare' conn (denotation' (restrictFirstBool Arrow.<<< q))+                (onList restrictFirstBoolList (denotation' q))  -- } @@ -247,24 +308,36 @@  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 prop1 p = fmap          TQ.ioProperty (p conn)+      prop2 p = (fmap . fmap) TQ.ioProperty (p conn)+      prop3 p = (fmap . fmap . fmap) TQ.ioProperty (p conn) -  let t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p+      test1 :: (Show a, TQ.Arbitrary a, TQ.Testable prop)+               => (PGS.Connection -> a -> IO prop) -> IO ()+      test1 = t . prop1 -  t propFmap-  t propApply-  t propLimit-  t propOffset-  t propOrder-  t propDistinct-  t propRestrict+      test2 :: (Show a1, Show a2, TQ.Arbitrary a1, TQ.Arbitrary a2,+                TQ.Testable prop)+               => (PGS.Connection -> a1 -> a2 -> IO prop) -> IO ()+      test2 = t . prop2 +      test3 :: (Show a1, Show a2, Show a3,+                TQ.Arbitrary a1, TQ.Arbitrary a2, TQ.Arbitrary a3,+                TQ.Testable prop)+               => (PGS.Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()+      test3 = t . prop3++      t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p++  test1 columns+  test2 fmap'+  test2 apply+  test3 limit+  test2 offset+  test2 order+  test1 distinct+  test1 restrict+ -- }  -- { Utilities@@ -302,5 +375,21 @@ restrictFirstBoolList = map snd                         . filter fst                         . map (firstBoolOrTrue True)++isSortedBy ::(a -> a -> Ord.Ordering) -> [a] -> Bool+isSortedBy comp xs = all (uncurry (.<=)) (zip xs (tail' xs))+  where tail' []     = []+        tail' (_:ys) = ys+        x .<= y       = lteBy comp x y++lteBy :: (a -> a -> Ord.Ordering) -> a -> a -> Bool+lteBy comp x y = comp x y /= Ord.GT++maximumBy :: (a -> a -> Ord.Ordering) -> [a] -> Maybe a+maximumBy _ []       = Nothing+maximumBy c xs@(_:_) = Just (List.maximumBy c xs)++minimumBy :: (a -> a -> Ord.Ordering) -> [a] -> Maybe a+minimumBy = maximumBy . flip  -- }

@@ -248,7 +248,7 @@ dropAndCreateDB :: PGS.Connection -> IO () dropAndCreateDB conn = do   mapM_ execute tables-  executeTextTable+  _ <- executeTextTable   mapM_ executeSerial serialTables   where execute = PGS.execute_ conn . dropAndCreateTableInt         executeTextTable = (PGS.execute_ conn . dropAndCreateTableText . columns2) "table6"@@ -334,6 +334,12 @@                                            table1Q)                       (\r -> [(1, 400) :: (Int, Int64), (2, 300)] == L.sort r) +testAggregateFunction :: Test+testAggregateFunction = testG (Arr.second aggregateCoerceFIXME+                        <<< O.aggregate (PP.p2 (O.groupBy, O.sum))+                                        (fmap (\(x, y) -> (x + 1, y)) table1Q))+                      (\r -> [(2, 400) :: (Int, Int64), (3, 300)] == L.sort r)+ testAggregateProfunctor :: Test testAggregateProfunctor = testG q expected   where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q@@ -568,7 +574,8 @@  allTests :: [Test] allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase,-            testDistinct, testAggregate, testAggregateProfunctor, testStringAggregate,+            testDistinct, testAggregate, testAggregateFunction,+            testAggregateProfunctor, testStringAggregate,             testOrderBy, testOrderBy2, testOrderBySame, testLimit, testOffset,             testLimitOffset, testOffsetLimit, testDistinctAndAggregate,             testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin,

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2015 Purely Agile Limited-version:         0.4.0.0+version:         0.4.1.0 synopsis:        An SQL-generating DSL targeting PostgreSQL description:     An SQL-generating DSL targeting PostgreSQL.  Allows                  Postgres queries to be written within Haskell in a@@ -48,6 +48,7 @@                    Opaleye.Aggregate,                    Opaleye.Binary,                    Opaleye.Column,+                   Opaleye.Constant,                    Opaleye.Distinct,                    Opaleye.Join,                    Opaleye.Manipulation,@@ -95,6 +96,7 @@     base >= 4 && < 5,     containers,     contravariant,+    multiset,     postgresql-simple,     profunctors,     product-profunctors,

@@ -1,6 +1,7 @@ module Opaleye ( module Opaleye.Aggregate                , module Opaleye.Binary                , module Opaleye.Column+               , module Opaleye.Constant                , module Opaleye.Distinct                , module Opaleye.Join                , module Opaleye.Manipulation@@ -17,6 +18,7 @@ import Opaleye.Aggregate import Opaleye.Binary import Opaleye.Column+import Opaleye.Constant import Opaleye.Distinct import Opaleye.Join import Opaleye.Manipulation

@@ -2,9 +2,11 @@                        Column,                        Nullable,                        unsafeCoerce,-                       unsafeCoerceColumn)  where+                       unsafeCoerceColumn,+                       unsafeCompositeField)  where -import           Opaleye.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn)+import           Opaleye.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn,+                                          unsafeCompositeField) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.PGTypes as T

@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++module Opaleye.Constant where++import           Opaleye.Column                  (Column)+import qualified Opaleye.Column                  as C+import qualified Opaleye.PGTypes                 as T++import qualified Data.CaseInsensitive            as CI+import qualified Data.Int                        as Int+import qualified Data.Text                       as ST+import qualified Data.Text.Lazy                  as LT+import qualified Data.ByteString                 as SBS+import qualified Data.ByteString.Lazy            as LBS+import qualified Data.Time                       as Time+import qualified Data.UUID                       as UUID++import qualified Data.Profunctor.Product         as PP+import           Data.Profunctor.Product         (empty, (***!), (+++!))+import qualified Data.Profunctor.Product.Default as D+import qualified Data.Profunctor                 as P++import           Control.Applicative (Applicative, pure, (<*>))+++newtype Constant haskells columns =+  Constant { constantExplicit :: haskells -> columns }++constant :: D.Default Constant haskells columns+         => haskells -> columns+constant = constantExplicit D.def++instance D.Default Constant haskell (Column sql)+         => D.Default Constant (Maybe haskell) (Column (C.Nullable sql)) where+  def = Constant (C.maybeToNullable . fmap f)+    where Constant f = D.def++instance D.Default Constant String (Column T.PGText) where+  def = Constant T.pgString++instance D.Default Constant LBS.ByteString (Column T.PGBytea) where+  def = Constant T.pgLazyByteString++instance D.Default Constant SBS.ByteString (Column T.PGBytea) where+  def = Constant T.pgStrictByteString++instance D.Default Constant ST.Text (Column T.PGText) where+  def = Constant T.pgStrictText++instance D.Default Constant LT.Text (Column T.PGText) where+  def = Constant T.pgLazyText++instance D.Default Constant Int (Column T.PGInt4) where+  def = Constant T.pgInt4++instance D.Default Constant Int.Int64 (Column T.PGInt8) where+  def = Constant T.pgInt8++instance D.Default Constant Double (Column T.PGFloat8) where+  def = Constant T.pgDouble++instance D.Default Constant Bool (Column T.PGBool) where+  def = Constant T.pgBool++instance D.Default Constant UUID.UUID (Column T.PGUuid) where+  def = Constant T.pgUUID++instance D.Default Constant Time.Day (Column T.PGDate) where+  def = Constant T.pgDay++instance D.Default Constant Time.UTCTime (Column T.PGTimestamptz) where+  def = Constant T.pgUTCTime++instance D.Default Constant Time.LocalTime (Column T.PGTimestamp) where+  def = Constant T.pgLocalTime++instance D.Default Constant Time.TimeOfDay (Column T.PGTime) where+  def = Constant T.pgTimeOfDay++instance D.Default Constant (CI.CI ST.Text) (Column T.PGCitext) where+  def = Constant T.pgCiStrictText++instance D.Default Constant (CI.CI LT.Text) (Column T.PGCitext) where+  def = Constant T.pgCiLazyText++instance D.Default Constant SBS.ByteString (Column T.PGJson) where+  def = Constant T.pgStrictJSON++instance D.Default Constant LBS.ByteString (Column T.PGJson) where+  def = Constant T.pgLazyJSON++instance D.Default Constant SBS.ByteString (Column T.PGJsonb) where+  def = Constant T.pgStrictJSONB++instance D.Default Constant LBS.ByteString (Column T.PGJsonb) where+  def = Constant T.pgLazyJSONB++-- { Boilerplate instances++instance Functor (Constant a) where+  fmap f (Constant g) = Constant (fmap f g)++instance Applicative (Constant a) where+  pure = Constant . pure+  Constant f <*> Constant x = Constant (f <*> x)++instance P.Profunctor Constant where+  dimap f g (Constant h) = Constant (P.dimap f g h)++instance PP.ProductProfunctor Constant where+  empty = Constant empty+  Constant f ***! Constant g = Constant (f ***! g)++instance PP.SumProfunctor Constant where+  Constant f +++! Constant g = Constant (f +++! g)++-- }

@@ -19,6 +19,10 @@ unsafeCoerceColumn :: Column a -> Column b unsafeCoerceColumn (Column e) = Column e +unsafeCompositeField :: Column a -> String -> Column b+unsafeCompositeField (Column e) fieldName =+  Column (HPQ.CompositeExpr e fieldName)+ binOp :: HPQ.BinOp -> Column a -> Column b -> Column c binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e') 

@@ -17,6 +17,7 @@  data PrimExpr   = AttrExpr  Symbol                 | BaseTableAttrExpr Attribute+                | CompositeExpr     PrimExpr Attribute -- ^ Composite Type Query                 | BinExpr   BinOp PrimExpr PrimExpr                 | UnExpr    UnOp PrimExpr                 | AggrExpr  AggrOp PrimExpr

@@ -30,6 +30,7 @@  -- | Expressions in SQL statements. data SqlExpr = ColumnSqlExpr  SqlColumn+             | CompositeSqlExpr SqlExpr String              | BinSqlExpr     String SqlExpr SqlExpr              | PrefixSqlExpr  String SqlExpr              | PostfixSqlExpr String SqlExpr

@@ -80,6 +80,7 @@     case expr of       AttrExpr (Symbol a t) -> ColumnSqlExpr (SqlColumn (tagWith t a))       BaseTableAttrExpr a -> ColumnSqlExpr (SqlColumn a)+      CompositeExpr e x -> CompositeSqlExpr (defaultSqlExpr gen e) x       BinExpr op e1 e2 ->         let leftE = sqlExpr gen e1             rightE = sqlExpr gen e2

@@ -3,6 +3,7 @@ -- License     :  BSD-style  module Opaleye.Internal.HaskellDB.Sql.Print (+                                     deliteral,                                      ppUpdate,                                      ppDelete,                                      ppInsert,@@ -27,6 +28,14 @@                                   empty, equals, hcat, hsep, parens, punctuate,                                   text, vcat) +-- Silliness to avoid "ORDER BY 1" etc. meaning order by the first+-- column.  We need an identity function, but due to+-- https://github.com/tomjaguarpaw/haskell-opaleye/issues/100 we need+-- to be careful not to be over enthusiastic.  Just apply COALESCE to+-- literals.+deliteral :: SqlExpr -> SqlExpr+deliteral expr@(ConstSqlExpr _) = FunSqlExpr "COALESCE" [expr]+deliteral expr                  = expr  ppWhere :: [SqlExpr] -> Doc ppWhere [] = empty@@ -38,13 +47,7 @@ ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es   where     ppGroupAttrs :: [SqlExpr] -> Doc-    ppGroupAttrs cs = commaV nameOrExpr cs-    nameOrExpr :: SqlExpr -> Doc-    nameOrExpr (ColumnSqlExpr (SqlColumn col)) = text col-    -- 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)+    ppGroupAttrs cs = commaV (ppSqlExpr . deliteral) cs  ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty@@ -53,8 +56,7 @@     -- 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)+      ppOrd (e,o) = ppSqlExpr (deliteral e)                       <+> ppSqlDirection o                       <+> ppSqlNulls o @@ -68,9 +70,9 @@         Sql.SqlNullsFirst -> "NULLS FIRST"         Sql.SqlNullsLast  -> "NULLS LAST" -ppAs :: String -> Doc -> Doc-ppAs alias expr    | null alias    = expr-                   | otherwise     = expr <+> hsep [text "as", doubleQuotes (text alias)]+ppAs :: Maybe String -> Doc -> Doc+ppAs Nothing      expr = expr+ppAs (Just alias) expr = expr <+> hsep [text "as", doubleQuotes (text alias)]   ppUpdate :: SqlUpdate -> Doc@@ -111,6 +113,7 @@ ppSqlExpr expr =     case expr of       ColumnSqlExpr c     -> ppColumn c+      CompositeSqlExpr s x -> parens (ppSqlExpr s) <> text "." <> text x       ParensSqlExpr e -> parens (ppSqlExpr e)       BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2       PrefixSqlExpr op e  -> text op <+> ppSqlExpr e

@@ -10,6 +10,7 @@ import qualified Data.Functor.Contravariant.Divisible as Divisible import qualified Data.Profunctor as P import qualified Data.Monoid as M+import qualified Data.Semigroup as S import qualified Data.Void as Void  {-|@@ -28,9 +29,12 @@ instance C.Contravariant Order where   contramap f (Order g) = Order (P.lmap f g) +instance S.Semigroup (Order a) where+  Order o <> Order o' = Order (o S.<> o')+ instance M.Monoid (Order a) where   mempty = Order M.mempty-  Order o `mappend` Order o' = Order (o `M.mappend` o')+  mappend = (S.<>)  instance Divisible.Divisible Order where   divide f o o' = M.mappend (C.contramap (fst . f) o)

@@ -66,7 +66,7 @@  -- This is pretty much just nameAs from HaskellDB nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc-nameAs (expr, name) = HPrint.ppAs (maybe "" unColumn name) (HPrint.ppSqlExpr expr)+nameAs (expr, name) = HPrint.ppAs (fmap unColumn name) (HPrint.ppSqlExpr expr)   where unColumn (HSql.SqlColumn s) = s  ppTables :: [Select] -> Doc@@ -78,12 +78,12 @@  -- TODO: duplication with ppSql ppTable :: (TableAlias, Select) -> Doc-ppTable (alias, select) = case select of-  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))+ppTable (alias, select) = HPrint.ppAs (Just alias) $ case select of+  Table table           -> HPrint.ppTable table+  SelectFrom selectFrom -> parens (ppSelectFrom selectFrom)+  SelectJoin slj        -> parens (ppSelectJoin slj)+  SelectValues slv      -> parens (ppSelectValues slv)+  SelectBinary slb      -> parens (ppSelectBinary slb)  ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppGroupBy Nothing   = empty@@ -98,7 +98,7 @@ ppOffset (Just n) = text ("OFFSET " ++ show n)  ppValues :: [[HSql.SqlExpr]] -> Doc-ppValues v = HPrint.ppAs "V" (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v))+ppValues v = HPrint.ppAs (Just "V") (parens (text "VALUES" $$ HPrint.commaV ppValuesRow v))  ppValuesRow :: [HSql.SqlExpr] -> Doc ppValuesRow = parens . HPrint.commaH HPrint.ppSqlExpr@@ -113,10 +113,10 @@ ppInsertReturning (Sql.Returning insert returnExprs) =   HPrint.ppInsert insert   $$ text "RETURNING"-  <+> HPrint.commaV HPrint.ppSqlExpr returnExprs+  <+> HPrint.commaV HPrint.ppSqlExpr (NEL.toList returnExprs)  ppUpdateReturning :: Sql.Returning HSql.SqlUpdate -> Doc ppUpdateReturning (Sql.Returning update returnExprs) =   HPrint.ppUpdate update   $$ text "RETURNING"-  <+> HPrint.commaV HPrint.ppSqlExpr returnExprs+  <+> HPrint.commaV HPrint.ppSqlExpr (NEL.toList returnExprs)

@@ -2,13 +2,13 @@  module Opaleye.Internal.RunQuery where -import           Control.Applicative (Applicative, pure, (<*>), liftA2)+import           Control.Applicative (Applicative, pure, (*>), (<*>), liftA2)  import           Database.PostgreSQL.Simple.Internal (RowParser) import           Database.PostgreSQL.Simple.FromField (FieldParser, FromField,                                                        fromField)-import           Database.PostgreSQL.Simple.FromRow (fieldWith)-import           Database.PostgreSQL.Simple.Types (fromPGArray)+import           Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith)+import           Database.PostgreSQL.Simple.Types (fromPGArray, Only(..))  import           Opaleye.Column (Column) import           Opaleye.Internal.Column (Nullable)@@ -60,6 +60,11 @@ -- 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.++-- I can no longer remember what the above comment means, but it might+-- be that we can't add nullability to a RowParser, only to a+-- FieldParser, so we have to have some type that we know contains+-- just a FieldParser. data QueryRunnerColumn pgType haskellType =   QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType) @@ -265,3 +270,14 @@         _       -> returnError UnexpectedNull field ""  -- }++prepareRowParser :: QueryRunner columns haskells -> columns -> RowParser haskells+prepareRowParser (QueryRunner _ rowParser nonZeroColumns) cols =+  if nonZeroColumns cols+  then rowParser cols+  else (fromRow :: RowParser (Only Int)) *> rowParser cols+     -- 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.

@@ -8,6 +8,7 @@ import           Opaleye.Internal.HaskellDB.PrimQuery (Symbol(Symbol)) import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD+import qualified Opaleye.Internal.HaskellDB.Sql.Print as SP import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG import qualified Opaleye.Internal.Tag as T @@ -62,7 +63,7 @@  data TableName = String -data Returning a = Returning a [HSql.SqlExpr]+data Returning a = Returning a (NEL.NonEmpty HSql.SqlExpr)  sqlQueryGenerator :: PQ.PrimQueryFold Select sqlQueryGenerator = (unit, baseTable, product, aggregate, order, limit_, join,@@ -101,7 +102,7 @@         --- constant.         handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr         handleEmpty =-          M.fromMaybe (return (HSql.FunSqlExpr "COALESCE" [HSql.ConstSqlExpr "0"]))+          M.fromMaybe (return (SP.deliteral (HSql.ConstSqlExpr "0")))           . NEL.nonEmpty          groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]@@ -187,6 +188,12 @@   (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+             -> NEL.NonEmpty (HSql.SqlExpr, Maybe a)+ensureColumns = ensureColumnsGen (\x -> (x,Nothing))++-- | For ensuring that we have at least one column in a SELECT or RETURNING+ensureColumnsGen :: (HSql.SqlExpr -> a)+              -> [a]+              -> NEL.NonEmpty a+ensureColumnsGen f = M.fromMaybe (return . f $ HSql.ConstSqlExpr "0")+                   . NEL.nonEmpty

@@ -88,6 +88,7 @@   -- tablecols contained in the View (which would be naughty)   mkName pe i = (++ i) $ case pe of     HPQ.BaseTableAttrExpr columnName -> columnName+    HPQ.CompositeExpr columnExpr fieldName -> mkName columnExpr i ++ fieldName     _ -> "tablecolumn"  runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]

@@ -98,7 +98,7 @@   where insert = arrangeInsert table columns         TI.Table _ (TI.TableProperties _ (TI.View columnsR)) = table         returningPEs = U.collectPEs unpackspec (returningf columnsR)-        returningSEs = map Sql.sqlExpr returningPEs+        returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)  arrangeInsertReturningSql :: U.Unpackspec returned ignored                           -> T.Table columnsW columnsR@@ -115,11 +115,11 @@                             -> columnsW                             -> (columnsR -> returned)                             -> IO [haskells]-runInsertReturningExplicit qr conn t w r = PGS.queryWith_ (rowParser (r v)) conn+runInsertReturningExplicit qr conn t w r = PGS.queryWith_ parser 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+  where IRQ.QueryRunner u _ _ = qr+        parser = IRQ.prepareRowParser qr (r v)         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.@@ -147,7 +147,7 @@   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+        returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)  arrangeUpdateReturningSql :: U.Unpackspec returned ignored                        -> T.Table columnsW columnsR@@ -167,10 +167,10 @@                            -> (columnsR -> returned)                            -> IO [haskells] runUpdateReturningExplicit qr conn t update cond r =-  PGS.queryWith_ (rowParser (r v)) conn+  PGS.queryWith_ parser 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+  where IRQ.QueryRunner u _ _ = qr+        parser = IRQ.prepareRowParser qr (r v)         TI.Table _ (TI.TableProperties _ (TI.View v)) = t  runUpdateReturning :: (D.Default RQ.QueryRunner returned haskells)

@@ -96,13 +96,13 @@ pgDay = IPT.unsafePgFormatTime "date" "'%F'"  pgUTCTime :: Time.UTCTime -> Column PGTimestamptz-pgUTCTime = IPT.unsafePgFormatTime "timestamptz" "'%FT%TZ'"+pgUTCTime = IPT.unsafePgFormatTime "timestamptz" "'%FT%T%QZ'"  pgLocalTime :: Time.LocalTime -> Column PGTimestamp-pgLocalTime = IPT.unsafePgFormatTime "timestamp" "'%FT%T'"+pgLocalTime = IPT.unsafePgFormatTime "timestamp" "'%FT%T%Q'"  pgTimeOfDay :: Time.TimeOfDay -> Column PGTime-pgTimeOfDay = IPT.unsafePgFormatTime "time" "'%T'"+pgTimeOfDay = IPT.unsafePgFormatTime "time" "'%T%Q'"  -- "We recommend not using the type time with time zone" -- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html@@ -130,7 +130,8 @@ -- 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.+-- TODO: We need to add literal JSON and JSONB types so we can say+-- `castToTypeTyped JSONB` rather than `castToType "jsonb"`. pgJSONB :: String -> Column PGJsonb pgJSONB = IPT.castToType "jsonb" . HSD.quote 

@@ -20,8 +20,6 @@ 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@@ -52,20 +50,16 @@                  -> PGS.Connection                  -> Query columns                  -> IO [haskells]-runQueryExplicit (QueryRunner u rowParser nonZeroColumns) conn q =-  PGS.queryWith_ parser conn sql+runQueryExplicit qr conn q = PGS.queryWith_ parser conn sql+  where (sql, parser) = prepareQuery qr q++prepareQuery :: QueryRunner columns haskells -> Query columns -> (PGS.Query, FR.RowParser haskells)+prepareQuery qr@(QueryRunner u _ _) q = (sql, parser)   where sql :: PGS.Query         sql = String.fromString (S.showSqlForPostgresExplicit u q)         -- FIXME: We're doing work twice here         (b, _, _) = Q.runSimpleQueryArrStart q ()-        parser = 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.+        parser = IRQ.prepareRowParser qr b  -- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on --   your own datatypes.  For example: