diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## 0.5.1.0 + +* Added + * support for JSON operators + * Many improvements to the Haddocks + * RIGHT and FULL OUTER joins + ## 0.5.0.0 * Added diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -61,10 +61,14 @@ > insertNothing = arrangeInsertManySql table (return (Nothing, 2, 3, P.pgString "Hello")) ghci> putStrLn insertNothing -INSERT INTO tablename (x, - y) -VALUES (2.0, - 3.0) +INSERT INTO "tablename" ("id", + "x", + "y", + "s") +VALUES (DEFAULT, + 2.0, + 3.0, + E'Hello') If we'd like to pass a value into the insertion function, we can't @@ -74,7 +78,7 @@ > insertNonLiteral i = > arrangeInsertManySql table (return (Nothing, 2, C.constant i, P.pgString "Hello")) -ghci> > putStrLn $ insertNonLiteral 12.0 +ghci> putStrLn $ insertNonLiteral 12.0 INSERT INTO "tablename" ("id", "x", "y", @@ -91,12 +95,14 @@ > insertJust = arrangeInsertManySql table (return (Just 1, 2, 3, P.pgString "Hello")) ghci> putStrLn insertJust -INSERT INTO tablename (id, - x, - y) +INSERT INTO "tablename" ("id", + "x", + "y", + "s") VALUES (1, 2.0, - 3.0) + 3.0, + E'Hello') An update takes an update function from the read type to the write @@ -109,10 +115,11 @@ > (\(id_, _, _, _) -> id_ .== 5) ghci> putStrLn update -UPDATE tablename -SET x = (x) + (y), - y = (x) - (y) -WHERE ((id) = 5) +SET "id" = DEFAULT, + "x" = ("x") + ("y"), + "y" = ("x") - ("y"), + "s" = "s" +WHERE (("id") = 5) Sometimes when we insert a row with an automatically generated field @@ -129,11 +136,15 @@ > def' = def ghci> putStrLn insertReturning -INSERT INTO tablename (x, - y) -VALUES (4.0, - 5.0) -RETURNING id +INSERT INTO "tablename" ("id", + "x", + "y", + "s") +VALUES (DEFAULT, + 4.0, + 5.0, + E'Bye') +RETURNING "id" Running the queries diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -109,9 +109,9 @@ instance TQ.Arbitrary ArbitraryColumns where arbitrary = do - l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1] - ++ map (return . Right) [False, True])) - return (ArbitraryColumns l) + l <- TQ.listOf (TQ.oneof (map (return . Left) [-1, 0, 1] + ++ map (return . Right) [False, True])) + return (ArbitraryColumns l) instance TQ.Arbitrary ArbitraryColumnsList where -- We don't want to choose very big lists because we take diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -19,6 +19,8 @@ import Data.Monoid ((<>)) import qualified Data.String as String import qualified Data.Time as Time +import qualified Data.Aeson as Json +import qualified Data.Text as T import qualified System.Exit as Exit import qualified System.Environment as Environment @@ -149,6 +151,12 @@ table7 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText) table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2")) +table8 :: O.Table (Column O.PGJson) (Column O.PGJson) +table8 = O.Table "table8" (O.required "column1") + +table9 :: O.Table (Column O.PGJsonb) (Column O.PGJsonb) +table9 = O.Table "table9" (O.required "column1") + 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")) @@ -168,6 +176,12 @@ table7Q :: Query (Column O.PGText, Column O.PGText) table7Q = O.queryTable table7 +table8Q :: Query (Column O.PGJson) +table8Q = O.queryTable table8 + +table9Q :: Query (Column O.PGJsonb) +table9Q = O.queryTable table9 + table1dataG :: Num a => [(a, a)] table1dataG = [ (1, 100) , (1, 100) @@ -221,6 +235,20 @@ table7columndata :: [(Column O.PGText, Column O.PGText)] table7columndata = map (O.pgString *** O.pgString) table7data +table8data :: [Json.Value] +table8data = [ Json.object + [ "a" Json..= ([10,20..100] :: [Int]) + , "b" Json..= Json.object ["x" Json..= (42 :: Int)] + , "c" Json..= (21 :: Int) + ] + ] + +table8columndata :: [Column O.PGJson] +table8columndata = map O.pgValueJSON table8data + +table9columndata :: [Column O.PGJsonb] +table9columndata = map O.pgValueJSONB table8data + -- 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 @@ -247,6 +275,12 @@ integer c = ("\"" ++ c ++ "\"" ++ " SERIAL") commas = L.intercalate "," . map integer +dropAndCreateTableJson :: (String, [String]) -> PGS.Query +dropAndCreateTableJson = dropAndCreateTable "json" + +dropAndCreateTableJsonb :: (String, [String]) -> PGS.Query +dropAndCreateTableJsonb = dropAndCreateTable "jsonb" + type Table_ = (String, [String]) -- This should ideally be derived from the table definition above @@ -264,14 +298,25 @@ textTables :: [Table_] textTables = map columns2 ["table6", "table7"] +jsonTables :: [Table_] +jsonTables = [("table8", ["column1"])] + +jsonbTables :: [Table_] +jsonbTables = [("table9", ["column1"])] + dropAndCreateDB :: PGS.Connection -> IO () dropAndCreateDB conn = do mapM_ execute tables mapM_ executeTextTable textTables mapM_ executeSerial serialTables + mapM_ executeJson jsonTables + -- Disabled until Travis supports Postgresql >= 9.4 + -- mapM_ executeJsonb jsonbTables where execute = PGS.execute_ conn . dropAndCreateTableInt executeTextTable = PGS.execute_ conn . dropAndCreateTableText executeSerial = PGS.execute_ conn . dropAndCreateTableSerial + executeJson = PGS.execute_ conn . dropAndCreateTableJson + -- executeJsonb = PGS.execute_ conn . dropAndCreateTableJsonb type Test = PGS.Connection -> IO Bool @@ -334,6 +379,16 @@ expected :: [Int] expected = [12, 12, 21, 33] +-- This tests case_ with an empty list of cases, to make sure it generates valid +-- SQL. +testCaseEmpty :: Test +testCaseEmpty = testG q (== expected) + where q :: Query (Column O.PGInt4) + q = table1Q >>> proc _ -> + Arr.returnA -< O.case_ [] 33 + expected :: [Int] + expected = [33, 33, 33, 33] + testDistinct :: Test testDistinct = testG (O.distinct table1Q) (\r -> L.sort (L.nub table1data) == L.sort r) @@ -681,6 +736,100 @@ where doubles = [1 :: Double, 2] +-- Test opaleye's equivalent of c1->'c' +testJsonGetFieldValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetFieldValue dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c" + expected :: [Maybe Json.Value] + expected = [Just $ Json.Number $ fromInteger 21] + +-- Test opaleye's equivalent of c1->>'c' +testJsonGetFieldText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetFieldText dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c" + expected :: [Maybe T.Text] + expected = [Just "21"] + +-- Test opaleye's equivalent of c1->'a'->2 +testJsonGetArrayValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetArrayValue dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..-> O.pgInt4 2 + expected :: [Maybe Json.Value] + expected = [Just $ Json.Number $ fromInteger 30] + +-- Test opaleye's equivalent of c1->'a'->>2 +testJsonGetArrayText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetArrayText dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..->> O.pgInt4 2 + expected :: [Maybe T.Text] + expected = [Just "30"] + +-- Test opaleye's equivalent of c1->>'missing' +-- Note that the missing field does not exist. +testJsonGetMissingField :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetMissingField dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing" + expected :: [Maybe T.Text] + expected = [Nothing] + +-- Test opaleye's equivalent of c1#>'{b,x}' +testJsonGetPathValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetPathValue dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..#> O.pgArray O.pgStrictText ["b", "x"] + expected :: [Maybe Json.Value] + expected = [Just $ Json.Number $ fromInteger 42] + +-- Test opaleye's equivalent of c1#>>'{b,x}' +testJsonGetPathText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetPathText dataQuery = testG q (== expected) + where q = dataQuery >>> proc c1 -> do + Arr.returnA -< O.toNullable c1 O..#>> O.pgArray O.pgStrictText ["b", "x"] + expected :: [Maybe T.Text] + expected = [Just "42"] + +-- Test opaleye's equivalent of c1 @> '{"c":21}'::jsonb +testJsonbRightInLeft :: Test +testJsonbRightInLeft = testG q (== [True]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< c1 O..@> O.pgJSONB "{\"c\":21}" + +-- Test opaleye's equivalent of '{"c":21}'::jsonb <@ c1 +testJsonbLeftInRight :: Test +testJsonbLeftInRight = testG q (== [True]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< O.pgJSONB "{\"c\":21}" O..<@ c1 + +-- Test opaleye's equivalent of c1 ? 'b' +testJsonbContains :: Test +testJsonbContains = testG q (== [True]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< c1 O..? O.pgStrictText "c" + +-- Test opaleye's equivalent of c1 ? 'missing' +-- Note that the missing field does not exist. +testJsonbContainsMissing :: Test +testJsonbContainsMissing = testG q (== [False]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< c1 O..? O.pgStrictText "missing" + +-- Test opaleye's equivalent of c1 ?| array['b', 'missing'] +testJsonbContainsAny :: Test +testJsonbContainsAny = testG q (== [True]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< c1 O..?| O.pgArray O.pgStrictText ["b", "missing"] + +-- Test opaleye's equivalent of c1 ?& array['a', 'b', 'c'] +testJsonbContainsAll :: Test +testJsonbContainsAll = testG q (== [True]) + where q = table9Q >>> proc c1 -> do + Arr.returnA -< c1 O..?& O.pgArray O.pgStrictText ["a", "b", "c"] + allTests :: [Test] allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase, testDistinct, testAggregate, testAggregate0, testAggregateFunction, @@ -694,9 +843,25 @@ testKeywordColNames, testInsertSerial, testInQuery, testAtTimeZone, testStringArrayAggregateOrdered, testMultipleAggregateOrdered, testOverwriteAggregateOrdered, testCountRows0, testCountRows3, - testArrayLiterals, testEmptyArray, testFloatArray + testArrayLiterals, testEmptyArray, testFloatArray, testCaseEmpty, + testJsonGetFieldValue table8Q, testJsonGetFieldText table8Q, + testJsonGetMissingField table8Q, testJsonGetArrayValue table8Q, + testJsonGetArrayText table8Q, testJsonGetPathValue table8Q, + testJsonGetPathText table8Q ] +-- Note: these tests are left out of allTests until Travis supports +-- Postgresql >= 9.4 +jsonbTests :: [Test] +jsonbTests = [testJsonGetFieldValue table9Q,testJsonGetFieldText table9Q, + testJsonGetMissingField table9Q,testJsonGetArrayValue table9Q, + testJsonGetArrayText table9Q,testJsonGetPathValue table9Q, + testJsonGetPathText table9Q, + testJsonbRightInLeft, testJsonbLeftInRight, + testJsonbContains, testJsonbContainsMissing, + testJsonbContainsAny, testJsonbContainsAll + ] + -- Environment.getEnv throws an exception on missing environment variable! getEnv :: String -> IO (Maybe String) getEnv var = do @@ -732,6 +897,9 @@ , (table4, table4columndata) ] insert (table6, table6columndata) insert (table7, table7columndata) + insert (table8, table8columndata) + -- Disabled until Travis supports Postgresql >= 9.4 + -- insert (table9, table9columndata) -- Need to run quickcheck after table data has been inserted QuickCheck.run conn diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -1,6 +1,6 @@ name: opaleye copyright: Copyright (c) 2014-2016 Purely Agile Limited -version: 0.5.0.0 +version: 0.5.1.0 synopsis: An SQL-generating DSL targeting PostgreSQL description: An SQL-generating DSL targeting PostgreSQL. Allows Postgres queries to be written within Haskell in a @@ -13,7 +13,7 @@ maintainer: Purely Agile category: Database build-type: Simple -cabal-version: >= 1.8 +cabal-version: >= 1.10 extra-doc-files: *.md, Doc/*.md tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 @@ -23,13 +23,14 @@ location: https://github.com/tomjaguarpaw/haskell-opaleye.git library + default-language: Haskell2010 hs-source-dirs: src build-depends: -- attoparsec can be removed once postgresql-simple patch in -- Internal.RunQuery is merged upstream - aeson >= 0.6 && < 0.12 + aeson >= 0.6 && < 1.1 , attoparsec >= 0.10.3 && < 0.14 - , base >= 4 && < 5 + , base >= 4.6 && < 5 , base16-bytestring >= 0.1.1.6 && < 0.2 , case-insensitive >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 @@ -92,11 +93,13 @@ ghc-options: -Wall test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Test.hs other-modules: QuickCheck hs-source-dirs: Test build-depends: + aeson >= 0.6 && < 0.12, base >= 4 && < 5, containers, contravariant, @@ -106,11 +109,13 @@ product-profunctors, QuickCheck, semigroups, + text >= 0.11 && < 1.3, time, opaleye ghc-options: -Wall test-suite tutorial + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TutorialAdvanced, diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -1,4 +1,7 @@ --- | Perform aggregations on query results. +-- | Perform aggregation on 'Query's. To aggregate a 'Query' you +-- should construct an 'Aggregator' encoding how you want the +-- aggregation to proceed, then call 'aggregate' on it. + module Opaleye.Aggregate (module Opaleye.Aggregate, Aggregator) where import Control.Applicative (pure) @@ -25,6 +28,13 @@ Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of type @a@, apply the aggregator to the results of the query. +If you simply want to count the number of rows in a query you might +find the 'countRows' function more convenient. + +By design there is no aggregation function of type @Aggregator b b' -> +QueryArr a b -> QueryArr a b'@. Such a function would allow violation +of SQL's scoping rules and lead to invalid queries. + Please note that when aggregating an empty query with no @GROUP BY@ clause, Opaleye's behaviour differs from Postgres's behaviour. Postgres returns a single row whereas Opaleye returns zero rows. @@ -33,12 +43,6 @@ query has zero rows it has zero groups, and thus zero rows in the result of an aggregation.) -If you simply want to count the number of rows in a query you might -find the 'countRows' function more convenient. - -By design there is no aggregation function of type @Aggregator b b' -> -QueryArr a b -> QueryArr a b'@. Such a function would allow violation -of SQL's scoping rules and lead to invalid queries. -} aggregate :: Aggregator a b -> Query a -> Query b aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q) diff --git a/src/Opaleye/Binary.hs b/src/Opaleye/Binary.hs --- a/src/Opaleye/Binary.hs +++ b/src/Opaleye/Binary.hs @@ -1,15 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} - -module Opaleye.Binary where - -import Opaleye.QueryArr (Query) -import qualified Opaleye.Internal.Binary as B -import qualified Opaleye.Internal.PrimQuery as PQ - -import Data.Profunctor.Product.Default (Default, def) - --- | Example type specialization: +-- | Binary relational operations on 'Query's, that is, operations +-- which take two 'Query's as arguments and return a single 'Query'. -- +-- All the binary relational operations have the same type +-- specializations. For example: +-- -- @ -- unionAll :: Query (Column a, Column b) -- -> Query (Column a, Column b) @@ -24,64 +18,75 @@ -- -> Query (Foo (Column a) (Column b) (Column c)) -- @ -- --- By design there is no union function of type @QueryArr a b -> --- QueryArr a b -> QueryArr a b@. Such a function would allow --- violation of SQL's scoping rules and lead to invalid queries. +-- Please note that by design there are no binary relational functions +-- of type @QueryArr a b -> QueryArr a b -> QueryArr a b@. Such +-- functions would allow violation of SQL's scoping rules and lead to +-- invalid queries. +-- +-- `unionAll` is very close to being the @<|>@ operator of a +-- @Control.Applicative.Alternative@ instance but it fails to work +-- only because of the typeclass constraint it has. + +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +module Opaleye.Binary where + +import Opaleye.QueryArr (Query) +import qualified Opaleye.Internal.Binary as B +import qualified Opaleye.Internal.PrimQuery as PQ + +import Data.Profunctor.Product.Default (Default, def) + unionAll :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns unionAll = unionAllExplicit def -unionAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' -unionAllExplicit = B.sameTypeBinOpHelper PQ.UnionAll - - -- | The same as unionAll, except that it additionally removes any -- duplicate rows. union :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns union = unionExplicit def -unionExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' -unionExplicit = B.sameTypeBinOpHelper PQ.Union - - - intersectAll :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns intersectAll = intersectAllExplicit def -intersectAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' -intersectAllExplicit = B.sameTypeBinOpHelper PQ.IntersectAll - - -- | The same as intersectAll, except that it additionally removes any -- duplicate rows. intersect :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns intersect = intersectExplicit def -intersectExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' -intersectExplicit = B.sameTypeBinOpHelper PQ.Intersect - - exceptAll :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns exceptAll = exceptAllExplicit def -exceptAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' -exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll - - -- | The same as exceptAll, except that it additionally removes any -- duplicate rows. except :: Default B.Binaryspec columns columns => Query columns -> Query columns -> Query columns except = exceptExplicit def + + +unionAllExplicit :: B.Binaryspec columns columns' + -> Query columns -> Query columns -> Query columns' +unionAllExplicit = B.sameTypeBinOpHelper PQ.UnionAll + +unionExplicit :: B.Binaryspec columns columns' + -> Query columns -> Query columns -> Query columns' +unionExplicit = B.sameTypeBinOpHelper PQ.Union + +intersectAllExplicit :: B.Binaryspec columns columns' + -> Query columns -> Query columns -> Query columns' +intersectAllExplicit = B.sameTypeBinOpHelper PQ.IntersectAll + +intersectExplicit :: B.Binaryspec columns columns' + -> Query columns -> Query columns -> Query columns' +intersectExplicit = B.sameTypeBinOpHelper PQ.Intersect + +exceptAllExplicit :: B.Binaryspec columns columns' + -> Query columns -> Query columns -> Query columns' +exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll exceptExplicit :: B.Binaryspec columns columns' -> Query columns -> Query columns -> Query columns' diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -1,3 +1,8 @@ +-- | Functions for working directly with 'Column's. +-- +-- Please note that numeric 'Column' types are instances of 'Num', so +-- you can use '*', '/', '+', '-' on them. + module Opaleye.Column (module Opaleye.Column, Column, Nullable, @@ -17,6 +22,7 @@ null :: Column (Nullable a) null = C.Column (HPQ.ConstExpr HPQ.NullLit) +-- | @TRUE@ if the value of the column is @NULL@, @FALSE@ otherwise. isNull :: Column (Nullable a) -> Column T.PGBool isNull = C.unOp HPQ.OpIsNull @@ -24,7 +30,7 @@ -- otherwise map the underlying @Column a@ using the provided -- function. -- --- The Opaleye equivalent of the 'Data.Maybe.maybe' function. +-- The Opaleye equivalent of 'Data.Maybe.maybe'. matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a) -> Column b matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement @@ -33,11 +39,13 @@ -- | If the @Column (Nullable a)@ is NULL then return the provided -- @Column a@ otherwise return the underlying @Column a@. -- --- The Opaleye equivalent of the 'Data.Maybe.fromMaybe' function +-- The Opaleye equivalent of 'Data.Maybe.fromMaybe'. fromNullable :: Column a -> Column (Nullable a) -> Column a fromNullable = flip matchNullable id --- | The Opaleye equivalent of 'Data.Maybe.Just' +-- | Treat a column as though it were nullable. This is always safe. +-- +-- The Opaleye equivalent of 'Data.Maybe.Just'. toNullable :: Column a -> Column (Nullable a) toNullable = unsafeCoerceColumn diff --git a/src/Opaleye/Constant.hs b/src/Opaleye/Constant.hs --- a/src/Opaleye/Constant.hs +++ b/src/Opaleye/Constant.hs @@ -24,13 +24,32 @@ import Control.Applicative (Applicative, pure, (<*>)) import Data.Functor ((<$>)) - -newtype Constant haskells columns = - Constant { constantExplicit :: haskells -> columns } - +-- | 'constant' provides a convenient typeclass wrapper around the +-- 'Column' creation functions in "Opaleye.PGTypes". Besides +-- convenience it doesn't provide any additional functionality. +-- +-- It can be used with functions like 'Opaleye.Manipulation.runInsert' +-- to insert custom Haskell types into the database. +-- The following is an example of a function for inserting custom types. +-- +-- @ +-- customInsert +-- :: ( 'D.Default' 'Constant' haskells columns ) +-- => Connection +-- -> 'Opaleye.Table' columns columns' +-- -> haskells +-- -> IO Int64 +-- customInsert conn table haskells = 'Opaleye.Manipulation.runInsert' conn table $ 'constant' haskells +-- @ +-- +-- In order to use this function with your custom types, you need to define an +-- instance of 'D.Default' 'Constant' for your custom types. constant :: D.Default Constant haskells columns => haskells -> columns constant = constantExplicit D.def + +newtype Constant haskells columns = + Constant { constantExplicit :: haskells -> columns } instance D.Default Constant haskell (Column sql) => D.Default Constant (Maybe haskell) (Column (C.Nullable sql)) where diff --git a/src/Opaleye/Distinct.hs b/src/Opaleye/Distinct.hs --- a/src/Opaleye/Distinct.hs +++ b/src/Opaleye/Distinct.hs @@ -8,7 +8,7 @@ import qualified Data.Profunctor.Product.Default as D --- | Remove duplicate items from the query result. +-- | Remove duplicate rows from the 'Query'. -- -- Example type specialization: -- @@ -22,7 +22,7 @@ -- distinct :: Query (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) -- @ -- --- By design there is no distinct function of type @QueryArr a b -> +-- By design there is no @distinct@ function of type @QueryArr a b -> -- QueryArr a b@. Such a function would allow violation of SQL's -- scoping rules and lead to invalid queries. distinct :: D.Default Distinctspec columns columns => 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 @@ -4,10 +4,10 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ --- | Numeric 'Column' types are instances of 'Num', so you can use --- '*', '/', '+', '-' on them. newtype Column a = Column HPQ.PrimExpr deriving Show +-- | Only used within a 'Column', to indicate that it can take null +-- values. data Nullable a = Nullable unColumn :: Column a -> HPQ.PrimExpr @@ -17,10 +17,15 @@ unsafeCoerce :: Column a -> Column b unsafeCoerce = unsafeCoerceColumn +-- | Treat a 'Column' as though it were of a different type. If such +-- a treatment is not valid then Postgres may fail with an error at +-- SQL run time. unsafeCoerceColumn :: Column a -> Column b unsafeCoerceColumn (Column e) = Column e --- | Cast a column to any other type. This is safe for some conversions such as uuid to text. +-- | Cast a column to any other type. Implements Postgres's @::@ or +-- @CAST( ... AS ... )@ operations. This is safe for some +-- conversions, such as uuid to text. unsafeCast :: String -> Column a -> Column b unsafeCast = mapColumn . HPQ.CastExpr where @@ -46,19 +51,19 @@ unsafeIfThenElse cond t f = unsafeCase_ [(cond, t)] f unsafeGt :: Column a -> Column a -> Column pgBool -unsafeGt = binOp HPQ.OpGt +unsafeGt = binOp (HPQ.:>) unsafeEq :: Column a -> Column a -> Column pgBool -unsafeEq = binOp HPQ.OpEq +unsafeEq = binOp (HPQ.:==) class PGNum a where pgFromInteger :: Integer -> Column a instance PGNum a => Num (Column a) where fromInteger = pgFromInteger - (*) = binOp HPQ.OpMul - (+) = binOp HPQ.OpPlus - (-) = binOp HPQ.OpMinus + (*) = binOp (HPQ.:*) + (+) = binOp (HPQ.:+) + (-) = binOp (HPQ.:-) abs = unOp HPQ.OpAbs negate = unOp HPQ.OpNegate @@ -72,8 +77,9 @@ instance (PGNum a, PGFractional a) => Fractional (Column a) where fromRational = pgFromRational - (/) = binOp HPQ.OpDiv + (/) = binOp (HPQ.:/) +-- | A dummy typeclass whose instances support integral operations. class PGIntegral a class PGString a where 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 @@ -45,15 +45,18 @@ | OtherLit String -- ^ used for hacking in custom SQL deriving (Read,Show) -data BinOp = OpEq | OpLt | OpLtEq | OpGt | OpGtEq | OpNotEq +data BinOp = (:==) | (:<) | (:<=) | (:>) | (:>=) | (:<>) | OpAnd | OpOr | OpLike | OpIn | OpOther String - | OpCat - | OpPlus | OpMinus | OpMul | OpDiv | OpMod - | OpBitNot | OpBitAnd | OpBitOr | OpBitXor - | OpAsg | OpAtTimeZone + | (:||) + | (:+) | (:-) | (:*) | (:/) | OpMod + | (:~) | (:&) | (:|) | (:^) + | (:=) | OpAtTimeZone + + | (:->) | (:->>) | (:#>) | (:#>>) + | (:@>) | (:<@) | (:?) | (:?|) | (:?&) deriving (Show,Read) data UnOp = OpNot 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 @@ -40,7 +40,7 @@ | FunSqlExpr String [SqlExpr] | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] -- ^ Aggregate functions separate from normal functions. | ConstSqlExpr String - | CaseSqlExpr [(SqlExpr,SqlExpr)] SqlExpr + | CaseSqlExpr (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr | ListSqlExpr [SqlExpr] | ParamSqlExpr (Maybe SqlName) SqlExpr | PlaceHolderSqlExpr 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 @@ -130,7 +130,9 @@ ConstExpr l -> ConstSqlExpr (sqlLiteral gen l) CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] e' = sqlExpr gen e - in CaseSqlExpr cs' e' + in case NEL.nonEmpty cs' of + Just nel -> CaseSqlExpr nel e' + Nothing -> e' ListExpr es -> ListSqlExpr (map (sqlExpr gen) es) ParamExpr n _ -> ParamSqlExpr n PlaceHolderSqlExpr FunExpr n exprs -> FunSqlExpr n (map (sqlExpr gen) exprs) @@ -139,29 +141,38 @@ ArrayExpr es -> ArraySqlExpr (map (sqlExpr gen) es) showBinOp :: BinOp -> String -showBinOp OpEq = "=" -showBinOp OpLt = "<" -showBinOp OpLtEq = "<=" -showBinOp OpGt = ">" -showBinOp OpGtEq = ">=" -showBinOp OpNotEq = "<>" +showBinOp (:==) = "=" +showBinOp (:<) = "<" +showBinOp (:<=) = "<=" +showBinOp (:>) = ">" +showBinOp (:>=) = ">=" +showBinOp (:<>) = "<>" 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 (:||) = "||" +showBinOp (:+) = "+" +showBinOp (:-) = "-" +showBinOp (:*) = "*" +showBinOp (:/) = "/" showBinOp OpMod = "MOD" -showBinOp OpBitNot = "~" -showBinOp OpBitAnd = "&" -showBinOp OpBitOr = "|" -showBinOp OpBitXor = "^" -showBinOp OpAsg = "=" +showBinOp (:~) = "~" +showBinOp (:&) = "&" +showBinOp (:|) = "|" +showBinOp (:^) = "^" +showBinOp (:=) = "=" showBinOp OpAtTimeZone = "AT TIME ZONE" +showBinOp (:->) = "->" +showBinOp (:->>) = "->>" +showBinOp (:#>) = "#>" +showBinOp (:#>>) = "#>>" +showBinOp (:@>) = "@>" +showBinOp (:<@) = "<@" +showBinOp (:?) = "?" +showBinOp (:?|) = "?|" +showBinOp (:?&) = "?&" data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix 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 @@ -27,6 +27,7 @@ import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, doubleQuotes, empty, equals, hcat, hsep, parens, punctuate, text, vcat, brackets) +import Data.Foldable (toList) -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first -- column. We need an identity function, but due to @@ -125,7 +126,7 @@ FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es) AggrFunSqlExpr f es ord -> text f <> parens (commaH ppSqlExpr es <+> ppOrderBy ord) ConstSqlExpr c -> text c - CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs) + CaseSqlExpr cs el -> text "CASE" <+> vcat (toList (fmap ppWhen cs)) <+> text "ELSE" <+> ppSqlExpr el <+> text "END" where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w <+> text "THEN" <+> ppSqlExpr t 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 @@ -3,8 +3,10 @@ module Opaleye.Internal.Join where import qualified Opaleye.Internal.Tag as T -import qualified Opaleye.Internal.PackMap as PM -import Opaleye.Internal.Column (Column, Nullable) +import Opaleye.Internal.Column (Column(Column), Nullable) +import qualified Opaleye.Internal.QueryArr as Q +import qualified Opaleye.Internal.PrimQuery as PQ +import qualified Opaleye.PGTypes as T import qualified Opaleye.Column as C import qualified Control.Applicative as A @@ -13,22 +15,35 @@ import qualified Data.Profunctor.Product as PP import qualified Data.Profunctor.Product.Default as D -import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ - newtype NullMaker a b = NullMaker (a -> b) toNullable :: NullMaker a b -> a -> b toNullable (NullMaker f) = f -extractLeftJoinFields :: Int -> T.Tag -> HPQ.PrimExpr - -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr -extractLeftJoinFields n = PM.extractAttr ("result" ++ show n ++ "_") - instance D.Default NullMaker (Column a) (Column (Nullable a)) where def = NullMaker C.unsafeCoerceColumn instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where def = NullMaker C.unsafeCoerceColumn + +joinExplicit :: (columnsA -> returnedColumnsA) + -> (columnsB -> returnedColumnsB) + -> PQ.JoinType + -> Q.Query columnsA -> Q.Query columnsB + -> ((columnsA, columnsB) -> Column T.PGBool) + -> Q.Query (returnedColumnsA, returnedColumnsB) +joinExplicit returnColumnsA returnColumnsB joinType + qA qB cond = Q.simpleQueryArr q where + q ((), startTag) = ((nullableColumnsA, nullableColumnsB), primQueryR, T.next endTag) + where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag) + (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag) + + nullableColumnsA = returnColumnsA columnsA + nullableColumnsB = returnColumnsB columnsB + + Column cond' = cond (columnsA, columnsB) + primQueryR = PQ.Join joinType cond' primQueryA primQueryB + -- { Boilerplate instances diff --git a/src/Opaleye/Internal/Operators.hs b/src/Opaleye/Internal/Operators.hs --- a/src/Opaleye/Internal/Operators.hs +++ b/src/Opaleye/Internal/Operators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,10 +6,15 @@ import Opaleye.Internal.Column (Column) import qualified Opaleye.Internal.Column as C +import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Opaleye.Internal.QueryArr as QA +import qualified Opaleye.Internal.TableMaker as TM +import qualified Opaleye.Internal.Table as Table +import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.PGTypes as T -import Data.Profunctor (Profunctor, dimap) +import Data.Profunctor (Profunctor, dimap, lmap, rmap) import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) import qualified Data.Profunctor.Product.Default as D @@ -18,9 +24,12 @@ (.==) = eqExplicit (D.def :: EqPP columns columns) infixr 3 .&& + +-- | Boolean and (.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool (.&&) = C.binOp HPQ.OpAnd +-- Probably should be newtype data EqPP a b = EqPP (a -> a -> Column T.PGBool) eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool @@ -29,6 +38,45 @@ instance D.Default EqPP (Column a) (Column a) where def = EqPP C.unsafeEq + +-- This seems to be the only place we use ViewColumnMaker now. +data RelExprMaker a b = + forall c. RelExprMaker { + relExprVCM :: TM.ViewColumnMaker a c + , relExprCM :: TM.ColumnMaker c b + } + +relExprColumn :: RelExprMaker String (Column a) +relExprColumn = RelExprMaker TM.tableColumn TM.column + +instance D.Default RelExprMaker String (Column a) where + def = relExprColumn + +runRelExprMaker :: RelExprMaker strings columns + -> Tag.Tag + -> strings + -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)]) +runRelExprMaker rem_ tag = + case rem_ of RelExprMaker vcm cm -> Table.runColumnMaker cm tag + . TM.runViewColumnMaker vcm + +relationValuedExprExplicit :: RelExprMaker strings columns + -> strings + -> (a -> HPQ.PrimExpr) + -> QA.QueryArr a columns +relationValuedExprExplicit rem_ strings pe = + QA.simpleQueryArr $ \(a, tag) -> + let (primExprs, projcols) = runRelExprMaker rem_ tag strings + primQ :: PQ.PrimQuery + primQ = PQ.RelExpr (pe a) projcols + in (primExprs, primQ, Tag.next tag) + +relationValuedExpr :: D.Default RelExprMaker strings columns + => strings + -> (a -> HPQ.PrimExpr) + -> QA.QueryArr a columns +relationValuedExpr = relationValuedExprExplicit D.def + -- { Boilerplate instances instance Profunctor EqPP where @@ -39,4 +87,14 @@ EqPP f ***! EqPP f' = EqPP (\a a' -> f (fst a) (fst a') .&& f' (snd a) (snd a')) +instance Profunctor RelExprMaker where + dimap f g (RelExprMaker a b) = RelExprMaker (lmap f a) (rmap g b) + +instance ProductProfunctor RelExprMaker where + empty = RelExprMaker empty empty + f ***! g = case f of RelExprMaker vcmf cmf -> + case g of RelExprMaker vcmg cmg -> + h vcmf vcmg cmf cmg + where h vcmg vcmf cmg cmf = RelExprMaker (vcmg ***! vcmf) + (cmg ***! cmf) -- } diff --git a/src/Opaleye/Internal/Optimize.hs b/src/Opaleye/Internal/Optimize.hs --- a/src/Opaleye/Internal/Optimize.hs +++ b/src/Opaleye/Internal/Optimize.hs @@ -55,6 +55,7 @@ PQ.UnionAll -> binary Just Just PQ.UnionAll PQ.IntersectAll -> binary (const Nothing) (const Nothing) PQ.IntersectAll , PQ.label = fmap . PQ.Label + , PQ.relExpr = return .: PQ.RelExpr } where -- If only the first argument is Just, do n1 on it -- If only the second argument is Just, do n2 on it 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 @@ -16,8 +16,8 @@ {-| An `Order` represents an expression to order on and a sort direction. Multiple `Order`s can be composed with -`Data.Monoid.mappend`. If two rows are equal according to the first -`Order`, the second is used, and so on. +`Data.Monoid.mappend` or @(\<\>)@ from "Data.Monoid". If two rows are +equal according to the first `Order`, the second is used, and so on. -} -- Like the (columns -> RowParser haskells) field of QueryRunner this 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 @@ -18,7 +18,7 @@ | IntersectAll deriving Show -data JoinType = LeftJoin deriving Show +data JoinType = LeftJoin | RightJoin | FullJoin deriving Show data TableIdentifier = TableIdentifier { tiSchemaName :: Maybe String @@ -55,6 +55,7 @@ [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] (PrimQuery' a, PrimQuery' a) | Label String (PrimQuery' a) + | RelExpr HPQ.PrimExpr [(Symbol, HPQ.PrimExpr)] deriving Show type PrimQuery = PrimQuery' () @@ -72,6 +73,8 @@ , values :: [Symbol] -> (NEL.NonEmpty [HPQ.PrimExpr]) -> p , binary :: BinOp -> [(Symbol, (HPQ.PrimExpr, HPQ.PrimExpr))] -> (p, p) -> p , label :: String -> p -> p + , relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> p + -- ^ A relation-valued expression } @@ -87,7 +90,9 @@ , join = Join , values = Values , binary = Binary - , label = Label } + , label = Label + , relExpr = RelExpr + } foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p foldPrimQuery f = fix fold @@ -103,6 +108,7 @@ Values ss pes -> values f ss pes Binary binop pes (q1, q2) -> binary f binop pes (self q1, self q2) Label l pq -> label f l (self pq) + RelExpr pe syms -> relExpr f pe syms fix g = let x = g x in x times :: PrimQuery -> PrimQuery -> PrimQuery 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 @@ -3,7 +3,9 @@ import Prelude hiding (product) import qualified Opaleye.Internal.Sql as Sql -import Opaleye.Internal.Sql (Select(SelectFrom, Table, +import Opaleye.Internal.Sql (Select(SelectFrom, + Table, + RelExpr, SelectJoin, SelectValues, SelectBinary, @@ -72,6 +74,8 @@ ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" +ppJoinType Sql.RightJoin = text "RIGHT OUTER JOIN" +ppJoinType Sql.FullJoin = text "FULL OUTER JOIN" ppAttrs :: Sql.SelectAttrs -> Doc ppAttrs Sql.Star = text "*" @@ -93,6 +97,7 @@ ppTable :: (TableAlias, Select) -> Doc ppTable (alias, select) = HPrint.ppAs (Just alias) $ case select of Table table -> HPrint.ppTable table + RelExpr expr -> HPrint.ppSqlExpr expr SelectFrom selectFrom -> parens (ppSelectFrom selectFrom) SelectJoin slj -> parens (ppSelectJoin slj) SelectValues slv -> parens (ppSelectValues slv) 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 @@ -20,7 +20,10 @@ -- | @QueryArr a b@ is analogous to a Haskell function @a -> [b]@. newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)) --- | @Query a@ is analogous to a Haskell value @[a]@. +-- | A Postgres query, i.e. some functionality that can run via SQL +-- and produce a collection of rows. +-- +-- @Query a@ is analogous to a Haskell value @[a]@. type Query = QueryArr () simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b 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 @@ -55,7 +55,7 @@ -- | 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 +-- 'T.PGText' 'String' encodes how to turn a 'T.PGText' result from the -- database into a Haskell 'String'. -- This is *not* a Product Profunctor because it is the only way I @@ -84,10 +84,10 @@ -- 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 :: FromField haskell => QueryRunnerColumn pgType haskell fieldQueryRunnerColumn = fieldParserQueryRunnerColumn fromField -fieldParserQueryRunnerColumn :: FieldParser haskell -> QueryRunnerColumn coltype haskell +fieldParserQueryRunnerColumn :: FieldParser haskell -> QueryRunnerColumn pgType haskell fieldParserQueryRunnerColumn = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b @@ -120,7 +120,25 @@ -- | A 'QueryRunnerColumnDefault' @pgType@ @haskellType@ represents -- the default way to turn a @pgType@ result from the database into a --- Haskell value of type @haskelType@. +-- Haskell value of type @haskellType@. +-- +-- Creating an instance of 'QueryRunnerColumnDefault' for your own types is +-- necessary for retrieving those types from the database. +-- +-- You should use one of the three methods below for writing a +-- 'QueryRunnerColumnDefault' instance. +-- +-- 1. If you already have a 'FromField' instance for your @haskellType@, use +-- 'fieldQueryRunnerColumn'. (This is how most of the built-in instances are +-- defined.) +-- +-- 2. If you don't have a 'FromField' instance, use +-- 'Opaleye.RunQuery.queryRunnerColumn' if possible. See the documentation for +-- 'Opaleye.RunQuery.queryRunnerColumn' for an example. +-- +-- 3. If you have a more complicated case, but not a 'FromField' instance, +-- write a 'FieldParser' for your type and use 'fieldParserQueryRunnerColumn'. +-- You can also add a 'FromField' instance using this. class QueryRunnerColumnDefault pgType haskellType where queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType 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 @@ -20,6 +20,8 @@ data Select = SelectFrom From | Table HSql.SqlTable + | RelExpr HSql.SqlExpr + -- ^ A relation-valued expression | SelectJoin Join | SelectValues Values | SelectBinary Binary @@ -60,7 +62,7 @@ bSelect2 :: Select } deriving Show -data JoinType = LeftJoin deriving Show +data JoinType = LeftJoin | RightJoin | FullJoin deriving Show data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show data Label = Label { @@ -82,7 +84,9 @@ , PQ.join = join , PQ.values = values , PQ.binary = binary - , PQ.label = label } + , PQ.label = label + , PQ.relExpr = relExpr + } sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes)) @@ -180,6 +184,8 @@ joinType :: PQ.JoinType -> JoinType joinType PQ.LeftJoin = LeftJoin +joinType PQ.RightJoin = RightJoin +joinType PQ.FullJoin = FullJoin binOp :: PQ.BinOp -> BinOp binOp o = case o of @@ -221,3 +227,10 @@ label :: String -> Select -> Select label l s = SelectLabel (Label l s) + +-- Very similar to 'baseTable' +relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> Select +relExpr pe columns = SelectFrom $ + newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns)) + , tables = [RelExpr (sqlExpr pe)] + } 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 @@ -47,9 +47,9 @@ -- @ data Table writerColumns viewColumns = Table String (TableProperties writerColumns viewColumns) - -- ^ Uses the default schema name (@"public"@). + -- ^ Uses the default schema name (@\"public\"@). | TableWithSchema String String (TableProperties writerColumns viewColumns) - -- ^ Schema name (@"public"@ by default in PostgreSQL), table name, + -- ^ Schema name (@\"public\"@ by default in PostgreSQL), table name, -- table properties. tableIdentifier :: Table writerColumns viewColumns -> PQ.TableIdentifier diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs --- a/src/Opaleye/Join.hs +++ b/src/Opaleye/Join.hs @@ -1,39 +1,60 @@ +-- | Left, right, and full outer joins. If you want inner joins, just use 'restrict' instead. +-- +-- The 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 the join functions. +-- +-- Example specialization: +-- +-- @ +-- leftJoin :: Query (Column a, Column b) +-- -> Query (Column c, Column (Nullable d)) +-- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.PGTypes.PGBool') +-- -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) +-- @ + {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} module Opaleye.Join where import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Join as J -import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PrimQuery as PQ import Opaleye.QueryArr (Query) -import qualified Opaleye.Internal.QueryArr as Q -import Opaleye.Internal.Column (Column(Column)) +import Opaleye.Internal.Column (Column) import qualified Opaleye.PGTypes as T import qualified Data.Profunctor.Product.Default as D --- | @leftJoin@'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 --- @leftJoin@. --- --- Example specialization: --- --- @ --- leftJoin :: Query (Column a, Column b) --- -> Query (Column c, Column (Nullable d)) --- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.PGTypes.PGBool') --- -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) --- @ leftJoin :: (D.Default U.Unpackspec columnsA columnsA, D.Default U.Unpackspec columnsB columnsB, - D.Default J.NullMaker columnsB nullableColumnsB) => - Query columnsA -> Query columnsB - -> ((columnsA, columnsB) -> Column T.PGBool) - -> Query (columnsA, nullableColumnsB) + D.Default J.NullMaker columnsB nullableColumnsB) + => Query columnsA -- ^ Left query + -> Query columnsB -- ^ Right query + -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join + -> Query (columnsA, nullableColumnsB) -- ^ Left join leftJoin = leftJoinExplicit D.def D.def D.def +rightJoin :: (D.Default U.Unpackspec columnsA columnsA, + D.Default U.Unpackspec columnsB columnsB, + D.Default J.NullMaker columnsA nullableColumnsA) + => Query columnsA -- ^ Left query + -> Query columnsB -- ^ Right query + -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join + -> Query (nullableColumnsA, columnsB) -- ^ Right join +rightJoin = rightJoinExplicit D.def D.def D.def + + +fullJoin :: (D.Default U.Unpackspec columnsA columnsA, + D.Default U.Unpackspec columnsB columnsB, + D.Default J.NullMaker columnsA nullableColumnsA, + D.Default J.NullMaker columnsB nullableColumnsB) + => Query columnsA -- ^ Left query + -> Query columnsB -- ^ Right query + -> ((columnsA, columnsB) -> Column T.PGBool) -- ^ Condition on which to join + -> Query (nullableColumnsA, nullableColumnsB) -- ^ Full outer join +fullJoin = fullJoinExplicit D.def 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. @@ -43,12 +64,25 @@ -> Query columnsA -> Query columnsB -> ((columnsA, columnsB) -> Column T.PGBool) -> Query (columnsA, nullableColumnsB) -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) +leftJoinExplicit _ _ nullmaker = + J.joinExplicit id (J.toNullable nullmaker) PQ.LeftJoin - nullableColumnsB = J.toNullable nullmaker columnsB +rightJoinExplicit :: U.Unpackspec columnsA columnsA + -> U.Unpackspec columnsB columnsB + -> J.NullMaker columnsA nullableColumnsA + -> Query columnsA -> Query columnsB + -> ((columnsA, columnsB) -> Column T.PGBool) + -> Query (nullableColumnsA, columnsB) +rightJoinExplicit _ _ nullmaker = + J.joinExplicit (J.toNullable nullmaker) id PQ.RightJoin - Column cond' = cond (columnsA, columnsB) - primQueryR = PQ.Join PQ.LeftJoin cond' primQueryA primQueryB + +fullJoinExplicit :: U.Unpackspec columnsA columnsA + -> U.Unpackspec columnsB columnsB + -> J.NullMaker columnsA nullableColumnsA + -> J.NullMaker columnsB nullableColumnsB + -> Query columnsA -> Query columnsB + -> ((columnsA, columnsB) -> Column T.PGBool) + -> Query (nullableColumnsA, nullableColumnsB) +fullJoinExplicit _ _ nullmakerA nullmakerB = + J.joinExplicit (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin diff --git a/src/Opaleye/Label.hs b/src/Opaleye/Label.hs --- a/src/Opaleye/Label.hs +++ b/src/Opaleye/Label.hs @@ -4,8 +4,6 @@ import qualified Opaleye.Internal.Label as L import qualified Opaleye.Internal.QueryArr as Q -{- | -Add a label in comments to the given query. --} +-- | Add a commented label to the generated SQL. label :: String -> Query a -> Query a label l a = Q.simpleQueryArr (L.label' l . Q.runSimpleQueryArr a) diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -47,12 +47,6 @@ import qualified Data.List.NonEmpty as NEL -- | Returns the number of rows inserted --- --- This will be deprecated in a future release. Use 'runInsertMany' instead. -runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 -runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql - --- | Returns the number of rows inserted runInsertMany :: PGS.Connection -> T.Table columns columns' -> [columns] @@ -62,21 +56,6 @@ Nothing -> return 0 Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) table columns' --- | @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@. --- --- This will be deprecated in a future release. Use --- 'runInsertManyReturning' instead. -runInsertReturning :: (D.Default RQ.QueryRunner returned haskells) - => PGS.Connection - -> T.Table columnsW columnsR - -> columnsW - -> (columnsR -> returned) - -> IO [haskells] -runInsertReturning = runInsertReturningExplicit D.def - -- | @runInsertManyReturning@'s use of the 'D.Default' typeclass means that the -- compiler will have trouble inferring types. It is strongly -- recommended that you provide full type signatures when using @@ -166,6 +145,27 @@ where IRQ.QueryRunner u _ _ = qr parser = IRQ.prepareRowParser qr (r v) TI.Table _ (TI.TableProperties _ (TI.View v)) = t + +-- | Returns the number of rows inserted +-- +-- This will be deprecated in a future release. Use 'runInsertMany' instead. +runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 +runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql + +-- | @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@. +-- +-- This will be deprecated in a future release. Use +-- 'runInsertManyReturning' instead. +runInsertReturning :: (D.Default RQ.QueryRunner returned haskells) + => PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> returned) + -> IO [haskells] +runInsertReturning = runInsertReturningExplicit D.def -- | For internal use only. Do not use. Will be removed in a -- subsequent release. diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -1,8 +1,8 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} --- | Operators on 'Column's. Numeric 'Column' types are instances of --- 'Num', so you can use '*', '/', '+', '-' on them. +-- | Operators on 'Column's. Please note that numeric 'Column' types +-- are instances of 'Num', so you can use '*', '/', '+', '-' on them. module Opaleye.Operators (module Opaleye.Operators, (O..&&)) where @@ -38,22 +38,19 @@ {-| Filter a 'QueryArr' to only those rows where the given condition holds. This is the 'QueryArr' equivalent of 'Prelude.filter' from the 'Prelude'. You would typically use 'keepWhen' if you want to use a -"point free" style.-} +\"point free\" style.-} keepWhen :: (a -> Column T.PGBool) -> QueryArr a a keepWhen p = proc a -> do restrict -< p a A.returnA -< a -doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 -doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) - infix 4 .== (.==) :: Column a -> Column a -> Column T.PGBool -(.==) = C.binOp HPQ.OpEq +(.==) = C.binOp (HPQ.:==) infix 4 ./= (./=) :: Column a -> Column a -> Column T.PGBool -(./=) = C.binOp HPQ.OpNotEq +(./=) = C.binOp (HPQ.:<>) infix 4 .=== -- | A polymorphic equality operator that works for all types that you @@ -75,18 +72,18 @@ infix 4 .< (.<) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool -(.<) = C.binOp HPQ.OpLt +(.<) = C.binOp (HPQ.:<) infix 4 .<= (.<=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool -(.<=) = C.binOp HPQ.OpLtEq +(.<=) = C.binOp (HPQ.:<=) infix 4 .>= (.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool -(.>=) = C.binOp HPQ.OpGtEq +(.>=) = C.binOp (HPQ.:>=) quot_ :: C.PGIntegral a => Column a -> Column a -> Column a -quot_ = C.binOp HPQ.OpDiv +quot_ = C.binOp (HPQ.:/) rem_ :: C.PGIntegral a => Column a -> Column a -> Column a rem_ = C.binOp HPQ.OpMod @@ -98,21 +95,27 @@ ifThenElse = unsafeIfThenElse infixr 2 .|| + +-- | Boolean or (.||) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool (.||) = C.binOp HPQ.OpOr not :: Column T.PGBool -> Column T.PGBool not = C.unOp HPQ.OpNot +-- | Concatenate 'Column' 'T.PGText' (.++) :: Column T.PGText -> Column T.PGText -> Column T.PGText -(.++) = C.binOp HPQ.OpCat +(.++) = C.binOp (HPQ.:||) +-- | To lowercase lower :: Column T.PGText -> Column T.PGText lower = C.unOp HPQ.OpLower +-- | To uppercase upper :: Column T.PGText -> Column T.PGText upper = C.unOp HPQ.OpUpper +-- | Postgres @LIKE@ operator like :: Column T.PGText -> Column T.PGText -> Column T.PGBool like = C.binOp HPQ.OpLike @@ -123,6 +126,11 @@ ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool ors = F.foldl' (.||) (T.pgBool False) +-- | 'in_' is designed to be used in prefix form. +-- +-- 'in_' @validProducts@ @product@ checks whether @product@ is a valid +-- product. 'in_' @validProducts@ is a function which checks whether +-- a product is a valid product. in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool in_ hs w = ors . fmap (w .==) $ hs @@ -169,3 +177,83 @@ singletonArray :: T.IsSqlType a => Column a -> Column (T.PGArray a) singletonArray x = arrayPrepend x emptyArray + +-- | Class of Postgres types that represent json values. +-- +-- Used to overload functions and operators that work on both 'T.PGJson' and 'T.PGJsonb'. +-- +-- Warning: making additional instances of this class can lead to broken code! +class PGIsJson a + +instance PGIsJson T.PGJson +instance PGIsJson T.PGJsonb + +-- | Class of Postgres types that can be used to index json values. +-- +-- Warning: making additional instances of this class can lead to broken code! +class PGJsonIndex a + +instance PGJsonIndex T.PGInt4 +instance PGJsonIndex T.PGInt8 +instance PGJsonIndex T.PGText + +-- | Get JSON object field by key. +infixl 8 .-> +(.->) :: (PGIsJson a, PGJsonIndex k) + => Column (C.Nullable a) -- ^ + -> Column k -- ^ key or index + -> Column (C.Nullable a) +(.->) = C.binOp (HPQ.:->) + +-- | Get JSON object field as text. +infixl 8 .->> +(.->>) :: (PGIsJson a, PGJsonIndex k) + => Column (C.Nullable a) -- ^ + -> Column k -- ^ key or index + -> Column (C.Nullable T.PGText) +(.->>) = C.binOp (HPQ.:->>) + +-- | Get JSON object at specified path. +infixl 8 .#> +(.#>) :: (PGIsJson a) + => Column (C.Nullable a) -- ^ + -> Column (T.PGArray T.PGText) -- ^ path + -> Column (C.Nullable a) +(.#>) = C.binOp (HPQ.:#>) + +-- | Get JSON object at specified path as text. +infixl 8 .#>> +(.#>>) :: (PGIsJson a) + => Column (C.Nullable a) -- ^ + -> Column (T.PGArray T.PGText) -- ^ path + -> Column (C.Nullable T.PGText) +(.#>>) = C.binOp (HPQ.:#>>) + +-- | Does the left JSON value contain within it the right value? +infix 4 .@> +(.@>) :: Column T.PGJsonb -> Column T.PGJsonb -> Column T.PGBool +(.@>) = C.binOp (HPQ.:@>) + +-- | Is the left JSON value contained within the right value? +infix 4 .<@ +(.<@) :: Column T.PGJsonb -> Column T.PGJsonb -> Column T.PGBool +(.<@) = C.binOp (HPQ.:<@) + +-- | Does the key/element string exist within the JSON value? +infix 4 .? +(.?) :: Column T.PGJsonb -> Column T.PGText -> Column T.PGBool +(.?) = C.binOp (HPQ.:?) + +-- | Do any of these key/element strings exist? +infix 4 .?| +(.?|) :: Column T.PGJsonb -> Column (T.PGArray T.PGText) -> Column T.PGBool +(.?|) = C.binOp (HPQ.:?|) + +-- | Do all of these key/element strings exist? +infix 4 .?& +(.?&) :: Column T.PGJsonb -> Column (T.PGArray T.PGText) -> Column T.PGBool +(.?&) = C.binOp (HPQ.:?&) + +-- | Cast a 'PGInt4' to a 'PGFloat8' +doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 +doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs --- a/src/Opaleye/Order.hs +++ b/src/Opaleye/Order.hs @@ -1,3 +1,5 @@ +-- | Ordering, @LIMIT@ and @OFFSET@ + module Opaleye.Order (module Opaleye.Order, O.Order) where import qualified Opaleye.Column as C diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -1,3 +1,6 @@ +-- | Postgres types and functions to create 'Column's of those types. +-- You may find it more convenient to use "Opaleye.Constant" instead. + {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,25 +24,6 @@ import Data.Int (Int64) -data PGBool -data PGDate -data PGFloat4 -data PGFloat8 -data PGInt8 -data PGInt4 -data PGInt2 -data PGNumeric -data PGText -data PGTime -data PGTimestamp -data PGTimestamptz -data PGUuid -data PGCitext -data PGArray a -data PGBytea -data PGJson -data PGJsonb - instance C.PGNum PGFloat8 where pgFromInteger = pgDouble . fromInteger @@ -62,12 +46,6 @@ instance C.PGString PGCitext where pgFromString = pgCiLazyText . CI.mk . LText.pack -literalColumn :: HPQ.Literal -> Column a -literalColumn = IPT.literalColumn -{-# WARNING literalColumn - "'literalColumn' has been moved to Opaleye.Internal.PGTypes" - #-} - pgString :: String -> Column PGText pgString = IPT.literalColumn . HPQ.StringLit @@ -98,12 +76,6 @@ pgUUID :: UUID.UUID -> Column PGUuid pgUUID = C.unsafeCoerceColumn . pgString . UUID.toString -unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c -unsafePgFormatTime = IPT.unsafePgFormatTime -{-# WARNING unsafePgFormatTime - "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes" - #-} - pgDay :: Time.Day -> Column PGDate pgDay = IPT.unsafePgFormatTime "date" "'%F'" @@ -206,3 +178,34 @@ showPGType _ = "json" instance IsSqlType PGJsonb where showPGType _ = "jsonb" + +data PGBool +data PGDate +data PGFloat4 +data PGFloat8 +data PGInt8 +data PGInt4 +data PGInt2 +data PGNumeric +data PGText +data PGTime +data PGTimestamp +data PGTimestamptz +data PGUuid +data PGCitext +data PGArray a +data PGBytea +data PGJson +data PGJsonb + +literalColumn :: HPQ.Literal -> Column a +literalColumn = IPT.literalColumn +{-# WARNING literalColumn + "'literalColumn' has been moved to Opaleye.Internal.PGTypes and will be deprecated in a future release" + #-} + +unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c +unsafePgFormatTime = IPT.unsafePgFormatTime +{-# WARNING unsafePgFormatTime + "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes and will be deprecated in a future release" + #-} diff --git a/src/Opaleye/QueryArr.hs b/src/Opaleye/QueryArr.hs --- a/src/Opaleye/QueryArr.hs +++ b/src/Opaleye/QueryArr.hs @@ -1,9 +1,6 @@ -{-| - -This modules defines the 'QueryArr' arrow, which is an arrow that represents -selecting data from a database, and composing multiple queries together. +-- | 'Query' and 'QueryArr' are the composable units of database +-- querying that are used in Opaleye. --} -module Opaleye.QueryArr (QueryArr, Query) where +module Opaleye.QueryArr (Query, QueryArr) where import Opaleye.Internal.QueryArr (QueryArr, Query) diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -4,7 +4,8 @@ QueryRunner, IRQ.QueryRunnerColumn, IRQ.QueryRunnerColumnDefault (..), - IRQ.fieldQueryRunnerColumn) where + IRQ.fieldQueryRunnerColumn, + IRQ.fieldParserQueryRunnerColumn) where import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple.FromRow as FR @@ -46,13 +47,6 @@ -> IO [haskells] runQuery = runQueryExplicit D.def -runQueryExplicit :: QueryRunner columns haskells - -> PGS.Connection - -> Query columns - -> IO [haskells] -runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql - where (sql, parser) = prepareQuery qr q - -- | @runQueryFold@ streams the results of a query incrementally and consumes -- the results with a left fold. -- @@ -67,18 +61,6 @@ -> IO b runQueryFold = runQueryFoldExplicit D.def -runQueryFoldExplicit - :: QueryRunner columns haskells - -> PGS.Connection - -> Query columns - -> b - -> (b -> haskells -> IO b) - -> IO b -runQueryFoldExplicit qr conn q z f = case sql of - Nothing -> return z - Just sql' -> PGS.foldWith_ parser conn sql' z f - where (sql, parser) = prepareQuery qr q - -- | Use 'queryRunnerColumn' to make an instance to allow you to run queries on -- your own datatypes. For example: -- @@ -99,7 +81,26 @@ where IRQ.QueryRunnerColumn u fp = qrc fmapFP = fmap . fmap . fmap --- | For internal use only. Do not use. Will be removed in a +runQueryExplicit :: QueryRunner columns haskells + -> PGS.Connection + -> Query columns + -> IO [haskells] +runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql + where (sql, parser) = prepareQuery qr q + +runQueryFoldExplicit + :: QueryRunner columns haskells + -> PGS.Connection + -> Query columns + -> b + -> (b -> haskells -> IO b) + -> IO b +runQueryFoldExplicit qr conn q z f = case sql of + Nothing -> return z + Just sql' -> PGS.foldWith_ parser conn sql' z f + where (sql, parser) = prepareQuery qr q + +-- | For internal use only. Do not use. Will be deprecated in a -- subsequent release. prepareQuery :: QueryRunner columns haskells -> Query columns -> (Maybe PGS.Query, FR.RowParser haskells) prepareQuery qr@(QueryRunner u _ _) q = (sql, parser) diff --git a/src/Opaleye/Sql.hs b/src/Opaleye/Sql.hs --- a/src/Opaleye/Sql.hs +++ b/src/Opaleye/Sql.hs @@ -15,7 +15,7 @@ import qualified Data.Profunctor.Product.Default as D --- | When 'Nothing' is returned it means that the query has no results. +-- | When 'Nothing' is returned it means that the 'Query' returns zero rows. -- -- Example type specialization: -- @@ -45,6 +45,7 @@ showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String showSqlForPostgresUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack +-- | For internal use only. Do not use. Will be deprecated in a future release. formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery' a, T.Tag) -> Maybe String formatAndShowSQL = fmap (show . Pr.ppSql . Sql.sql) . traverse2Of3 Op.removeEmpty where -- Just a lens diff --git a/src/Opaleye/Values.hs b/src/Opaleye/Values.hs --- a/src/Opaleye/Values.hs +++ b/src/Opaleye/Values.hs @@ -9,7 +9,10 @@ import Data.Profunctor.Product.Default (Default, def) --- | Example type specialization: +-- | 'values' implements Postgres's @VALUES@ construct and allows you +-- to create a query that consists of the given rows. +-- +-- Example type specialization: -- -- @ -- values :: [(Column a, Column b)] -> Query (Column a, Column b)