diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/Doc/Tutorial/TutorialAdvanced.lhs b/Doc/Tutorial/TutorialAdvanced.lhs --- a/Doc/Tutorial/TutorialAdvanced.lhs +++ b/Doc/Tutorial/TutorialAdvanced.lhs @@ -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 * diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -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, diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Purely Agile Limited +Copyright (c) 2014-2015 Purely Agile Limited All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck.hs @@ -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) + +-- } diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -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 diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -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 diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -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 diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -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. diff --git a/src/Opaleye/Internal/Aggregate.hs b/src/Opaleye/Internal/Aggregate.hs --- a/src/Opaleye/Internal/Aggregate.hs +++ b/src/Opaleye/Internal/Aggregate.hs @@ -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) -- } diff --git a/src/Opaleye/Internal/Binary.hs b/src/Opaleye/Internal/Binary.hs --- a/src/Opaleye/Internal/Binary.hs +++ b/src/Opaleye/Internal/Binary.hs @@ -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') 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 @@ -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') diff --git a/src/Opaleye/Internal/Distinct.hs b/src/Opaleye/Internal/Distinct.hs --- a/src/Opaleye/Internal/Distinct.hs +++ b/src/Opaleye/Internal/Distinct.hs @@ -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) -- } 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 @@ -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) 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 @@ -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]) 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 @@ -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 diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs @@ -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 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 @@ -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 diff --git a/src/Opaleye/Internal/Helpers.hs b/src/Opaleye/Internal/Helpers.hs --- a/src/Opaleye/Internal/Helpers.hs +++ b/src/Opaleye/Internal/Helpers.hs @@ -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) diff --git a/src/Opaleye/Internal/Join.hs b/src/Opaleye/Internal/Join.hs --- a/src/Opaleye/Internal/Join.hs +++ b/src/Opaleye/Internal/Join.hs @@ -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 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 @@ -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) diff --git a/src/Opaleye/Internal/PGTypes.hs b/src/Opaleye/Internal/PGTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/PGTypes.hs @@ -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 diff --git a/src/Opaleye/Internal/PackMap.hs b/src/Opaleye/Internal/PackMap.hs --- a/src/Opaleye/Internal/PackMap.hs +++ b/src/Opaleye/Internal/PackMap.hs @@ -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 -- } diff --git a/src/Opaleye/Internal/PrimQuery.hs b/src/Opaleye/Internal/PrimQuery.hs --- a/src/Opaleye/Internal/PrimQuery.hs +++ b/src/Opaleye/Internal/PrimQuery.hs @@ -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 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 @@ -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 diff --git a/src/Opaleye/Internal/QueryArr.hs b/src/Opaleye/Internal/QueryArr.hs --- a/src/Opaleye/Internal/QueryArr.hs +++ b/src/Opaleye/Internal/QueryArr.hs @@ -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) 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,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 "" -- } 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 @@ -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 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 @@ -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 diff --git a/src/Opaleye/Internal/TableMaker.hs b/src/Opaleye/Internal/TableMaker.hs --- a/src/Opaleye/Internal/TableMaker.hs +++ b/src/Opaleye/Internal/TableMaker.hs @@ -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) diff --git a/src/Opaleye/Internal/Tag.hs b/src/Opaleye/Internal/Tag.hs --- a/src/Opaleye/Internal/Tag.hs +++ b/src/Opaleye/Internal/Tag.hs @@ -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 diff --git a/src/Opaleye/Internal/Unpackspec.hs b/src/Opaleye/Internal/Unpackspec.hs --- a/src/Opaleye/Internal/Unpackspec.hs +++ b/src/Opaleye/Internal/Unpackspec.hs @@ -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) --} diff --git a/src/Opaleye/Internal/Values.hs b/src/Opaleye/Internal/Values.hs --- a/src/Opaleye/Internal/Values.hs +++ b/src/Opaleye/Internal/Values.hs @@ -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)))) diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs --- a/src/Opaleye/Join.hs +++ b/src/Opaleye/Join.hs @@ -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 diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -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 diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -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 diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs --- a/src/Opaleye/Order.hs +++ b/src/Opaleye/Order.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 diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -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 diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -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: diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -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)))