diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -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 -- } diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -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, diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -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, diff --git a/src/Opaleye.hs b/src/Opaleye.hs --- a/src/Opaleye.hs +++ b/src/Opaleye.hs @@ -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 diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -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 diff --git a/src/Opaleye/Constant.hs b/src/Opaleye/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Constant.hs @@ -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) + +-- } diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs --- a/src/Opaleye/Internal/Column.hs +++ b/src/Opaleye/Internal/Column.hs @@ -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') diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs --- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -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 diff --git a/src/Opaleye/Internal/Order.hs b/src/Opaleye/Internal/Order.hs --- a/src/Opaleye/Internal/Order.hs +++ b/src/Opaleye/Internal/Order.hs @@ -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) diff --git a/src/Opaleye/Internal/Print.hs b/src/Opaleye/Internal/Print.hs --- a/src/Opaleye/Internal/Print.hs +++ b/src/Opaleye/Internal/Print.hs @@ -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) diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs --- a/src/Opaleye/Internal/RunQuery.hs +++ b/src/Opaleye/Internal/RunQuery.hs @@ -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. diff --git a/src/Opaleye/Internal/Sql.hs b/src/Opaleye/Internal/Sql.hs --- a/src/Opaleye/Internal/Sql.hs +++ b/src/Opaleye/Internal/Sql.hs @@ -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 diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs --- a/src/Opaleye/Internal/Table.hs +++ b/src/Opaleye/Internal/Table.hs @@ -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)] diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -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) diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -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 diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -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: