summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomjaguarpaw <>2020-08-01 12:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-01 12:07:00 (GMT)
commit7091ea8be607644dd02caae4365fb5a9ede5b839 (patch)
treee88ba8bb6fcf6c611856df38b22430ff03fc8d99
parent24f39f3642b59ec285e7e9d80d1ff21cf8db61d7 (diff)
version 0.6.7005.00.6.7005.0
-rw-r--r--CHANGELOG.md43
-rw-r--r--Doc/Tutorial/TutorialAdvanced.lhs2
-rw-r--r--Doc/Tutorial/TutorialBasic.lhs4
-rw-r--r--Doc/Tutorial/TutorialBasicMonomorphic.lhs4
-rw-r--r--Doc/Tutorial/TutorialBasicTypeFamilies.lhs8
-rw-r--r--Doc/Tutorial/TutorialManipulation.lhs4
-rw-r--r--Test/Connection.hs44
-rw-r--r--Test/Opaleye/Test/Arbitrary.hs464
-rw-r--r--Test/Opaleye/Test/Fields.hs199
-rw-r--r--Test/QuickCheck.hs708
-rw-r--r--Test/Test.hs739
-rw-r--r--Test/TypeFamilies.hs2
-rw-r--r--Test/Wrapped.hs87
-rw-r--r--opaleye.cabal22
-rw-r--r--src/Opaleye.hs12
-rw-r--r--src/Opaleye/Adaptors.hs84
-rw-r--r--src/Opaleye/Aggregate.hs16
-rw-r--r--src/Opaleye/Binary.hs27
-rw-r--r--src/Opaleye/Column.hs7
-rw-r--r--src/Opaleye/Distinct.hs19
-rw-r--r--src/Opaleye/Field.hs3
-rw-r--r--src/Opaleye/FunctionalJoin.hs8
-rw-r--r--src/Opaleye/Internal/Aggregate.hs74
-rw-r--r--src/Opaleye/Internal/Binary.hs13
-rw-r--r--src/Opaleye/Internal/Distinct.hs21
-rw-r--r--src/Opaleye/Internal/HaskellDB/Sql/Default.hs6
-rw-r--r--src/Opaleye/Internal/Join.hs45
-rw-r--r--src/Opaleye/Internal/Lateral.hs27
-rw-r--r--src/Opaleye/Internal/Manipulation.hs4
-rw-r--r--src/Opaleye/Internal/MaybeFields.hs316
-rw-r--r--src/Opaleye/Internal/Operators.hs27
-rw-r--r--src/Opaleye/Internal/Optimize.hs24
-rw-r--r--src/Opaleye/Internal/PackMap.hs21
-rw-r--r--src/Opaleye/Internal/PrimQuery.hs65
-rw-r--r--src/Opaleye/Internal/Print.hs17
-rw-r--r--src/Opaleye/Internal/QueryArr.hs62
-rw-r--r--src/Opaleye/Internal/RunQuery.hs23
-rw-r--r--src/Opaleye/Internal/Sql.hs98
-rw-r--r--src/Opaleye/Internal/Table.hs80
-rw-r--r--src/Opaleye/Internal/TableMaker.hs6
-rw-r--r--src/Opaleye/Internal/Unpackspec.hs13
-rw-r--r--src/Opaleye/Internal/Values.hs136
-rw-r--r--src/Opaleye/Join.hs187
-rw-r--r--src/Opaleye/Label.hs4
-rw-r--r--src/Opaleye/Lateral.hs9
-rw-r--r--src/Opaleye/Manipulation.hs11
-rw-r--r--src/Opaleye/Map.hs2
-rw-r--r--src/Opaleye/MaybeFields.hs73
-rw-r--r--src/Opaleye/Operators.hs20
-rw-r--r--src/Opaleye/Order.hs24
-rw-r--r--src/Opaleye/PGTypes.hs13
-rw-r--r--src/Opaleye/RunSelect.hs12
-rw-r--r--src/Opaleye/Select.hs16
-rw-r--r--src/Opaleye/Sql.hs6
-rw-r--r--src/Opaleye/SqlTypes.hs2
-rw-r--r--src/Opaleye/Table.hs14
-rw-r--r--src/Opaleye/Values.hs67
57 files changed, 3099 insertions, 945 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6b55d2b..b4decd2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,47 @@
+## 0.6.7005.0
+
+* Add a `Monad` instance for `Select` (and `SelectArr i`).
+
+* Add `Opaleye.Lateral`, to support LATERAL subqueries.
+
+* Add `Opaleye.Join.optionalRestrict` and `Opaleye.Join.optional`, as
+ more convenient and composable ways of doing left/right joins.
+
+* Add `Opaleye.MaybeFields`
+
+* Add `optionalTableField`, `readOnlyTableField`,
+ `requiredTableField`, to replace `optional`, `readOnly` and
+ `required` in a later version.
+
+* Add `valuesSafe`, a version of `values`. `values` of an empty list
+ generates incorrect queries when mixed with @OUTER@/@LEFT@/@RIGHT
+ JOIN@s. `valuesSafe` will replace it in version 0.7
+
+* Add `Opaleye.Adaptors` as the forward-compatible place to import
+ `Unpackspec` and `unpackspecField` from, as well as other adaptors.
+
+* Unicode characters are escaped properly in `sqlString`/`toFields`
+
+* Add `inSelect`, to replace `inQuery` in a future version.
+
+* Add `unsafeCoerceField`, to replace `unsafeCoerceColumn` in a future
+ version.
+
+* Generalise label to type `label :: String -> S.SelectArr a b ->
+S.SelectArr a b`
+
+* [Fix invalid queries
+ bug](https://github.com/tomjaguarpaw/haskell-opaleye/pull/468) in
+ `union`, `unionAll`, `except` and `exceptAll` where one side was
+ empty.
+
+## 0.6.7004.2
+
+* No user-visible changes
+
## 0.6.7004.1
-* Fixed quadratic slowdown in `removeEmpty`.
+* Fixed exponential slowdown in `removeEmpty`.
* Fixed `read` compatibility with time-1.9 in test suite.
diff --git a/Doc/Tutorial/TutorialAdvanced.lhs b/Doc/Tutorial/TutorialAdvanced.lhs
index 3211466..9c8579d 100644
--- a/Doc/Tutorial/TutorialAdvanced.lhs
+++ b/Doc/Tutorial/TutorialAdvanced.lhs
@@ -72,4 +72,4 @@ Helper function
===============
> printSql :: Default U.Unpackspec a a => Select a -> IO ()
-> printSql = putStrLn . maybe "Empty query" id . Sql.showSqlForPostgres
+> printSql = putStrLn . maybe "Empty query" id . Sql.showSql
diff --git a/Doc/Tutorial/TutorialBasic.lhs b/Doc/Tutorial/TutorialBasic.lhs
index 8815d73..0d53bc1 100644
--- a/Doc/Tutorial/TutorialBasic.lhs
+++ b/Doc/Tutorial/TutorialBasic.lhs
@@ -14,7 +14,7 @@
> (.===),
> (.++), ifThenElse, sqlString, aggregate, groupBy,
> count, avg, sum, leftJoin, runSelect,
-> showSqlForPostgres, Unpackspec,
+> showSql, Unpackspec,
> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8, SqlBool)
>
> import Data.Profunctor.Product (p2, p3)
@@ -857,4 +857,4 @@ Utilities
This is a little utility function to help with printing generated SQL.
> printSql :: Default Unpackspec a a => Select a -> IO ()
-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres
+> printSql = putStrLn . maybe "Empty query" id . showSql
diff --git a/Doc/Tutorial/TutorialBasicMonomorphic.lhs b/Doc/Tutorial/TutorialBasicMonomorphic.lhs
index 962a112..13cb0bf 100644
--- a/Doc/Tutorial/TutorialBasicMonomorphic.lhs
+++ b/Doc/Tutorial/TutorialBasicMonomorphic.lhs
@@ -12,7 +12,7 @@
> Select, (.==),
> aggregate, groupBy,
> count, avg, sum, leftJoin, runSelect,
-> showSqlForPostgres, Unpackspec,
+> showSql, Unpackspec,
> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8)
>
> import qualified Opaleye as O
@@ -405,4 +405,4 @@ Utilities
This is a little utility function to help with printing generated SQL.
> printSql :: Default Unpackspec a a => Select a -> IO ()
-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres
+> printSql = putStrLn . maybe "Empty query" id . showSql
diff --git a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs
index bf302c9..2a25d68 100644
--- a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs
+++ b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs
@@ -18,7 +18,7 @@
> Table, table, tableField, selectTable,
> Select, (.==), aggregate, groupBy,
> count, avg, sum, leftJoin, runSelect, runSelectTF,
-> showSqlForPostgres, Unpackspec,
+> showSql, Unpackspec,
> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8)
>
> import qualified Opaleye as O
@@ -354,9 +354,9 @@ Types of joins are inferrable in new versions of Opaleye. Here is a
> O.fullJoinInferrable (O.fullJoinInferrable
> birthdaySelect
> (selectTable widgetTable)
-> (const (O.pgBool True)))
+> (const (O.sqlBool True)))
> birthdaySelect
-> (const (O.pgBool True))
+> (const (O.sqlBool True))
Running queries on Postgres
===========================
@@ -396,4 +396,4 @@ Utilities
This is a little utility function to help with printing generated SQL.
> printSql :: Default Unpackspec a a => Select a -> IO ()
-> printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres
+> printSql = putStrLn . maybe "Empty query" id . showSql
diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs
index e04df39..8445e99 100644
--- a/Doc/Tutorial/TutorialManipulation.lhs
+++ b/Doc/Tutorial/TutorialManipulation.lhs
@@ -50,7 +50,7 @@ To perform a delete we provide an expression from our read type to
> delete :: Delete Int64
> delete = Delete
> { dTable = myTable
-> , dWhere = (\(_, x, y, _) -> x .< y)
+> , dWhere = \(_, x, y, _) -> x .< y
> , dReturning = rCount
> }
@@ -133,7 +133,7 @@ according to the update function.
> update = Update
> { uTable = myTable
> , uUpdateWith = updateEasy (\(id_, x, y, s) -> (id_, x + y, x - y, s))
-> , uWhere = (\(id_, _, _, _) -> id_ .== 5)
+> , uWhere = \(id_, _, _, _) -> id_ .== 5
> , uReturning = rCount
> }
diff --git a/Test/Connection.hs b/Test/Connection.hs
new file mode 100644
index 0000000..ea58bfe
--- /dev/null
+++ b/Test/Connection.hs
@@ -0,0 +1,44 @@
+module Connection where
+
+import Control.Concurrent (threadDelay)
+import Control.Exception (tryJust)
+import Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import Data.ByteString (ByteString)
+import qualified Database.PostgreSQL.Simple as PGS
+import GHC.IO.Exception (ioe_description)
+
+type Connection = (IORef PGS.Connection, ByteString)
+
+withConnection :: Connection -> (PGS.Connection -> IO r) -> IO (Either () r)
+withConnection (conn, connectString) k = do
+ conn' <- readIORef conn
+
+ er <- tryJust (\e -> if ioe_description e == "failed to fetch file descriptor"
+ then Just e
+ else Nothing)
+ (k conn')
+
+ case er of
+ Right r -> pure (Right r)
+ Left _ -> do
+ PGS.close conn'
+ -- If we reconnect immediately then the connection fails with
+ -- "Exception: libpq: failed (FATAL: the database system is in
+ -- recovery mode". We could try to handle that, but it's easier
+ -- just to delay for ten seconds, which seems to be enough time
+ -- for the database to recover.
+ threadDelay (10 * 1000 * 1000) -- microseconds
+ conn'new <- PGS.connectPostgreSQL connectString
+ writeIORef conn conn'new
+ return (Left ())
+
+connectPostgreSQL :: ByteString -> IO Connection
+connectPostgreSQL connectString = do
+ conn' <- PGS.connectPostgreSQL connectString
+ conn <- newIORef conn'
+ pure (conn, connectString)
+
+close :: Connection -> IO ()
+close (conn, _) = do
+ conn' <- readIORef conn
+ PGS.close conn'
diff --git a/Test/Opaleye/Test/Arbitrary.hs b/Test/Opaleye/Test/Arbitrary.hs
new file mode 100644
index 0000000..86646a1
--- /dev/null
+++ b/Test/Opaleye/Test/Arbitrary.hs
@@ -0,0 +1,464 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Opaleye.Test.Arbitrary where
+
+import Prelude hiding (compare, (.), id)
+
+import Opaleye.Test.Fields
+
+import qualified Opaleye as O
+import qualified Opaleye.Join as OJ
+
+import Control.Applicative (pure, (<$>), (<*>), liftA2)
+import qualified Control.Arrow as Arrow
+import Control.Arrow ((<<<))
+import Control.Category ((.), id)
+import Control.Monad ((<=<))
+import qualified Data.Profunctor as P
+import qualified Data.Profunctor.Product as PP
+import qualified Data.Monoid as Monoid
+import qualified Test.QuickCheck as TQ
+
+data Order = Asc | Desc deriving Show
+
+newtype ArbitrarySelect = ArbitrarySelect (O.Select Fields)
+newtype ArbitrarySelectMaybe =
+ ArbitrarySelectMaybe (O.Select (O.MaybeFields Fields))
+newtype ArbitrarySelectArr = ArbitrarySelectArr (O.SelectArr Fields Fields)
+newtype ArbitraryKleisli = ArbitraryKleisli (Fields -> O.Select Fields)
+newtype ArbitraryHaskells = ArbitraryHaskells { unArbitraryHaskells :: Haskells }
+ deriving Show
+newtype ArbitraryHaskellsList =
+ ArbitraryHaskellsList { unArbitraryHaskellsList :: [HaskellsTuple] }
+ deriving Show
+newtype ArbitraryPositiveInt = ArbitraryPositiveInt Int
+ deriving Show
+newtype ArbitraryOrder = ArbitraryOrder { unArbitraryOrder :: [(Order, Int)] }
+ deriving Show
+newtype ArbitraryFunction =
+ ArbitraryFunction { unArbitraryFunction :: forall m i b s.
+ Functor m => Choices m i b s -> Choices m i b s }
+
+twoIntTable :: String
+ -> O.Table (O.Field O.SqlInt4, O.Field O.SqlInt4)
+ (O.Field O.SqlInt4, O.Field O.SqlInt4)
+twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
+
+table1 :: O.Table (O.Field O.SqlInt4, O.Field O.SqlInt4)
+ (O.Field O.SqlInt4, O.Field O.SqlInt4)
+table1 = twoIntTable "table1"
+
+instance TQ.Arbitrary ArbitraryFunction where
+ arbitrary = do
+ i <- TQ.choose (0 :: Int, 4)
+
+ return (ArbitraryFunction (\xs ->
+ if i == 0 then
+ evens xs `appendChoices` odds xs
+ else if i == 1 then
+ evens xs `appendChoices` evens xs
+ else if i == 2 then
+ odds xs `appendChoices` odds xs
+ else if i == 3 then
+ evens xs
+ else
+ odds xs))
+
+-- We don't have the ability to aggregate MaybeFields, at least, not
+-- yet. Therefore we just replace them with Nothing.
+aggregateFields :: O.Aggregator Fields Fields
+aggregateFields =
+ -- The requirement to cast to int4 is silly, but we still have a bug
+ --
+ -- https://github.com/tomjaguarpaw/haskell-opaleye/issues/117
+ ppChoices (choicePP (P.rmap (O.unsafeCast "int4") O.sum)
+ O.boolAnd
+ (O.stringAgg (O.sqlString ", ")))
+ (const (PP.purePP (O.nothingFieldsExplicit (pure emptyChoices))))
+
+arbitraryOrder :: ArbitraryOrder -> O.Order Fields
+arbitraryOrder =
+ Monoid.mconcat
+ . map (\(direction, index) ->
+ (case direction of
+ Asc -> \f -> chooseChoice f (O.asc id) (O.asc id) (O.asc id)
+ Desc -> \f -> chooseChoice f (O.desc id) (O.desc id) (O.desc id))
+ -- If the list is empty we have to conjure up an arbitrary
+ -- value of type Field. We don't know how to order
+ -- MaybeFields (yet) so we do the same if we hit a
+ -- MaybeFields.
+ (\c -> let l = unChoices c
+ len = length l
+ in if len > 0 then
+ case l !! (index `mod` length l) of
+ Left i -> i
+ Right _ -> CInt 0
+ else
+ CInt 0))
+ . unArbitraryOrder
+
+restrictFirstBool :: O.SelectArr Fields Fields
+restrictFirstBool = Arrow.arr snd
+ <<< Arrow.first O.restrict
+ <<< Arrow.arr (firstBoolOrTrue (O.sqlBool True))
+
+instance Show ArbitrarySelect where
+ show (ArbitrarySelect q) = maybe "Empty query" id
+ (O.showSqlExplicit unpackFields q)
+
+instance Show ArbitrarySelectMaybe where
+ show (ArbitrarySelectMaybe q) =
+ maybe "Empty query" id
+ (O.showSqlExplicit (O.unpackspecMaybeFields unpackFields) q)
+
+instance Show ArbitrarySelectArr where
+ -- We could plug in dummy data here, or maybe just an empty list
+ show _ = "ArbitrarySelectArr"
+
+instance Show ArbitraryKleisli where
+ -- We could plug in dummy data here, or maybe just an empty list
+ show _ = "ArbitraryKleisli"
+
+instance Show ArbitraryFunction where
+ show = const "A function"
+
+recurseSafelyOneof :: [TQ.Gen a] -> [TQ.Gen a] -> [TQ.Gen a] -> TQ.Gen a
+recurseSafelyOneof r0 r1 r2 =
+ recurseSafely (TQ.oneof r0) (TQ.oneof r1) (TQ.oneof r2)
+
+recurseSafely :: TQ.Gen a -> TQ.Gen a -> TQ.Gen a -> TQ.Gen a
+recurseSafely r0 r1 r2 = do
+ -- The range of choose is inclusive
+ c <- TQ.choose (1, 10 :: Int)
+
+ if c <= 3
+ then r0
+ else if c <= 8
+ then r1
+ else if c <= 10
+ then r2
+ else error "Impossible"
+
+instance TQ.Arbitrary ArbitrarySelect where
+ arbitrary = recurseSafelyOneof
+ arbitrarySelectRecurse0
+ arbitrarySelectRecurse1
+ arbitrarySelectRecurse2
+
+instance TQ.Arbitrary ArbitrarySelectArr where
+ arbitrary = recurseSafelyOneof
+ arbitrarySelectArrRecurse0
+ arbitrarySelectArrRecurse1
+ arbitrarySelectArrRecurse2
+
+instance TQ.Arbitrary ArbitraryKleisli where
+ arbitrary = recurseSafelyOneof
+ arbitraryKleisliRecurse0
+ arbitraryKleisliRecurse1
+ arbitraryKleisliRecurse2
+
+-- It would be better if ArbitrarySelect recursively called this, but
+-- it will do for now.
+instance TQ.Arbitrary ArbitrarySelectMaybe where
+ arbitrary = do
+ TQ.oneof $
+ (fmap . fmap) ArbitrarySelectMaybe $
+ map (\fg -> do { ArbitrarySelect q <- TQ.arbitrary
+ ; f <- fg
+ ; return (f q)
+ })
+ genSelectArrMaybeMapper
+ ++
+ [ do
+ ArbitrarySelect q <- TQ.arbitrary
+ return (fmap fieldsToMaybeFields q)
+ ]
+
+-- [Note] Testing strategy
+--
+-- We have to be very careful otherwise we will generate
+-- infinite-sized expressions. On the other hand we probably generate
+-- far too small small expressions. We should probably improve that
+-- but explicitly passing a size parameter to the sub-generators.
+--
+-- The idea here is that only arbitrary... generators can do
+-- recursion, i.e. call arbitrary in a way that could lead to other
+-- calls of arbitrary. The gen... functions don't call arbitrary
+-- again, but can return functions to which arbitrary argument can be
+-- applied by arbitrary... generators.
+
+arbitrarySelectRecurse0 :: [TQ.Gen ArbitrarySelect]
+arbitrarySelectRecurse0 =
+ (fmap . fmap) ArbitrarySelect $
+ genSelect
+
+arbitrarySelectRecurse1 :: [TQ.Gen ArbitrarySelect]
+arbitrarySelectRecurse1 =
+ (fmap . fmap) ArbitrarySelect $
+ -- I'm not sure this is neccessary anymore. It should be covered by
+ -- other generation pathways.
+ [ do
+ ArbitrarySelectArr q <- TQ.arbitrary
+ return (q <<< pure emptyChoices)
+ ]
+ ++
+ map (\fg -> do { ArbitrarySelect q <- TQ.arbitrary
+ ; f <- fg
+ ; return (f q) })
+ genSelectMapper
+
+arbitrarySelectRecurse2 :: [TQ.Gen ArbitrarySelect]
+arbitrarySelectRecurse2 =
+ (fmap . fmap) ArbitrarySelect $
+ map (\fg -> do { ArbitrarySelect q1 <- TQ.arbitrary
+ ; ArbitrarySelect q2 <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q1 q2)
+ })
+ genSelectArrPoly
+ ++
+ map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary
+ ; ArbitrarySelect q2 <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q1 q2)
+ })
+ genSelectArrMapper2
+ ++
+ map (\fg -> do { ArbitrarySelect q1 <- TQ.arbitrary
+ ; ArbitrarySelect q2 <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q1 q2)
+ })
+ genSelectMapper2
+
+arbitrarySelectArrRecurse0 :: [TQ.Gen ArbitrarySelectArr]
+arbitrarySelectArrRecurse0 =
+ (fmap . fmap) ArbitrarySelectArr $
+ map (fmap ignoreArguments) genSelect
+ ++ genSelectArr
+ where ignoreArguments = P.lmap (const ())
+
+arbitrarySelectArrRecurse1 :: [TQ.Gen ArbitrarySelectArr]
+arbitrarySelectArrRecurse1 =
+ (fmap . fmap) ArbitrarySelectArr $
+ map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary
+ ; f <- fg
+ ; pure (O.laterally f q) })
+ genSelectMapper
+ ++
+ map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q) })
+ genSelectArrMapper
+ ++
+ map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary
+ ; f <- fg
+ ; pure (fmap (Choices . pure . Right) (f q)) })
+ genSelectArrMaybeMapper
+ ++
+ map (\fg -> do { ArbitraryKleisli q <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q) })
+ [ pure O.lateral ]
+
+arbitrarySelectArrRecurse2 :: [TQ.Gen ArbitrarySelectArr]
+arbitrarySelectArrRecurse2 =
+ (fmap . fmap) ArbitrarySelectArr $
+ map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary
+ ; ArbitrarySelectArr q2 <- TQ.arbitrary
+ ; f <- fg
+ ; pure (O.bilaterally f q1 q2) })
+ genSelectMapper2
+ ++
+ (
+ map (\fg -> do { ArbitrarySelectArr q1 <- TQ.arbitrary
+ ; ArbitrarySelectArr q2 <- TQ.arbitrary
+ ; f <- fg
+ ; pure (f q1 q2)
+ }) $
+ genSelectArrPoly
+ ++
+ genSelectArrMapper2
+ )
+
+arbitraryKleisliRecurse0 :: [TQ.Gen ArbitraryKleisli]
+arbitraryKleisliRecurse0 =
+ (fmap . fmap) (ArbitraryKleisli . const) genSelect
+ ++ [ pure (ArbitraryKleisli pure) ]
+
+arbitraryKleisliRecurse1 :: [TQ.Gen ArbitraryKleisli]
+arbitraryKleisliRecurse1 =
+ map (\fg -> do { ArbitrarySelectArr q <- TQ.arbitrary
+ ; f <- fg
+ ; return (ArbitraryKleisli (f q)) })
+ [ pure O.viaLateral ]
+
+arbitraryKleisliRecurse2 :: [TQ.Gen ArbitraryKleisli]
+arbitraryKleisliRecurse2 =
+ map (\fg -> do { ArbitraryKleisli q1 <- TQ.arbitrary
+ ; ArbitraryKleisli q2 <- TQ.arbitrary
+ ; f <- fg
+ ; return (ArbitraryKleisli (f q1 q2)) })
+ [ pure (<=<) , pure (liftA2 (liftA2 appendChoices)) ]
+
+genSelect :: [TQ.Gen (O.Select Fields)]
+genSelect =
+ [ do
+ ArbitraryHaskells fields_ <- TQ.arbitrary
+ return ((pure . fieldsOfHaskells) fields_)
+ , return (fmap (\(x,y) -> Choices [Left (CInt x), Left (CInt y)])
+ (O.selectTable table1))
+ , do
+ TQ.oneof [
+ do
+ ArbitraryHaskellsList l <- TQ.arbitrary
+ return (fmap fieldsList (O.valuesSafe (fmap O.toFields l)))
+ , -- We test empty lists of values separately, because we
+ -- used to not support them
+ do
+ s <- TQ.choose (0, 5)
+ l <- TQ.vectorOf s (pure ())
+ return (fmap (const emptyChoices) (O.valuesSafe l))
+ ]
+ ]
+
+genSelectArr :: [TQ.Gen (O.SelectArr Fields Fields)]
+genSelectArr =
+ [ do
+ f <- TQ.arbitrary
+ return (Arrow.arr (unArbitraryFunction f))
+
+ , do
+ return restrictFirstBool
+ ]
+
+genSelectMapper :: [TQ.Gen (O.Select Fields -> O.Select Fields)]
+genSelectMapper =
+ [ do
+ return (O.distinctExplicit distinctFields)
+ , do
+ l <- TQ.choose (0, 100)
+ return (O.limit l)
+ , do
+ l <- TQ.choose (0, 100)
+ return (O.offset l)
+ , do
+ o <- TQ.arbitrary
+ return (O.orderBy (arbitraryOrder o))
+
+ , do
+ return (O.aggregate aggregateFields)
+ , do
+ let q' q = P.dimap (\_ -> fst . firstBoolOrTrue (O.sqlBool True))
+ (fieldsList
+ . O.fromMaybeFields (0,
+ O.sqlBool True,
+ O.justFields (O.sqlString "field"))
+ . fmap listFields)
+ (O.optionalRestrictExplicit unpackFields q)
+ return q'
+ ]
+
+genSelectMapper2 :: [TQ.Gen (O.Select Fields -> O.Select Fields
+ -> O.Select Fields)]
+genSelectMapper2 =
+ [ do
+ binaryOperation <- TQ.elements [ O.intersect
+ , O.intersectAll
+ , O.union
+ , O.unionAll
+ , O.except
+ , O.exceptAll
+ ]
+ return (arbitraryBinary binaryOperation)
+ ]
+ where arbitraryBinary binaryOperation q1 q2 =
+ (fmap fieldsList
+ (binaryOperation
+ (fmap listFields q1)
+ (fmap listFields q2)))
+
+genSelectArrMapper :: [TQ.Gen (O.SelectArr a Fields -> O.SelectArr a Fields)]
+genSelectArrMapper =
+ [ do
+ thisLabel <- TQ.arbitrary
+ return (O.label thisLabel)
+ ]
+
+genSelectArrMaybeMapper :: [TQ.Gen (O.SelectArr a Fields
+ -> O.SelectArr a (O.MaybeFields Fields))]
+genSelectArrMaybeMapper =
+ [ do
+ return (OJ.optionalExplicit unpackFields)
+ ]
+
+genSelectArrPoly :: [TQ.Gen (O.SelectArr a Fields
+ -> O.SelectArr a Fields
+ -> O.SelectArr a Fields)]
+genSelectArrPoly =
+ [ do
+ pure (\q1 q2 -> appendChoices <$> q1 <*> q2)
+ ]
+
+genSelectArrMapper2 :: [TQ.Gen (O.SelectArr b c
+ -> O.SelectArr a b
+ -> O.SelectArr a c)]
+genSelectArrMapper2 =
+ [ do
+ pure (<<<)
+ ]
+
+instance TQ.Arbitrary ArbitraryHaskells where
+ arbitrary = arbitraryHaskells 6
+
+-- Postgres strings cannot contain the zero codepoint. See
+--
+-- https://www.postgresql.org/message-id/1171970019.3101.328.camel@coppola.muc.ecircle.de
+arbitraryPGString :: TQ.Gen String
+arbitraryPGString = filter (/= '\0') <$> TQ.arbitrary
+
+arbitraryHaskells :: Int -> TQ.Gen ArbitraryHaskells
+arbitraryHaskells size = do
+ s <- TQ.choose (0, size)
+
+ l <- TQ.vectorOf s (TQ.oneof
+ [ Left <$> CInt <$> TQ.arbitrary
+ , Left <$> CBool <$> TQ.arbitrary
+ , Left <$> CString <$> arbitraryPGString
+ , pure (Right Nothing)
+ , do
+ ArbitraryHaskells c <- arbitraryHaskells (size `div` 2)
+ return (Right (Just c))
+ ])
+
+ return (ArbitraryHaskells (Choices l))
+
+instance TQ.Arbitrary ArbitraryHaskellsList where
+ -- We don't want to choose very big lists because we take
+ -- products of queries and so their sizes are going to end up
+ -- multiplying.
+ arbitrary = do
+ k <- TQ.choose (0, 5)
+ l <- TQ.vectorOf k $ do
+ i <- TQ.arbitrary
+ b <- TQ.arbitrary
+ ms <- TQ.oneof [ pure Nothing
+ , Just <$> arbitraryPGString
+ ]
+ pure (i, b, ms)
+ return (ArbitraryHaskellsList 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)))
diff --git a/Test/Opaleye/Test/Fields.hs b/Test/Opaleye/Test/Fields.hs
new file mode 100644
index 0000000..fa2b8bf
--- /dev/null
+++ b/Test/Opaleye/Test/Fields.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Opaleye.Test.Fields where
+
+import Prelude hiding (compare)
+
+import Wrapped (constructor, asSumProfunctor,
+ constructorDecidable, asDecidable)
+
+import qualified Opaleye as O
+import qualified Opaleye.Internal.MaybeFields as OM
+import qualified Opaleye.Internal.Values as OV
+
+import Control.Arrow ((>>>))
+import Control.Applicative (pure)
+import qualified Data.Profunctor.Product.Default as D
+import qualified Data.Profunctor as P
+import qualified Data.Profunctor.Product as PP
+import qualified Data.Functor.Contravariant.Divisible as Divisible
+import qualified Data.Maybe as Maybe
+
+data Choice i b s = CInt i | CBool b | CString s deriving (Show, Eq, Ord)
+
+chooseChoice :: Divisible.Decidable f
+ => (a -> Choice i b s) -> f i -> f b -> f s -> f a
+chooseChoice choose fi fb fs = asDecidable $ proc a -> case choose a of
+ CInt i -> constructorDecidable fi -< i
+ CBool b -> constructorDecidable fb -< b
+ CString s -> constructorDecidable fs -< s
+
+newtype Choices m i b s =
+ Choices { unChoices :: [Either (Choice i b s) (m (Choices m i b s))] }
+
+deriving instance Show Haskells
+deriving instance Eq Haskells
+deriving instance Ord Haskells
+
+type SimpleField = Choice (O.Field O.SqlInt4)
+ (O.Field O.SqlBool)
+ (O.Field O.SqlText)
+type Fields = Choices O.MaybeFields (O.Field O.SqlInt4)
+ (O.Field O.SqlBool)
+ (O.Field O.SqlText)
+type Haskells = Choices Maybe Int Bool String
+
+emptyChoices :: Choices m i b s
+emptyChoices = Choices []
+
+appendChoices :: Choices m i b s -> Choices m i b s -> Choices m i b s
+appendChoices c1 c2 = Choices (unChoices c1 ++ unChoices c2)
+
+ppChoices :: (PP.SumProfunctor p, PP.ProductProfunctor p)
+ => p (Choice i b s) (Choice i' b' s')
+ -> (p (Choices m i b s) (Choices m' i' b' s')
+ -> p (m (Choices m i b s)) (m' (Choices m' i' b' s')))
+ -> p (Choices m i b s) (Choices m' i' b' s')
+ppChoices p f = ps
+ where ps = P.dimap unChoices Choices (PP.list (p PP.+++! f ps))
+
+fieldsOfHaskells :: Haskells -> Fields
+fieldsOfHaskells = O.toFieldsExplicit toFieldsFields
+
+fieldsList :: Functor m => (a, b, m s) -> Choices m a b s
+fieldsList (x, y, ms) =
+ Choices [ Left (CInt x),
+ Left (CBool y),
+ Right (fmap (Choices . pure . Left . CString) ms)
+ ]
+
+type FieldsTuple = (O.Field O.SqlInt4,
+ O.Field O.SqlBool,
+ O.MaybeFields (O.Field O.SqlText))
+type HaskellsTuple = (Int, Bool, Maybe String)
+
+listFieldsG :: Functor m
+ => Choices m i b s -> i -> b -> s -> m s -> (i, b, m s)
+listFieldsG f i b s ms = (fst (firstIntOr i f),
+ fst (firstBoolOrTrue b f),
+ ms')
+ where ms' = maybe ms (fmap (fst . firstStringOr s)) (firstMaybe f)
+
+listFields :: Fields -> FieldsTuple
+listFields f =
+ listFieldsG f 1 (O.sqlBool True) (O.sqlString "xyz") O.nothingFields
+
+listHaskells :: Haskells -> HaskellsTuple
+listHaskells f = listFieldsG f 1 True "xyz" Nothing
+
+fieldsToMaybeFields :: Applicative m => Choices m i b s -> m (Choices m i b s)
+fieldsToMaybeFields fs = case Maybe.listToMaybe (subMaybeFields fs) of
+ Nothing -> pure fs
+ Just x -> x
+
+unpackFields :: O.Unpackspec Fields Fields
+unpackFields = defChoicesPP O.unpackspecMaybeFields
+
+distinctNullsFields :: OM.WithNulls O.Distinctspec Fields Fields
+distinctNullsFields =
+ ppChoices defChoicePP (OM.mapMaybeFieldsWithNulls D.def)
+
+distinctFields :: O.Distinctspec Fields Fields
+distinctFields = P.dimap unChoices Choices (PP.list
+ (defChoicePP PP.+++! OM.unWithNulls D.def distinctNullsFields))
+
+fromFieldsFields :: O.FromFields Fields Haskells
+fromFieldsFields = defChoicesPP O.fromFieldsMaybeFields
+
+toFieldsFields :: O.ToFields Haskells Fields
+toFieldsFields =
+ defChoicesPP (O.toFieldsMaybeFields (fmap Choices OV.nullspecList))
+
+choicePP :: PP.SumProfunctor p
+ => p i1 i2 -> p b1 b2 -> p s1 s2
+ -> p (Choice i1 b1 s1) (Choice i2 b2 s2)
+choicePP p1 p2 p3 = asSumProfunctor $ proc choice -> case choice of
+ CInt i -> constructor CInt p1 -< i
+ CBool b -> constructor CBool p2 -< b
+ CString s -> constructor CString p3 -< s
+
+defChoicesPP :: (D.Default p a a', D.Default p b b', D.Default p s s',
+ PP.SumProfunctor p, PP.ProductProfunctor p)
+ => (p (Choices m a b s) (Choices m' a' b' s')
+ -> p (m (Choices m a b s)) (m' (Choices m' a' b' s')))
+ -> p (Choices m a b s) (Choices m' a' b' s')
+defChoicesPP = ppChoices defChoicePP
+
+defChoicePP :: (D.Default p a a', D.Default p b b', D.Default p s s',
+ PP.SumProfunctor p, PP.ProductProfunctor p)
+ => p (Choice a b s) (Choice a' b' s')
+defChoicePP = choicePP D.def D.def D.def
+
+-- We could try to be clever and look inside the MaybeFields, but this
+-- will do for now.
+firstBoolOrTrue :: b -> Choices m a b s -> (b, Choices m a b s)
+firstBoolOrTrue true c = (b, c)
+ where b = case Maybe.mapMaybe (either isBool (const Nothing)) (unChoices c) of
+ [] -> true
+ (x:_) -> x
+
+-- We could try to be clever and look inside the MaybeFields, but this
+-- will do for now.
+firstIntOr :: a -> Choices m a b s -> (a, Choices m a b s)
+firstIntOr else_ c = (b, c)
+ where b = case Maybe.mapMaybe (either isInt (const Nothing)) (unChoices c) of
+ [] -> else_
+ (x:_) -> x
+
+-- We could try to be clever and look inside the MaybeFields, but this
+-- will do for now.
+firstStringOr :: s -> Choices m a b s -> (s, Choices m a b s)
+firstStringOr else_ c = (b, c)
+ where b = case Maybe.mapMaybe (either isString (const Nothing)) (unChoices c) of
+ [] -> else_
+ (x:_) -> x
+
+firstMaybe :: Choices m a b s
+ -> Maybe (m (Choices m a b s))
+firstMaybe c = case Maybe.mapMaybe (either (const Nothing) Just) (unChoices c) of
+ [] -> Nothing
+ (x:_) -> Just x
+
+isBool :: Choice a b s -> Maybe b
+isBool (CInt _) = Nothing
+isBool (CBool l) = Just l
+isBool (CString _) = Nothing
+
+isInt :: Choice a b s -> Maybe a
+isInt (CInt a) = Just a
+isInt (CBool _) = Nothing
+isInt (CString _) = Nothing
+
+isString :: Choice a b s -> Maybe s
+isString (CInt _) = Nothing
+isString (CBool _) = Nothing
+isString (CString s) = Just s
+
+pairColumns :: Choices m i b s -> (Choices m i b s, Choices m i b s)
+pairColumns cs = (evens cs, odds cs)
+
+unpairColums :: (Choices m i b s, Choices m i b s) -> Choices m i b s
+unpairColums = uncurry appendChoices
+
+odds :: Choices m i b s -> Choices m i b s
+odds (Choices []) = Choices []
+odds (Choices (x:xs)) = Choices (x : unChoices (evens (Choices xs)))
+
+evens :: Choices m i b s -> Choices m i b s
+evens (Choices []) = Choices []
+evens (Choices (_:xs)) = odds (Choices xs)
+
+subMaybeFields :: Choices m i b s -> [m (Choices m i b s)]
+subMaybeFields = unChoices >>> Maybe.mapMaybe (\case Left _ -> Nothing
+ Right r -> Just r)
diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs
index a850b3a..fe410a6 100644
--- a/Test/QuickCheck.hs
+++ b/Test/QuickCheck.hs
@@ -1,268 +1,287 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module QuickCheck where
+import Prelude hiding (compare, (.), id)
+
+import Connection (Connection, withConnection)
+import Opaleye.Test.Arbitrary
+import Opaleye.Test.Fields
+
import qualified Opaleye as O
+import qualified Opaleye.Join as OJ
+
import qualified Database.PostgreSQL.Simple as PGS
-import qualified Test.QuickCheck as TQ
import Control.Applicative (Applicative, pure, (<$>), (<*>), liftA2)
+import qualified Control.Arrow as Arrow
+import Control.Arrow ((<<<))
+import Control.Category (Category, (.), id)
+import Control.Monad (when, (<=<))
import qualified Data.Profunctor.Product.Default as D
-import Data.List (sort)
+import qualified Data.Either
import qualified Data.List as List
import qualified Data.MultiSet as MultiSet
+import qualified Data.Profunctor as P
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.Ord as Ord hiding (compare)
import qualified Data.Set as Set
import qualified Data.Maybe as Maybe
-import qualified Control.Arrow as Arrow
+import qualified Test.QuickCheck as TQ
+import Test.QuickCheck ((===), (.&&.))
-twoIntTable :: String
- -> O.Table (O.Column O.SqlInt4, O.Column O.SqlInt4)
- (O.Column O.SqlInt4, O.Column O.SqlInt4)
-twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
-
-table1 :: O.Table (O.Column O.SqlInt4, O.Column O.SqlInt4)
- (O.Column O.SqlInt4, O.Column O.SqlInt4)
-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.SqlInt4) (O.Column O.SqlBool)]
-type Haskells = [Either Int Bool]
-
-columnsOfHaskells :: Haskells -> Columns
-columnsOfHaskells = O.constantExplicit eitherPP
-
-columnsList :: (a, b) -> [Either a b]
-columnsList (x, y) = [Left x, Right y]
-
-newtype ArbitraryQuery = ArbitraryQuery (O.Query Columns)
-newtype ArbitraryColumns = ArbitraryColumns { unArbitraryColumns :: Haskells }
- deriving Show
-newtype ArbitraryColumnsList = ArbitraryColumnsList { unArbitraryColumnsList :: [(Int, Bool)] }
- 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) = maybe "Empty query" id
- (O.showSqlForPostgresExplicit unpackColumns q)
-
-instance Show ArbitraryGarble where
- show = const "A permutation"
-
-instance TQ.Arbitrary ArbitraryQuery where
- arbitrary = TQ.oneof [
- (ArbitraryQuery . pure . columnsOfHaskells . unArbitraryColumns)
- <$> TQ.arbitrary
- , do
- ArbitraryQuery q1 <- TQ.arbitrary
- ArbitraryQuery q2 <- TQ.arbitrary
- aq ((++) <$> q1 <*> q2)
- , return (ArbitraryQuery (fmap (\(x,y) -> [Left x, Left y]) (O.queryTable table1)))
- , do
- ArbitraryQuery q <- TQ.arbitrary
- 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)
- , do
- ArbitraryColumnsList l <- TQ.arbitrary
- aq (fmap columnsList (O.values (fmap O.constant l)))
- ]
- 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) [False, True]))
- return (ArbitraryColumns l)
-
-instance TQ.Arbitrary ArbitraryColumnsList where
- -- We don't want to choose very big lists because we take
- -- products of queries and so their sizes are going to end up
- -- multiplying.
- arbitrary = do
- k <- TQ.choose (0, 5)
- l <- TQ.vectorOf k TQ.arbitrary
- return (ArbitraryColumnsList 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
-
-pureList :: [a] -> QueryDenotation a
-pureList = QueryDenotation . pure . pure
-
-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)
+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 Field. We don't know how to order
+ -- MaybeFields (yet) so we do the same if we hit a
+ -- MaybeFields.
+ --
+ -- Note that this one will compare CInt Int
+ -- to CBool Bool, but it never gets asked to
+ -- do so, so we don't care.
+ (Ord.comparing (\c -> let l = unChoices c
+ len = length l
+ in if len > 0 then
+ case l !! (index `mod` length l) of
+ Left i -> i
+ Right _ -> CInt 0
+ else
+ CInt 0)))
+ . unArbitraryOrder
+
+newtype SelectArrDenotation a b =
+ SelectArrDenotation { unSelectArrDenotation :: PGS.Connection -> [a] -> IO [b] }
+
+type SelectDenotation = SelectArrDenotation ()
+
+instance Functor (SelectArrDenotation a) where
+ fmap f = SelectArrDenotation
+ . (fmap . fmap . fmap . fmap) f
+ . unSelectArrDenotation
+
+instance Applicative (SelectArrDenotation a) where
+ pure = SelectArrDenotation . pure . pure . pure . pure
+ f <*> x = SelectArrDenotation ((liftA2 . liftA2 . liftA2 . liftA2) ($)
+ (unSelectArrDenotation f)
+ (unSelectArrDenotation x))
+
+instance Category SelectArrDenotation where
+ id = SelectArrDenotation (\_ -> pure)
+ (.) = \(SelectArrDenotation f) (SelectArrDenotation g) ->
+ SelectArrDenotation (\conn -> f conn <=< g conn)
+
+runSelectArrDenotation :: SelectArrDenotation a b
+ -> a
+ -> PGS.Connection
+ -> IO [b]
+runSelectArrDenotation sab a conn = unSelectArrDenotation sab conn [a]
+
+onList :: ([a] -> [b]) -> SelectDenotation a -> SelectDenotation b
+onList f = SelectArrDenotation . (fmap . fmap . fmap) f . unSelectArrDenotation
+
+-- This is taking liberties. Firstly it errors out when two fields
+-- are of different types. It should probably return a Maybe or an
+-- Either. Secondly, it doesn't detect when lists are the same
+-- length and it probably should.
+--
+-- We don't have the ability to aggregate MaybeFields, at least, not
+-- yet. Therefore we just replace them with Nothing.
+aggregateDenotation :: [Haskells] -> [Haskells]
+aggregateDenotation cs = if null cs
+ then []
+ else (pure
+ . List.foldl1' combine
+ . map emptyOutChoices
+ ) cs
+ where combine h1 h2 = Choices (zipWith (curry (\case
+ (Left l1, Left l2) -> Left $ case (l1, l2) of
+ (CInt i1, CInt i2) -> CInt (i1 + i2)
+ (CBool b1, CBool b2) -> CBool (b1 && b2)
+ (CString s1, CString s2) -> CString (s1 ++ ", " ++ s2)
+ _ -> error "Impossible"
+ (Right _, Right _) -> Right Nothing
+ _ -> error "Impossible")) (unChoices h1) (unChoices h2))
+
+ emptyOutChoices c = Choices $ flip map (unChoices c) $ \case
+ Left l -> Left l
+ Right _ -> Right Nothing
+
+optionalDenotation :: [Haskells] -> [Maybe Haskells]
+optionalDenotation = \case
+ [] -> [Nothing]
+ xs -> map Just xs
+
+optionalRestrictDenotation :: [Haskells] -> [Maybe Haskells]
+optionalRestrictDenotation = optionalDenotation . restrictFirstBoolList
+
+traverseDenotation :: SelectArrDenotation a Haskells
+ -> SelectDenotation (Maybe a)
+ -> SelectDenotation (Maybe Haskells)
+traverseDenotation (SelectArrDenotation f) (SelectArrDenotation q) =
+ (SelectArrDenotation (\conn l -> do
+ qr <- q conn l
+ let nothings :: [()]
+ (nothings, justs) =
+ Data.Either.partitionEithers
+ (map (\case
+ Nothing -> Left ()
+ Just j -> Right j)
+ qr)
+
+ justs' <- f conn justs
+ let _ = justs' :: [Haskells]
+
+ return ((Just <$> justs')
+ ++ (Nothing <$ nothings))))
+
+lateralDenotation :: (a -> SelectDenotation r)
+ -> SelectArrDenotation a r
+lateralDenotation f = SelectArrDenotation (\conn l ->
+ concatMapM (\r -> unSelectArrDenotation (f r) conn [()]) l)
+
+pureList :: [a] -> SelectDenotation a
+pureList = SelectArrDenotation . pure . pure . pure
+
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f = fmap concat . mapM f
+
+denotationExplicit :: O.FromFields fields a
+ -> O.Select fields
+ -> SelectDenotation a
+denotationExplicit qr q =
+ SelectArrDenotation (\conn rs ->
+ flip concatMapM rs (\() -> O.runSelectExplicit qr conn q))
+
+denotation :: O.Select Fields -> SelectDenotation Haskells
+denotation = denotationExplicit fromFieldsFields
+
+denotationArr :: O.SelectArr FieldsTuple Fields
+ -> SelectArrDenotation HaskellsTuple Haskells
+denotationArr q =
+ SelectArrDenotation (\conn hs ->
+ let fs = O.valuesSafe (map O.toFields hs)
+ in O.runSelectExplicit fromFieldsFields conn (q <<< fs))
+
+denotation2 :: O.Select (Fields, Fields)
+ -> SelectDenotation (Haskells, Haskells)
+denotation2 = denotationExplicit (fromFieldsFields PP.***! fromFieldsFields)
+
+denotationMaybeFields :: O.Select (O.MaybeFields Fields)
+ -> SelectDenotation (Maybe Haskells)
+denotationMaybeFields =
+ denotationExplicit (O.fromFieldsMaybeFields fromFieldsFields)
+
+unSelectDenotations :: Connection
+ -> SelectDenotation a
+ -> SelectDenotation b
+ -> ([a] -> [b] -> IO TQ.Property)
+ -> IO TQ.Property
+unSelectDenotations conn one two k = unSelectArrDenotations conn one two () k
+
+unSelectArrDenotations :: Connection
+ -> SelectArrDenotation i a
+ -> SelectArrDenotation i b
+ -> i
+ -> ([a] -> [b] -> IO TQ.Property)
+ -> IO TQ.Property
+unSelectArrDenotations conn one two i k = do
+ withConnection conn (runSelectArrDenotation one i) >>= \case
+ Left _ -> discard
+ Right oner -> withConnection conn (runSelectArrDenotation two i) >>= \case
+ Left _ -> discard
+ Right twor -> k oner twor
+
+ where discard = do
+ putStrLn "A denotation failed to run but it was not our fault"
+ pure (TQ.property TQ.Discard)
-- { Comparing the results
--- compareNoSort is stronger than compare' so prefer to use it where possible
-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')
-
-compareSortedBy :: Ord a
+-- compareNoSort is stronger than compare so prefer to use it where
+-- possible. If the queries do not compare equal but do compare equal
+-- sorted then switch to "compare". That's no big deal.
+compareNoSort :: (Ord a, Show a)
+ => Connection
+ -> SelectDenotation a
+ -> SelectDenotation a
+ -> IO TQ.Property
+compareNoSort conn one two =
+ unSelectDenotations conn one two $ \one' two' -> do
+ when (one' /= two')
+ (putStrLn $ if List.sort one' == List.sort two'
+ then "[but they are equal sorted]"
+ else "AND THEY'RE NOT EVEN EQUAL SORTED!")
+
+ return (one' === two')
+
+compare :: (Show a, Ord a)
+ => Connection
+ -> SelectDenotation a
+ -> SelectDenotation a
+ -> IO TQ.Property
+compare conn one two = unSelectDenotations conn one two $ \one' two' ->
+ return (List.sort one' === List.sort two')
+
+compareSortedBy :: (Show a, Ord a)
=> (a -> a -> Ord.Ordering)
- -> PGS.Connection
- -> QueryDenotation a
- -> QueryDenotation a
- -> IO Bool
-compareSortedBy o conn one two = do
- one' <- unQueryDenotation one conn
- two' <- unQueryDenotation two conn
- return ((sort one' == sort two')
- && isSortedBy o one')
+ -> Connection
+ -> SelectDenotation a
+ -> SelectDenotation a
+ -> IO TQ.Property
+compareSortedBy o conn one two = unSelectDenotations conn one two $ \one' two' ->
+ return ((List.sort one' === List.sort two')
+ .&&. isSortedBy o one')
-- }
-- { The tests
-columns :: PGS.Connection -> ArbitraryColumns -> IO Bool
-columns conn (ArbitraryColumns c) =
- compareNoSort conn (denotation' (pure (columnsOfHaskells c)))
+fields :: Connection -> ArbitraryHaskells -> IO TQ.Property
+fields conn (ArbitraryHaskells c) =
+ compareNoSort conn (denotation (pure (fieldsOfHaskells c)))
(pure c)
-fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool
-fmap' conn f (ArbitraryQuery q) =
- 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) =
- compare' conn (denotation2 ((,) <$> q1 <*> q2))
- ((,) <$> denotation' q1 <*> denotation' q2)
+compose :: Connection
+ -> ArbitrarySelectArr
+ -> ArbitrarySelect
+ -> IO TQ.Property
+compose conn (ArbitrarySelectArr a) (ArbitrarySelect q) = do
+ compare conn (denotation (a' . Arrow.arr listFields . q))
+ (denotationArr a' . fmap listHaskells (denotation q))
+ where a' = a . Arrow.arr fieldsList
+
+
+-- Would prefer to write 'compare conn (denotation id) id' but that
+-- requires extending compare to compare SelectArrs.
+identity :: Connection
+ -> ArbitrarySelect
+ -> IO TQ.Property
+identity conn (ArbitrarySelect q) = do
+ compare conn (denotation (id . q))
+ (id . denotation q)
+
+fmap' :: Connection -> ArbitraryFunction -> ArbitrarySelect -> IO TQ.Property
+fmap' conn (ArbitraryFunction f) (ArbitrarySelect q) =
+ compareNoSort conn (denotation (fmap f q))
+ (fmap f (denotation q))
+
+apply :: Connection -> ArbitrarySelect -> ArbitrarySelect -> IO TQ.Property
+apply conn (ArbitrarySelect q1) (ArbitrarySelect q2) =
+ compare conn (denotation2 ((,) <$> q1 <*> q2))
+ ((,) <$> denotation q1 <*> denotation q2)
-- When combining arbitrary queries with the applicative product <*>
-- the limit of the denotation is not always the denotation of the
@@ -272,77 +291,134 @@ apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) =
-- the remainder under the applied ordering.
--
-- Strangely the same caveat doesn't apply to offset.
-limit :: PGS.Connection
+limit :: Connection
-> ArbitraryPositiveInt
- -> ArbitraryQuery
+ -> ArbitrarySelect
-> ArbitraryOrder
- -> IO Bool
-limit conn (ArbitraryPositiveInt l) (ArbitraryQuery q) o = do
+ -> IO TQ.Property
+limit conn (ArbitraryPositiveInt l) (ArbitrarySelect q) o = do
let q' = O.limit l (O.orderBy (arbitraryOrder o) q)
- one' <- unQueryDenotation (denotation' q') conn
- two' <- unQueryDenotation (denotation' q) conn
-
- let remainder = MultiSet.fromList two'
- `MultiSet.difference`
- MultiSet.fromList one'
- maxChosen :: Maybe Haskells
- maxChosen = maximumBy (arbitraryOrdering o) one'
- minRemain :: Maybe Haskells
- minRemain = minimumBy (arbitraryOrdering o) (MultiSet.toList remainder)
- cond :: Maybe Bool
- cond = lteBy (arbitraryOrdering o) <$> maxChosen <*> minRemain
- condBool :: Bool
- condBool = Maybe.fromMaybe True cond
-
- return ((length one' == min l (length two'))
- && condBool)
-
-offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool
-offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) =
- compareNoSort conn (denotation' (O.offset l q))
- (onList (drop l) (denotation' q))
-
-order :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool
-order conn o (ArbitraryQuery q) =
+ unSelectDenotations conn (denotation q') (denotation q) $ \one' two' -> do
+ let remainder = MultiSet.fromList two'
+ `MultiSet.difference`
+ MultiSet.fromList one'
+ maxChosen :: Maybe Haskells
+ maxChosen = maximumBy (arbitraryOrdering o) one'
+ minRemain :: Maybe Haskells
+ minRemain = minimumBy (arbitraryOrdering o) (MultiSet.toList remainder)
+ cond :: Maybe Bool
+ cond = lteBy (arbitraryOrdering o) <$> maxChosen <*> minRemain
+ condBool :: Bool
+ condBool = Maybe.fromMaybe True cond
+
+ return ((length one' === min l (length two'))
+ .&&. condBool)
+
+offset :: Connection -> ArbitraryPositiveInt -> ArbitrarySelect
+ -> IO TQ.Property
+offset conn (ArbitraryPositiveInt l) (ArbitrarySelect q) =
+ compareNoSort conn (denotation (O.offset l q))
+ (onList (drop l) (denotation q))
+
+order :: Connection -> ArbitraryOrder -> ArbitrarySelect -> IO TQ.Property
+order conn o (ArbitrarySelect q) =
compareSortedBy (arbitraryOrdering o)
conn
- (denotation' (O.orderBy (arbitraryOrder o) q))
- (denotation' q)
+ (denotation (O.orderBy (arbitraryOrder o) q))
+ (denotation q)
-distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool
-distinct conn (ArbitraryQuery q) =
- compare' conn (denotation' (O.distinctExplicit eitherPP q))
- (onList nub (denotation' q))
+distinct :: Connection -> ArbitrarySelect -> IO TQ.Property
+distinct conn (ArbitrarySelect q) =
+ compare conn (denotation (O.distinctExplicit distinctFields q))
+ (onList nub (denotation q))
-- When we added <*> to the arbitrary queries we started getting some
-- consequences to do with the order of the returned rows and so
-- restrict had to start being compared sorted.
-restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool
-restrict conn (ArbitraryQuery q) =
- compare' conn (denotation' (restrictFirstBool Arrow.<<< q))
- (onList restrictFirstBoolList (denotation' q))
-
-values :: PGS.Connection -> ArbitraryColumnsList -> IO Bool
-values conn (ArbitraryColumnsList l) =
- compareNoSort conn (denotation' (fmap columnsList (O.values (fmap O.constant l))))
- (pureList (fmap columnsList l))
+restrict :: Connection -> ArbitrarySelect -> IO TQ.Property
+restrict conn (ArbitrarySelect q) =
+ compare conn (denotation (restrictFirstBool <<< q))
+ (onList restrictFirstBoolList (denotation q))
+
+values :: Connection -> ArbitraryHaskellsList -> IO TQ.Property
+values conn (ArbitraryHaskellsList l) =
+ compareNoSort conn
+ (denotation (fmap fieldsList (O.valuesSafe (fmap O.toFields l))))
+ (pureList (fmap fieldsList l))
+
+-- We test values entries of length two in values, and values entries
+-- of length zero here. Ideally we would find some way to merge them.
+valuesEmpty :: Connection -> [()] -> IO TQ.Property
+valuesEmpty conn l =
+ compareNoSort conn
+ (denotationExplicit D.def (O.valuesSafe l))
+ (pureList l)
+
+aggregate :: Connection -> ArbitrarySelect -> IO TQ.Property
+aggregate conn (ArbitrarySelect q) =
+ compareNoSort conn (denotation (O.aggregate aggregateFields q))
+ (onList aggregateDenotation (denotation q))
+
+
+label :: Connection -> String -> ArbitrarySelect -> IO TQ.Property
+label conn comment (ArbitrarySelect q) =
+ compareNoSort conn (denotation (O.label comment q))
+ (denotation q)
+
+optional :: Connection -> ArbitrarySelect -> IO TQ.Property
+optional conn (ArbitrarySelect q) =
+ compare conn (denotationMaybeFields (OJ.optionalExplicit unpackFields q))
+ (onList optionalDenotation (denotation q))
+
+optionalRestrict :: Connection -> ArbitrarySelect -> IO TQ.Property
+optionalRestrict conn (ArbitrarySelect q) =
+ compare conn (denotationMaybeFields q1)
+ (onList optionalRestrictDenotation (denotation q))
+ where q1 = P.lmap (\() -> fst . firstBoolOrTrue (O.sqlBool True))
+ (O.optionalRestrictExplicit unpackFields q)
+
+maybeFieldsToSelect :: Connection -> ArbitrarySelectMaybe -> IO TQ.Property
+maybeFieldsToSelect conn (ArbitrarySelectMaybe q) =
+ compare conn (denotation (O.maybeFieldsToSelect <<< q))
+ (onList (Maybe.maybeToList =<<) (denotationMaybeFields q))
+
+traverseMaybeFields :: Connection
+ -> ArbitrarySelectArr
+ -> ArbitrarySelectMaybe
+ -> IO TQ.Property
+traverseMaybeFields conn (ArbitrarySelectArr q) (ArbitrarySelectMaybe qm) =
+ compare conn
+ (denotationMaybeFields (travMF q' . Arrow.arr (fmap listFields) . qm))
+ (traverseDenotation (denotationArr q')
+ ((fmap . fmap) listHaskells (denotationMaybeFields qm)))
+ where u = unpackFields
+ q' = q . Arrow.arr fieldsList
+ travMF = O.traverseMaybeFieldsExplicit D.def u
+
+lateral :: Connection
+ -> ArbitraryKleisli
+ -> ArbitrarySelect
+ -> IO TQ.Property
+lateral conn (ArbitraryKleisli f) (ArbitrarySelect q) =
+ compare conn (lateralDenotation denotation_f . denotation_q)
+ (denotationArr (O.lateral f') . denotation_q)
+ where _ = f :: Fields -> O.Select Fields
+
+ f' :: FieldsTuple -> O.Select Fields
+ f' = f . Arrow.arr fieldsList
+
+ denotation_q :: SelectDenotation HaskellsTuple
+ denotation_q = fmap listHaskells (denotation q)
+
+ denotation_f :: HaskellsTuple -> SelectDenotation Haskells
+ denotation_f = denotation . f' . O.toFields
{- TODO
- * Aggregation
- * Binary operations
- * union
- * unionAll
- * intersect
- * intersectAll
- * except
- * exceptAll
* Nullability
- * Left join
- * Label (check it has no effect)
* Operators (mathematical, logical, etc.)
- * >>>?
+ * Use traverseMaybeFields in generated queries
-}
@@ -350,30 +426,39 @@ values conn (ArbitraryColumnsList l) =
-- { Running the QuickCheck
-run :: PGS.Connection -> IO ()
+-- One way that the property tests can fail is because of LIMIT and
+-- OFFSET. It seems that a query returning LIMIT or OFFSET does not
+-- always return the same result when it is part of a larger query.
+-- This happens rarely. We could sort before LIMIT or OFFSET to make
+-- it even rarer.
+
+run :: Connection -> IO ()
run conn = do
let prop1 p = fmap TQ.ioProperty (p conn)
prop2 p = (fmap . fmap) TQ.ioProperty (p conn)
prop3 p = (fmap . fmap . fmap) TQ.ioProperty (p conn)
test1 :: (Show a, TQ.Arbitrary a, TQ.Testable prop)
- => (PGS.Connection -> a -> IO prop) -> IO ()
+ => (Connection -> a -> IO prop) -> IO ()
test1 = t . prop1
test2 :: (Show a1, Show a2, TQ.Arbitrary a1, TQ.Arbitrary a2,
TQ.Testable prop)
- => (PGS.Connection -> a1 -> a2 -> IO prop) -> IO ()
+ => (Connection -> a1 -> a2 -> IO prop) -> IO ()
test2 = t . prop2
test3 :: (Show a1, Show a2, Show a3,
TQ.Arbitrary a1, TQ.Arbitrary a2, TQ.Arbitrary a3,
TQ.Testable prop)
- => (PGS.Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()
+ => (Connection -> a1 -> a2 -> a3 -> IO prop) -> IO ()
test3 = t . prop3
- t p = errorIfNotSuccess =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p
+ t p = errorIfNotSuccess
+ =<< TQ.quickCheckWithResult (TQ.stdArgs { TQ.maxSuccess = 1000 }) p
- test1 columns
+ test1 identity
+ test2 compose
+ test1 fields
test2 fmap'
test2 apply
test3 limit
@@ -382,6 +467,14 @@ run conn = do
test1 distinct
test1 restrict
test1 values
+ test1 valuesEmpty
+ test1 aggregate
+ test2 label
+ test1 optional
+ test1 optionalRestrict
+ test1 maybeFieldsToSelect
+ test2 traverseMaybeFields
+ test2 lateral
-- }
@@ -390,11 +483,6 @@ run conn = do
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)
-
-- Replace this with `isSuccess` when the following issue is fixed
--
-- https://github.com/nick8325/quickcheck/issues/220
@@ -403,22 +491,6 @@ 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
diff --git a/Test/Test.hs b/Test/Test.hs
index 474b58b..f77ae09 100644
--- a/Test/Test.hs
+++ b/Test/Test.hs
@@ -24,10 +24,13 @@ import qualified Data.Time as Time
import qualified Database.PostgreSQL.Simple as PGS
import qualified Database.PostgreSQL.Simple.Range as R
import GHC.Int (Int64)
-import Opaleye (Column, Nullable, Query,
- QueryArr, (.==), (.>))
+import Opaleye (Field, Nullable, Select,
+ SelectArr, (.==), (.>))
import qualified Opaleye as O
import qualified Opaleye.Internal.Aggregate as IA
+import Opaleye.Internal.RunQuery (DefaultFromField)
+import Opaleye.Internal.MaybeFields as OM
+import qualified Connection
import qualified QuickCheck
import System.Environment (lookupEnv)
import Test.Hspec
@@ -40,132 +43,121 @@ import Opaleye.Manipulation (Delete (Delete))
Status
======
-The tests here are very superficial and pretty much the bare mininmum
-that needs to be tested.
+The Hspec tests are very superficial and pretty much the bare mininmum
+that needs to be tested. The property tests are very thorough, but
+could be made even more thorough.
Future
======
-The overall approach to testing should probably go as follows.
+The property testing strategy is to define a denotation for SelectArrs
+and to show that the denotation of two SelectArrs combined with an
+operation is the same as using the operation to combine the
+denotations. The denotation that we will choose is roughly `Kleisli
+[]` but we have to do IO operations over a Postgres connection so it's
+slightly different in practice in a way that doesn't impinge on what I
+am about to say.
-1. Test all individual units of functionality by running them on a
- table and checking that they produce the expected result. This type
- of testing is amenable to the QuickCheck approach if we reimplement
- the individual units of functionality in Haskell.
+For example, using brackets "[.]" to stand for denotation, we want to
+ensure the property
-2. Test that "the denotation is an arrow morphism" is correct. I
- think in combination with 1. this is all that will be required to
- demonstrate that the library is correct.
+* [f <<< g] = [f] <<< [g]
- "The denotation is an arrow morphism" means that for each arrow
- operation, the denotation preserves the operation. If we have
+That is, running `f <<< g` on some input should be the same as running
+`g` on the input, followed by running `f` on the output of `g`.
+Likewise we want to ensure typeclass-general properties like
- f :: QueryArr wiresa wiresb
+* [id] = id
- then [f] should be something like
+* [f <*> g] = [f] <*> [g]
- [f] :: a -> IO [b]
- f as = runQuery (toValues as >>> f)
+as well as Postgres-specific properties like
- For example, take the operation >>>. We need to check that
+* [restrict] = guard
- [f >>> g] = [f] >>> [g]
+* [limit n q] = arr (take n) . [q]
- for all f and g, where [] means the denotation. We would also want
- to check that
-
- [id] = id
-
- and
-
- [first f] = first [f]
-
- I think checking these operations is sufficient because all the
- other QueryArr operations are implemented in terms of them.
-
- (Here I'm taking a slight liberty as `a -> IO [b]` is not directly
- an arrow, but it could be made one straightforwardly. (For the laws
- to be satisfied, perhaps we have to assume that the IO actions
- commute.))
-
- I don't think this type of testing is amenable to QuickCheck. It
- seems we have to check the properties for arbitrary arrows indexed by
- arbitrary types. I don't think QuickCheck supports this sort of
- randomised testing.
-
-Note
-----
-
-This seems to be equivalent to just reimplementing Opaleye in
-Haskell-side terms and comparing the results of queries run in both
-ways.
+The property tests are not written quite as neatly as this because
+there is a lot of scaffolding to make things line up. It's probably
+possible to simplify the property tests though.
-}
twoIntTable :: String
- -> O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+ -> O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
-table1 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+table1 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
table1 = twoIntTable "table1"
-table1F :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+table1F :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
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.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+-- This is implicitly testing our ability to handle upper case letters
+-- in table names.
+table2 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
table2 = twoIntTable "TABLE2"
-table3 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+table3 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
table3 = twoIntTable "table3"
-table4 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4)
+table4 :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
table4 = twoIntTable "table4"
-table5 :: O.Table (Maybe (Column O.SqlInt4), Maybe (Column O.SqlInt4))
- (Column O.SqlInt4, Column O.SqlInt4)
-table5 = O.TableWithSchema "public" "table5" (PP.p2 (O.optional "column1", O.optional "column2"))
+table5 :: O.Table (Maybe (Field O.SqlInt4), Maybe (Field O.SqlInt4))
+ (Field O.SqlInt4, Field O.SqlInt4)
+table5 = O.TableWithSchema "public" "table5"
+ (PP.p2 (O.optional "column1", O.optional "column2"))
-table6 :: O.Table (Column O.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText)
+table6 :: O.Table (Field O.SqlText, Field O.SqlText)
+ (Field O.SqlText, Field O.SqlText)
table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2"))
-table7 :: O.Table (Column O.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText)
+table7 :: O.Table (Field O.SqlText, Field O.SqlText)
+ (Field O.SqlText, Field O.SqlText)
table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2"))
-table8 :: O.Table (Column O.SqlJson) (Column O.SqlJson)
+table8 :: O.Table (Field O.SqlJson) (Field O.SqlJson)
table8 = O.Table "table8" (O.required "column1")
-table9 :: O.Table (Column O.SqlJsonb) (Column O.SqlJsonb)
+table9 :: O.Table (Field O.SqlJsonb) (Field O.SqlJsonb)
table9 = O.Table "table9" (O.required "column1")
-table10 :: O.Table (Column O.SqlInt4) (Column O.SqlInt4)
+table10 :: O.Table (Field O.SqlInt4) (Field O.SqlInt4)
table10 = O.Table "table10" (O.required "column1")
-tableKeywordColNames :: O.Table (Column O.SqlInt4, Column O.SqlInt4)
- (Column O.SqlInt4, Column O.SqlInt4)
-tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where"))
+tableKeywordColNames :: O.Table (Field O.SqlInt4, Field O.SqlInt4)
+ (Field O.SqlInt4, Field O.SqlInt4)
+tableKeywordColNames = O.Table "keywordtable"
+ (PP.p2 (O.required "column", O.required "where"))
-table1Q :: Query (Column O.SqlInt4, Column O.SqlInt4)
-table1Q = O.queryTable table1
+table1Q :: Select (Field O.SqlInt4, Field O.SqlInt4)
+table1Q = O.selectTable table1
-table2Q :: Query (Column O.SqlInt4, Column O.SqlInt4)
-table2Q = O.queryTable table2
+table2Q :: Select (Field O.SqlInt4, Field O.SqlInt4)
+table2Q = O.selectTable table2
-table3Q :: Query (Column O.SqlInt4, Column O.SqlInt4)
-table3Q = O.queryTable table3
+table3Q :: Select (Field O.SqlInt4, Field O.SqlInt4)
+table3Q = O.selectTable table3
-table6Q :: Query (Column O.SqlText, Column O.SqlText)
-table6Q = O.queryTable table6
+table6Q :: Select (Field O.SqlText, Field O.SqlText)
+table6Q = O.selectTable table6
-table7Q :: Query (Column O.SqlText, Column O.SqlText)
-table7Q = O.queryTable table7
+table7Q :: Select (Field O.SqlText, Field O.SqlText)
+table7Q = O.selectTable table7
-table8Q :: Query (Column O.SqlJson)
-table8Q = O.queryTable table8
+table8Q :: Select (Field O.SqlJson)
+table8Q = O.selectTable table8
-table9Q :: Query (Column O.SqlJsonb)
-table9Q = O.queryTable table9
+table9Q :: Select (Field O.SqlJsonb)
+table9Q = O.selectTable table9
table1dataG :: Num a => [(a, a)]
table1dataG = [ (1, 100)
@@ -176,8 +168,8 @@ table1dataG = [ (1, 100)
table1data :: [(Int, Int)]
table1data = table1dataG
-table1columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]
-table1columndata = table1dataG
+table1fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]
+table1fielddata = table1dataG
table2dataG :: Num a => [(a, a)]
table2dataG = [ (1, 100)
@@ -186,8 +178,8 @@ table2dataG = [ (1, 100)
table2data :: [(Int, Int)]
table2data = table2dataG
-table2columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]
-table2columndata = table2dataG
+table2fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]
+table2fielddata = table2dataG
table3dataG :: Num a => [(a, a)]
table3dataG = [ (1, 50) ]
@@ -195,8 +187,8 @@ table3dataG = [ (1, 50) ]
table3data :: [(Int, Int)]
table3data = table3dataG
-table3columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]
-table3columndata = table3dataG
+table3fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]
+table3fielddata = table3dataG
table4dataG :: Num a => [(a, a)]
table4dataG = [ (1, 10)
@@ -205,20 +197,21 @@ table4dataG = [ (1, 10)
table4data :: [(Int, Int)]
table4data = table4dataG
-table4columndata :: [(Column O.SqlInt4, Column O.SqlInt4)]
-table4columndata = table4dataG
+table4fielddata :: [(Field O.SqlInt4, Field O.SqlInt4)]
+table4fielddata = table4dataG
table6data :: [(String, String)]
table6data = [("xy", "a"), ("z", "a"), ("more text", "a")]
-table6columndata :: [(Column O.SqlText, Column O.SqlText)]
-table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data
+table6fielddata :: [(Field O.SqlText, Field O.SqlText)]
+table6fielddata = map (\(field1, field2) ->
+ (O.sqlString field1, O.sqlString field2)) table6data
table7data :: [(String, String)]
table7data = [("foo", "c"), ("bar", "a"), ("baz", "b")]
-table7columndata :: [(Column O.SqlText, Column O.SqlText)]
-table7columndata = map (O.pgString *** O.pgString) table7data
+table7fielddata :: [(Field O.SqlText, Field O.SqlText)]
+table7fielddata = map (O.sqlString *** O.sqlString) table7data
table8data :: [Json.Value]
table8data = [ Json.object
@@ -228,20 +221,20 @@ table8data = [ Json.object
]
]
-table8columndata :: [Column O.SqlJson]
-table8columndata = map O.pgValueJSON table8data
+table8fielddata :: [Field O.SqlJson]
+table8fielddata = map O.sqlValueJSON table8data
-table9columndata :: [Column O.SqlJsonb]
-table9columndata = map O.pgValueJSONB table8data
+table9fielddata :: [Field O.SqlJsonb]
+table9fielddata = map O.sqlValueJSONB 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
-dropAndCreateTable columnType (t, cols) = String.fromString drop_
+dropAndCreateTable fieldType (t, cols) = String.fromString drop_
where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"
++ "CREATE TABLE \"public\".\"" ++ t ++ "\""
++ " (" ++ commas cols ++ ");"
- integer c = "\"" ++ c ++ "\"" ++ " " ++ columnType
+ integer c = "\"" ++ c ++ "\"" ++ " " ++ fieldType
commas = L.intercalate "," . map integer
dropAndCreateTableInt :: (String, [String]) -> PGS.Query
@@ -270,28 +263,28 @@ dropAndCreateTablePk :: (String, [String]) -> PGS.Query
dropAndCreateTablePk (t, cols) = String.fromString drop_
where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";"
++ "CREATE TABLE \"public\".\"" ++ t ++ "\""
- ++ " (" ++ allColumns ++ ");"
+ ++ " (" ++ allFields ++ ");"
pk c = "\"" ++ c ++ "\"" ++ " integer primary key"
integer c = "\"" ++ c ++ "\"" ++ " integer"
commas = L.intercalate ","
- allColumns = commas $ [pk $ head cols] ++ map integer (tail cols)
+ allFields = commas $ [pk $ head cols] ++ map integer (tail cols)
type Table_ = (String, [String])
-- This should ideally be derived from the table definition above
-columns2 :: String -> Table_
-columns2 t = (t, ["column1", "column2"])
+fields2 :: String -> Table_
+fields2 t = (t, ["column1", "column2"])
-- This should ideally be derived from the table definition above
tables :: [Table_]
-tables = map columns2 ["table1", "TABLE2", "table3", "table4"]
+tables = map fields2 ["table1", "TABLE2", "table3", "table4"]
++ [("keywordtable", ["column", "where"])]
serialTables :: [Table_]
-serialTables = map columns2 ["table5"]
+serialTables = map fields2 ["table5"]
textTables :: [Table_]
-textTables = map columns2 ["table6", "table7"]
+textTables = map fields2 ["table6", "table7"]
jsonTables :: [Table_]
jsonTables = [("table8", ["column1"])]
@@ -319,77 +312,85 @@ dropAndCreateDB conn = do
type Test = SpecWith PGS.Connection
-testH :: D.Default O.QueryRunner wires haskells =>
- Query wires
+testH :: D.Default O.FromFields fields haskells =>
+ Select fields
-> ([haskells] -> IO expectation)
-> PGS.Connection
-> IO expectation
testH q p conn = do
- result <- O.runQuery conn q
+ result <- O.runSelect conn q
p result
-queryShouldReturnSorted :: (D.Default O.QueryRunner wires haskells, Show haskells, Ord haskells) =>
- Query wires
+selectShouldReturnSorted :: (D.Default O.FromFields fields haskells
+ , Show haskells, Ord haskells) =>
+ Select fields
-> [haskells]
-> PGS.Connection
-> Expectation
-queryShouldReturnSorted q expected = testH q (\res -> L.sort res `shouldBe` L.sort expected)
+selectShouldReturnSorted q expected = testH q (\res ->
+ L.sort res `shouldBe` L.sort expected)
testSelect :: Test
-testSelect = it "selects" $ table1Q `queryShouldReturnSorted` table1data
+testSelect = it "selects" $ table1Q `selectShouldReturnSorted` table1data
testProduct :: Test
-testProduct = it "joins tables" $ query `queryShouldReturnSorted` (A.liftA2 (,) table1data table2data)
- where query = table1Q &&& table2Q
+testProduct = it "joins tables" $
+ select `selectShouldReturnSorted` A.liftA2 (,) table1data table2data
+ where select = table1Q &&& table2Q
testRestrict :: Test
-testRestrict = it "restricts the rows returned" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
- where query = proc () -> do
+testRestrict = it "restricts the rows returned" $
+ select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
+ where select = proc () -> do
t <- table1Q -< ()
O.restrict -< fst t .== 1
Arr.returnA -< t
testExists :: Test
-testExists = it "restricts the rows returned with EXISTS" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
- where query = proc () -> do
+testExists = it "restricts the rows returned with EXISTS" $
+ select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data)
+ where select = proc () -> do
t <- table1Q -< ()
- () <- O.exists (proc t -> do
+ () <- O.restrictExists (proc t -> do
t' <- table1Q -< ()
O.restrict -< fst t' .> fst t) -< t
Arr.returnA -< t
testNotExists :: Test
-testNotExists = it "restricts the rows returned with NOT EXISTS" $ query `queryShouldReturnSorted` filter ((== 2) . fst) (L.sort table1data)
- where query = proc () -> do
+testNotExists = it "restricts the rows returned with NOT EXISTS" $
+ select `selectShouldReturnSorted` filter ((== 2) . fst) (L.sort table1data)
+ where select = proc () -> do
t <- table1Q -< ()
- () <- O.notExists (proc t -> do
+ () <- O.restrictNotExists (proc t -> do
t' <- table1Q -< ()
O.restrict -< fst t' .> fst t) -< t
Arr.returnA -< t
testIn :: Test
-testIn = it "restricts values to a range" $ query `queryShouldReturnSorted` filter (flip elem [100, 200] . snd) (L.sort table1data)
- where query = proc () -> do
+testIn = it "restricts values to a range" $
+ select `selectShouldReturnSorted` filter (flip elem [100, 200] . snd)
+ (L.sort table1data)
+ where select = proc () -> do
t <- table1Q -< ()
- O.restrict -< O.in_ [O.pgInt4 100, O.pgInt4 200] (snd t)
+ O.restrict -< O.in_ [O.sqlInt4 100, O.sqlInt4 200] (snd t)
O.restrict -< O.not (O.in_ [] (fst t)) -- Making sure empty lists work.
Arr.returnA -< t
testNum :: Test
-testNum = it "" $ query `queryShouldReturnSorted` (map op table1data)
- where query :: Query (Column O.SqlInt4)
- query = proc () -> do
+testNum = it "" $ select `selectShouldReturnSorted` map op table1data
+ where select :: Select (Field O.SqlInt4)
+ select = proc () -> do
t <- table1Q -< ()
Arr.returnA -< op t
op :: Num a => (a, a) -> a
op (x, y) = abs (x - 5) * signum (x - 4) * (y * y + 1)
testDiv :: Test
-testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1data)
- where query :: Query (Column O.SqlFloat8)
- query = proc () -> do
- t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< ()
+testDiv = it "" $ select `selectShouldReturnSorted` map (op . toDoubles) table1data
+ where select :: Select (Field O.SqlFloat8)
+ select = proc () -> do
+ t <- Arr.arr (doubleOfInt *** doubleOfInt) <<< table1Q -< ()
Arr.returnA -< op t
op :: Fractional a => (a, a) -> a
-- Choosing 0.5 here as it should be exactly representable in
@@ -398,10 +399,12 @@ testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1da
toDoubles :: (Int, Int) -> (Double, Double)
toDoubles = fromIntegral *** fromIntegral
+ doubleOfInt = O.unsafeCast "float8"
+
-- TODO: need to implement and test case_ returning tuples
testCase :: Test
-testCase = it "" $ q `queryShouldReturnSorted` expected
- where q :: Query (Column O.SqlInt4)
+testCase = it "" $ q `selectShouldReturnSorted` expected
+ where q :: Select (Field O.SqlInt4)
q = table1Q >>> proc (i, j) -> do
Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33
expected :: [Int]
@@ -410,15 +413,16 @@ testCase = it "" $ q `queryShouldReturnSorted` expected
-- This tests case_ with an empty list of cases, to make sure it generates valid
-- SQL.
testCaseEmpty :: Test
-testCaseEmpty = it "" $ q `queryShouldReturnSorted` expected
- where q :: Query (Column O.SqlInt4)
+testCaseEmpty = it "" $ q `selectShouldReturnSorted` expected
+ where q :: Select (Field O.SqlInt4)
q = table1Q >>> proc _ ->
Arr.returnA -< O.case_ [] 33
expected :: [Int]
expected = [33, 33, 33, 33]
testDistinct :: Test
-testDistinct = it "" $ O.distinct table1Q `queryShouldReturnSorted` (L.nub table1data)
+testDistinct =
+ it "" $ O.distinct table1Q `selectShouldReturnSorted` L.nub table1data
testDistinctOn :: Test
@@ -459,8 +463,9 @@ testDistinctOn = do
testH q (\r -> L.sort r `shouldBe` L.sort expected) conn
where
- pgTriples :: [(O.Column O.PGInt8, O.Column O.PGInt8, O.Column O.PGText)]
- pgTriples = (\(x,y,z) -> (O.pgInt8 x, O.pgInt8 y, O.pgStrictText z)) <$> triples
+ pgTriples :: [(O.Field O.SqlInt8, O.Field O.SqlInt8, O.Field O.SqlText)]
+ pgTriples = (\(x,y,z) ->
+ (O.sqlInt8 x, O.sqlInt8 y, O.sqlStrictText z)) <$> triples
triples :: [(Int64, Int64, T.Text)]
triples =
@@ -474,46 +479,54 @@ testDistinctOn = do
, (4, 100, "b")
]
--- FIXME: the unsafeCoerceColumn is currently needed because the type
+-- FIXME: the unsafeCoerceField is currently needed because the type
-- changes required for aggregation are not currently dealt with by
-- Opaleye.
-aggregateCoerceFIXME :: QueryArr (Column O.SqlInt4) (Column O.SqlInt8)
+aggregateCoerceFIXME :: SelectArr (Field O.SqlInt4) (Field O.SqlInt8)
aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME'
-aggregateCoerceFIXME' :: Column a -> Column O.SqlInt8
-aggregateCoerceFIXME' = O.unsafeCoerceColumn
+aggregateCoerceFIXME' :: Field a -> Field O.SqlInt8
+aggregateCoerceFIXME' = O.unsafeCoerceField
testAggregate :: Test
testAggregate = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum))
- table1Q) `queryShouldReturnSorted` [(1, 400) :: (Int, Int64), (2, 300)]
+ table1Q)
+ `selectShouldReturnSorted` [ (1, 400) :: (Int, Int64)
+ , (2, 300) ]
testAggregate0 :: Test
testAggregate0 = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.sum, O.sum))
- (O.keepWhen (const (O.pgBool False))
- <<< table1Q)) `queryShouldReturnSorted` ([] :: [(Int, Int64)])
+ (O.keepWhen (const (O.sqlBool False))
+ <<< table1Q))
+ `selectShouldReturnSorted` ([] :: [(Int, Int64)])
testAggregateFunction :: Test
testAggregateFunction = it "" $ (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum))
(fmap (\(x, y) -> (x + 1, y)) table1Q))
- `queryShouldReturnSorted` [(2, 400) :: (Int, Int64), (3, 300)]
+ `selectShouldReturnSorted` [ (2, 400) :: (Int, Int64)
+ , (3, 300) ]
testAggregateProfunctor :: Test
-testAggregateProfunctor = it "" $ q `queryShouldReturnSorted` [(1, 1200) :: (Int, Int64), (2, 300)]
+testAggregateProfunctor = it "" $
+ q `selectShouldReturnSorted` [ (1, 1200) :: (Int, Int64), (2, 300)]
where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q
countsum = P.dimap (\x -> (x,x))
(\(x, y) -> aggregateCoerceFIXME' x * y)
(PP.p2 (O.sum, O.count))
testStringArrayAggregate :: Test
-testStringArrayAggregate = it "" $ q `queryShouldReturnSorted` [(map fst table6data, minimum (map snd table6data))]
+testStringArrayAggregate = it "" $
+ q `selectShouldReturnSorted` [(map fst table6data,
+ minimum (map snd table6data))]
where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q
testStringAggregate :: Test
-testStringAggregate = it "" $ q `queryShouldReturnSorted` expected
- where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q
+testStringAggregate = it "" $ q `selectShouldReturnSorted` expected
+ where q = O.aggregate (PP.p2 ((O.stringAgg . O.sqlString) "_", O.groupBy))
+ table6Q
expected = [(
(foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data ,
head (map snd table6data))]
@@ -521,8 +534,9 @@ testStringAggregate = it "" $ q `queryShouldReturnSorted` expected
-- | Using aggregateOrdered applies the ordering to all aggregates.
testStringArrayAggregateOrdered :: Test
-testStringArrayAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
- where q = O.aggregateOrdered (O.asc snd) (PP.p2 (O.arrayAgg, O.stringAgg . O.pgString $ ",")) table7Q
+testStringArrayAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected
+ where q = O.aggregateOrdered (O.asc snd)
+ (PP.p2 (O.arrayAgg, O.stringAgg . O.sqlString $ ",")) table7Q
expected = [( map fst sortedData
, L.intercalate "," . map snd $ sortedData
)
@@ -533,14 +547,16 @@ testStringArrayAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
-- different aggregates.
testMultipleAggregateOrdered :: Test
-testMultipleAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
+testMultipleAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected
where q = O.aggregate ((,) <$> IA.orderAggregate (O.asc snd)
(P.lmap fst O.arrayAgg)
<*> IA.orderAggregate (O.desc snd)
- (P.lmap snd (O.stringAgg . O.pgString $ ","))
+ (P.lmap snd (O.stringAgg . O.sqlString $ ","))
) table7Q
expected = [( map fst . L.sortBy (Ord.comparing snd) $ table7data
- , L.intercalate "," . map snd . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data
+ , L.intercalate ","
+ . map snd
+ . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data
)
]
@@ -548,7 +564,7 @@ testMultipleAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
-- order, just like with ordered queries.
--
testOverwriteAggregateOrdered :: Test
-testOverwriteAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
+testOverwriteAggregateOrdered = it "" $ q `selectShouldReturnSorted` expected
where q = O.aggregate ( IA.orderAggregate (O.asc snd)
. IA.orderAggregate (O.desc snd)
$ PP.p2 (O.arrayAgg, O.max)
@@ -559,42 +575,45 @@ testOverwriteAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected
]
testCountRows0 :: Test
-testCountRows0 = it "" $ q `queryShouldReturnSorted` [0 :: Int64]
- where q = O.countRows (O.keepWhen (const (O.pgBool False)) <<< table7Q)
+testCountRows0 = it "" $ q `selectShouldReturnSorted` [0 :: Int64]
+ where q = O.countRows (O.keepWhen (const (O.sqlBool False)) <<< table7Q)
testCountRows3 :: Test
-testCountRows3 = it "" $ q `queryShouldReturnSorted` [3 :: Int64]
+testCountRows3 = it "" $ q `selectShouldReturnSorted` [3 :: Int64]
where q = O.countRows table7Q
-queryShouldReturnSortBy :: O.Order (Column O.SqlInt4, Column O.SqlInt4)
+selectShouldReturnSortBy :: O.Order (Field O.SqlInt4, Field O.SqlInt4)
-> ((Int, Int) -> (Int, Int) -> Ordering)
-> (PGS.Connection -> Expectation)
-queryShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q)
+selectShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q)
(L.sortBy order table1data `shouldBe`)
testOrderBy :: Test
-testOrderBy = it "" $ queryShouldReturnSortBy (O.desc snd)
+testOrderBy = it "" $ selectShouldReturnSortBy (O.desc snd)
(flip (Ord.comparing snd))
testOrderBy2 :: Test
-testOrderBy2 = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc snd)
+testOrderBy2 = it "" $ selectShouldReturnSortBy (O.desc fst <> O.asc snd)
(flip (Ord.comparing fst) <> Ord.comparing snd)
testOrderBySame :: Test
-testOrderBySame = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc fst)
+testOrderBySame = it "" $ selectShouldReturnSortBy (O.desc fst <> O.asc fst)
(flip (Ord.comparing fst) <> Ord.comparing fst)
testOrderExact :: Test
-testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q) (result `shouldBe`)
- where cols = map O.constant [300,200::Int]
+testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q)
+ (result `shouldBe`)
+ where cols = map O.toFields [300,200::Int]
result = [ (2::Int, 300::Int)
, (1, 200)
, (1, 100)
, (1, 100)
]
-limitOrderShouldMatch :: (Query (Column O.SqlInt4, Column O.SqlInt4) -> Query (Column O.SqlInt4, Column O.SqlInt4))
- -> ([(Int, Int)] -> [(Int, Int)]) -> (PGS.Connection -> Expectation)
+limitOrderShouldMatch :: (Select (Field O.SqlInt4, Field O.SqlInt4)
+ -> Select (Field O.SqlInt4, Field O.SqlInt4))
+ -> ([(Int, Int)] -> [(Int, Int)])
+ -> (PGS.Connection -> Expectation)
limitOrderShouldMatch olQ ol = testH (olQ (orderQ table1Q))
(ol (order table1data) `shouldBe`)
where orderQ = O.orderBy (O.desc snd)
@@ -613,21 +632,21 @@ testOffsetLimit :: Test
testOffsetLimit = it "" $ limitOrderShouldMatch (O.offset 2 . O.limit 2) (drop 2 . take 2)
testDistinctAndAggregate :: Test
-testDistinctAndAggregate = it "" $ q `queryShouldReturnSorted` expectedResult
+testDistinctAndAggregate = it "" $ q `selectShouldReturnSorted` expectedResult
where q = O.distinct table1Q
&&& (Arr.second aggregateCoerceFIXME
<<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q)
expectedResult = A.liftA2 (,) (L.nub table1data)
[(1 :: Int, 400 :: Int64), (2, 300)]
-one :: Query (Column O.SqlInt4)
-one = Arr.arr (const (1 :: Column O.SqlInt4))
+one :: Select (Field O.SqlInt4)
+one = Arr.arr (const (1 :: Field O.SqlInt4))
-- The point of the "double" tests is to ensure that we do not
--- introduce name clashes in the operations which create new column names
-testDoubleH :: (Show haskells, Eq haskells, D.Default O.QueryRunner columns haskells) =>
- (QueryArr () (Column O.SqlInt4) -> QueryArr () columns) -> [haskells]
- -> (PGS.Connection -> Expectation)
+-- introduce name clashes in the operations which create new field names
+testDoubleH :: (Show haskells, Eq haskells, D.Default O.FromFields fields haskells)
+ => (SelectArr () (Field O.SqlInt4) -> SelectArr () fields) -> [haskells]
+ -> (PGS.Connection -> Expectation)
testDoubleH q expected1 = testH (q one &&& q one) (`shouldBe` expected2)
where expected2 = A.liftA2 (,) expected1 expected1
@@ -639,21 +658,21 @@ testDoubleAggregate = it "" $ testDoubleH (O.aggregate O.count) [1 :: Int64]
testDoubleLeftJoin :: Test
testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))]
- where lj :: Query (Column O.SqlInt4)
- -> Query (Column O.SqlInt4, Column (Nullable O.SqlInt4))
+ where lj :: Select (Field O.SqlInt4)
+ -> Select (Field O.SqlInt4, Field (Nullable O.SqlInt4))
lj q = O.leftJoin q q (uncurry (.==))
testDoubleValues :: Test
testDoubleValues = it "" $ testDoubleH v [1 :: Int]
- where v :: Query (Column O.SqlInt4) -> Query (Column O.SqlInt4)
+ where v :: Select (Field O.SqlInt4) -> Select (Field O.SqlInt4)
v _ = O.values [1]
testDoubleUnionAll :: Test
testDoubleUnionAll = it "" $ testDoubleH u [1 :: Int, 1]
where u q = q `O.unionAll` q
-aLeftJoin :: Query ((Column O.SqlInt4, Column O.SqlInt4),
- (Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4)))
+aLeftJoin :: Select ((Field O.SqlInt4, Field O.SqlInt4),
+ (Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4)))
aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r)
testLeftJoin :: Test
@@ -666,10 +685,10 @@ testLeftJoin = it "" $ testH aLeftJoin (`shouldBe` expected)
testLeftJoinNullable :: Test
testLeftJoinNullable = it "" $ testH q (`shouldBe` expected)
- where q :: Query ((Column O.SqlInt4, Column O.SqlInt4),
- ((Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4)),
- (Column (Nullable O.SqlInt4),
- Column (Nullable O.SqlInt4))))
+ where q :: Select ((Field O.SqlInt4, Field O.SqlInt4),
+ ((Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4)),
+ (Field (Nullable O.SqlInt4),
+ Field (Nullable O.SqlInt4))))
q = O.leftJoin table3Q aLeftJoin cond
cond (x, y) = fst x .== fst (fst y)
@@ -700,7 +719,7 @@ testThreeWayProduct = it "" $ testH q (`shouldBe` expected)
testValues :: Test
testValues = it "" $ testH (O.values values) (values' `shouldBe`)
- where values :: [(Column O.SqlInt4, Column O.SqlInt4)]
+ where values :: [(Field O.SqlInt4, Field O.SqlInt4)]
values = [ (1, 10)
, (2, 100) ]
values' :: [(Int, Int)]
@@ -710,7 +729,7 @@ testValues = it "" $ testH (O.values values) (values' `shouldBe`)
{- FIXME: does not yet work
testValuesDouble :: Test
testValuesDouble = testG (O.values values) (values' ==)
- where values :: [(Column O.SqlInt4, Column O.SqlFloat8)]
+ where values :: [(Field O.SqlInt4, Field O.SqlFloat8)]
values = [ (1, 10.0)
, (2, 100.0) ]
values' :: [(Int, Double)]
@@ -720,32 +739,44 @@ testValuesDouble = testG (O.values values) (values' ==)
testValuesEmpty :: Test
testValuesEmpty = it "" $ testH (O.values values) (values' `shouldBe`)
- where values :: [Column O.SqlInt4]
+ where values :: [Field O.SqlInt4]
values = []
values' :: [Int]
values' = []
testUnionAll :: Test
-testUnionAll = it "" $ (table1Q `O.unionAll` table2Q) `queryShouldReturnSorted` (table1data ++ table2data)
+testUnionAll = it "" $ (table1Q `O.unionAll` table2Q)
+ `selectShouldReturnSorted` (table1data ++ table2data)
testTableFunctor :: Test
-testTableFunctor = it "" $ testH (O.queryTable table1F) (result `shouldBe`)
+testTableFunctor = it "" $ testH (O.selectTable table1F) (result `shouldBe`)
where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data
-- TODO: This is getting too complicated
testUpdate :: Test
testUpdate = it "" $ \conn -> do
- _ <- O.runUpdate conn table4 update cond
- result <- runQueryTable4 conn
+ _ <- O.runUpdate_ conn O.Update { O.uTable = table4
+ , O.uUpdateWith = update
+ , O.uWhere = cond
+ , O.uReturning = O.rCount }
+ result <- runSelectTable4 conn
result `shouldBe` expected
- _ <- O.runDelete conn table4 condD
- resultD <- runQueryTable4 conn
+ _ <- O.runDelete_ conn O.Delete { O.dTable = table4
+ , O.dWhere = condD
+ , O.dReturning = O.rCount }
+ resultD <- runSelectTable4 conn
resultD `shouldBe` expectedD
- returned <- O.runInsertManyReturning conn table4 insertT returning
- _ <- O.runInsertMany conn table4 insertTMany
- resultI <- runQueryTable4 conn
+ returned <- O.runInsert_ conn O.Insert { O.iTable = table4
+ , O.iRows = insertT
+ , O.iReturning = O.rReturning returning
+ , O.iOnConflict = Nothing }
+ _ <- O.runInsert_ conn O.Insert { O.iTable = table4
+ , O.iRows = insertTMany
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Nothing }
+ resultI <- runSelectTable4 conn
resultI `shouldBe` expectedI
returned `shouldBe` expectedR
@@ -758,12 +789,12 @@ testUpdate = it "" $ \conn -> do
, (22, -18)]
expectedD :: [(Int, Int)]
expectedD = [(1, 10)]
- runQueryTable4 conn = O.runQuery conn (O.queryTable table4)
+ runSelectTable4 conn = O.runSelect conn (O.selectTable table4)
- insertT :: [(Column O.SqlInt4, Column O.SqlInt4)]
+ insertT :: [(Field O.SqlInt4, Field O.SqlInt4)]
insertT = [(1, 2), (3, 5)]
- insertTMany :: [(Column O.SqlInt4, Column O.SqlInt4)]
+ insertTMany :: [(Field O.SqlInt4, Field O.SqlInt4)]
insertTMany = [(20, 30), (40, 50)]
expectedI :: [(Int, Int)]
@@ -775,7 +806,11 @@ testUpdate = it "" $ \conn -> do
testDeleteReturning :: Test
testDeleteReturning = it "" $ \conn -> do
result <- O.runDelete_ conn delete
- _ <- O.runInsertMany conn table4 ([(40,50)] :: [(Column O.SqlInt4, Column O.SqlInt4)]) :: IO Int64
+ _ <- O.runInsert_ conn O.Insert { O.iTable = table4
+ , O.iRows = [(40,50)]
+ :: [(Field O.SqlInt4, Field O.SqlInt4)]
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Nothing } :: IO Int64
result `shouldBe` expected
where delete = Delete table cond returning
table = table4
@@ -785,25 +820,40 @@ testDeleteReturning = it "" $ \conn -> do
testInsertConflict :: Test
testInsertConflict = it "inserts with conflicts" $ \conn -> do
- _ <- O.runDelete conn table10 (const $ O.constant True)
- returned <- O.runInsertManyReturning conn table10 insertT id
- extras <- O.runInsertManyReturningOnConflictDoNothing conn table10 conflictsT id
- moreExtras <- O.runInsertManyOnConflictDoNothing conn table10 moreConflictsT
+ _ <- O.runDelete_ conn O.Delete { O.dTable = table10
+ , O.dWhere = const $ O.toFields True
+ , O.dReturning = O.rCount }
+ returned <- O.runInsert_ conn O.Insert { O.iTable = table10
+ , O.iRows = insertT
+ , O.iReturning = O.rReturning id
+ , O.iOnConflict = Nothing }
+ extras <- O.runInsert_ conn O.Insert { O.iTable = table10
+ , O.iRows = conflictsT
+ , O.iReturning = O.rReturning id
+ , O.iOnConflict = Just O.DoNothing }
+ moreExtras <- O.runInsert_ conn O.Insert { O.iTable = table10
+ , O.iRows = moreConflictsT
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Just O.DoNothing }
returned `shouldBe` afterInsert
extras `shouldBe` afterConflicts
moreExtras `shouldBe` 1
- runQueryTable10 conn `shouldReturn` allRows
+ runSelectTable10 conn `shouldReturn` allRows
- O.runInsertMany conn table10 insertT `shouldThrow` (\ (_ :: PGS.SqlError) -> True)
+ O.runInsert_ conn O.Insert { O.iTable = table10
+ , O.iRows = insertT
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Nothing }
+ `shouldThrow` (\ (_ :: PGS.SqlError) -> True)
- where insertT :: [Column O.SqlInt4]
+ where insertT :: [Field O.SqlInt4]
insertT = [1, 2]
- conflictsT :: [Column O.SqlInt4]
+ conflictsT :: [Field O.SqlInt4]
conflictsT = [1, 3]
- moreConflictsT :: [Column O.SqlInt4]
+ moreConflictsT :: [Field O.SqlInt4]
moreConflictsT = [3, 4]
afterInsert :: [Int]
@@ -815,12 +865,12 @@ testInsertConflict = it "inserts with conflicts" $ \conn -> do
allRows :: [Int]
allRows = [1, 2, 3, 4]
- runQueryTable10 conn = O.runQuery conn (O.queryTable table10)
+ runSelectTable10 conn = O.runSelect conn (O.selectTable table10)
testKeywordColNames :: Test
testKeywordColNames = it "" $ \conn -> do
let q :: IO [(Int, Int)]
- q = O.runQuery conn (O.queryTable tableKeywordColNames)
+ q = O.runSelect conn (O.selectTable tableKeywordColNames)
_ <- q
True `shouldBe` True
@@ -831,7 +881,7 @@ testInsertSerial = it "" $ \conn -> do
_ <- runInsert conn table5 (Nothing, Nothing)
_ <- runInsert conn table5 (Nothing, Just 40)
- resultI <- O.runQuery conn (O.queryTable table5)
+ resultI <- O.runSelect conn (O.selectTable table5)
resultI `shouldBe` expected
@@ -840,11 +890,15 @@ testInsertSerial = it "" $ \conn -> do
, (30, 1)
, (1, 2)
, (2, 40) ]
- runInsert conn table row = O.runInsertMany conn table [row]
+ runInsert conn table row =
+ O.runInsert_ conn O.Insert { O.iTable = table
+ , O.iRows = [row]
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Nothing }
-testInQuery :: Test
-testInQuery = it "" $ \conn -> do
- let q (x, e) = testH (O.inQuery x (O.queryTable table1)) (`shouldBe` [e]) conn
+testInSelect :: Test
+testInSelect = it "" $ \conn -> do
+ let q (x, e) = testH (O.inSelect x (O.selectTable table1)) (`shouldBe` [e]) conn
mapM_ (q . (\x -> (x, True))) table1dataG
mapM_ (q . (\(x, y) -> ((x, y+1), False))) table1dataG
@@ -852,112 +906,123 @@ testInQuery = it "" $ \conn -> do
-- and r && and s `shouldBe` True
testAtTimeZone :: Test
-testAtTimeZone = it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (`shouldBe` [t'])
- where t = O.pgUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))
+testAtTimeZone =
+ it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.sqlString "CET")))
+ (`shouldBe` [t'])
+ where t = O.sqlUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600))
t' = Time.LocalTime d (Time.TimeOfDay 2 0 0)
d = Time.fromGregorian 2015 1 1
testArrayLiterals :: Test
-testArrayLiterals = it "" $ testH (A.pure $ O.pgArray O.pgInt4 vals) (`shouldBe` [vals])
+testArrayLiterals = it "" $ testH (A.pure $ O.sqlArray O.sqlInt4 vals)
+ (`shouldBe` [vals])
where vals = [1,2,3]
-- This test fails without the explicit cast in pgArray since postgres
-- can't determine the type of the array.
testEmptyArray :: Test
-testEmptyArray = it "" $ testH (A.pure $ O.pgArray O.pgInt4 []) (`shouldBe` [[] :: [Int]])
+testEmptyArray = it "" $ testH (A.pure $ O.sqlArray O.sqlInt4 [])
+ (`shouldBe` [[] :: [Int]])
-- This test fails without the explicit cast in pgArray since postgres
-- defaults the numbers to 'integer' but postgresql-simple expects 'float8'.
testFloatArray :: Test
-testFloatArray = it "" $ testH (A.pure $ O.pgArray O.pgDouble doubles) (`shouldBe` [doubles])
+testFloatArray = it "" $ testH (A.pure $ O.sqlArray O.sqlDouble doubles)
+ (`shouldBe` [doubles])
where
doubles = [1 :: Double, 2]
testArrayIndex :: Test
testArrayIndex = it "correctly indexes an array" $
- testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 3)
+ testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7] `O.index` O.sqlInt4 3)
(`shouldBe` ([Just 7] :: [Maybe Int]))
testArrayIndexOOB :: Test
testArrayIndexOOB = it "returns Nothing when the index is out of bounds" $
- testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.index` O.pgInt4 8)
+ testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7] `O.index` O.sqlInt4 8)
(`shouldBe` ([Nothing] :: [Maybe Int]))
testSingletonArray :: Test
testSingletonArray = it "constructs a singleton PGInt8 array" $
- testH (A.pure $ O.singletonArray (O.pgInt8 1))
+ testH (A.pure $ O.singletonArray (O.sqlInt8 1))
(`shouldBe` ([[1]] :: [[Int64]]))
testArrayAppend :: Test
testArrayAppend = it "appends two arrays" $
- testH (A.pure $ O.pgArray O.pgInt4 [5,6,7] `O.arrayAppend` O.pgArray O.pgInt4 [1,2,3])
+ testH (A.pure $ O.sqlArray O.sqlInt4 [5,6,7]
+ `O.arrayAppend` O.sqlArray O.sqlInt4 [1,2,3])
(`shouldBe` ([[5,6,7,1,2,3]] :: [[Int]]))
-type JsonTest a = SpecWith (Query (Column a) -> PGS.Connection -> Expectation)
+type JsonTest a = SpecWith (Select (Field a) -> PGS.Connection -> Expectation)
-- Test opaleye's equivalent of c1->'c'
-testJsonGetFieldValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
-testJsonGetFieldValue dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c"
+testJsonGetFieldValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)
+ => Select (Field a) -> Test
+testJsonGetFieldValue dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "c"
expected :: [Maybe Json.Value]
- expected = [Just $ Json.Number $ fromInteger 21]
+ expected = [Just $ Json.Number 21]
-- Test opaleye's equivalent of c1->>'c'
-testJsonGetFieldText :: (O.SqlIsJson a) => Query (Column a) -> Test
-testJsonGetFieldText dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c"
+testJsonGetFieldText :: (O.SqlIsJson a) => Select (Field a) -> Test
+testJsonGetFieldText dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..->> O.sqlStrictText "c"
expected :: [Maybe T.Text]
expected = [Just "21"]
--- Special Test for Github Issue #350 : https://github.com/tomjaguarpaw/haskell-opaleye/issues/350
-testRestrictWithJsonOp :: (O.SqlIsJson a) => Query (Column a) -> Test
-testRestrictWithJsonOp dataQuery = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH query (`shouldBe` table8data)
- where query = dataQuery >>> proc col1 -> do
+-- Special Test for Github Issue #350 :
+-- https://github.com/tomjaguarpaw/haskell-opaleye/issues/350
+testRestrictWithJsonOp :: (O.SqlIsJson a) => Select (Field a) -> Test
+testRestrictWithJsonOp dataSelect = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH select (`shouldBe` table8data)
+ where select = dataSelect >>> proc col1 -> do
t <- table8Q -< ()
- O.restrict -< (O.toNullable col1 O..->> O.pgStrictText "c") .== O.toNullable (O.pgStrictText "21")
+ O.restrict -< (O.toNullable col1 O..->> O.sqlStrictText "c")
+ .== O.toNullable (O.sqlStrictText "21")
Arr.returnA -< t
-- Test opaleye's equivalent of c1->'a'->2
-testJsonGetArrayValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
-testJsonGetArrayValue dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..-> O.pgInt4 2
+testJsonGetArrayValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)
+ => Select (Field a) -> Test
+testJsonGetArrayValue dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "a" O..-> O.sqlInt4 2
expected :: [Maybe Json.Value]
- expected = [Just $ Json.Number $ fromInteger 30]
+ expected = [Just $ Json.Number 30]
-- Test opaleye's equivalent of c1->'a'->>2
-testJsonGetArrayText :: (O.SqlIsJson a) => Query (Column a) -> Test
-testJsonGetArrayText dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..->> O.pgInt4 2
+testJsonGetArrayText :: (O.SqlIsJson a) => Select (Field a) -> Test
+testJsonGetArrayText dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..-> O.sqlStrictText "a" O..->> O.sqlInt4 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.SqlIsJson a) => Query (Column a) -> Test
-testJsonGetMissingField dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing"
+testJsonGetMissingField :: (O.SqlIsJson a) => Select (Field a) -> Test
+testJsonGetMissingField dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..->> O.sqlStrictText "missing"
expected :: [Maybe T.Text]
expected = [Nothing]
-- Test opaleye's equivalent of c1#>'{b,x}'
-testJsonGetPathValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test
-testJsonGetPathValue dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..#> O.pgArray O.pgStrictText ["b", "x"]
+testJsonGetPathValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)
+ => Select (Field a) -> Test
+testJsonGetPathValue dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..#> O.sqlArray O.sqlStrictText ["b", "x"]
expected :: [Maybe Json.Value]
- expected = [Just $ Json.Number $ fromInteger 42]
+ expected = [Just $ Json.Number 42]
-- Test opaleye's equivalent of c1#>>'{b,x}'
-testJsonGetPathText :: (O.SqlIsJson a) => Query (Column a) -> Test
-testJsonGetPathText dataQuery = it "" $ testH q (`shouldBe` expected)
- where q = dataQuery >>> proc c1 -> do
- Arr.returnA -< O.toNullable c1 O..#>> O.pgArray O.pgStrictText ["b", "x"]
+testJsonGetPathText :: (O.SqlIsJson a) => Select (Field a) -> Test
+testJsonGetPathText dataSelect = it "" $ testH q (`shouldBe` expected)
+ where q = dataSelect >>> proc c1 -> do
+ Arr.returnA -< O.toNullable c1 O..#>> O.sqlArray O.sqlStrictText ["b", "x"]
expected :: [Maybe T.Text]
expected = [Just "42"]
@@ -965,96 +1030,99 @@ testJsonGetPathText dataQuery = it "" $ testH q (`shouldBe` expected)
testJsonbRightInLeft :: Test
testJsonbRightInLeft = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< c1 O..@> O.pgJSONB "{\"c\":21}"
+ Arr.returnA -< c1 O..@> O.sqlJSONB "{\"c\":21}"
-- Test opaleye's equivalent of '{"c":21}'::jsonb <@ c1
testJsonbLeftInRight :: Test
testJsonbLeftInRight = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< O.pgJSONB "{\"c\":21}" O..<@ c1
+ Arr.returnA -< O.sqlJSONB "{\"c\":21}" O..<@ c1
-- Test opaleye's equivalent of c1 ? 'b'
testJsonbContains :: Test
testJsonbContains = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< c1 O..? O.pgStrictText "c"
+ Arr.returnA -< c1 O..? O.sqlStrictText "c"
-- Test opaleye's equivalent of c1 ? 'missing'
-- Note that the missing field does not exist.
testJsonbContainsMissing :: Test
testJsonbContainsMissing = it "" $ testH q (`shouldBe` [False])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< c1 O..? O.pgStrictText "missing"
+ Arr.returnA -< c1 O..? O.sqlStrictText "missing"
-- Test opaleye's equivalent of c1 ?| array['b', 'missing']
testJsonbContainsAny :: Test
testJsonbContainsAny = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< c1 O..?| O.pgArray O.pgStrictText ["b", "missing"]
+ Arr.returnA -< c1 O..?| O.sqlArray O.sqlStrictText ["b", "missing"]
-- Test opaleye's equivalent of c1 ?& array['a', 'b', 'c']
testJsonbContainsAll :: Test
testJsonbContainsAll = it "" $ testH q (`shouldBe` [True])
where q = table9Q >>> proc c1 -> do
- Arr.returnA -< c1 O..?& O.pgArray O.pgStrictText ["a", "b", "c"]
+ Arr.returnA -< c1 O..?& O.sqlArray O.sqlStrictText ["a", "b", "c"]
testRangeOverlap :: Test
testRangeOverlap = it "generates overlap" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
- q = A.pure $ (range 3 7) `O.overlap` (range 4 12)
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)
+ q = A.pure (range 3 7 `O.overlap` range 4 12)
testRangeDateOverlap :: Test
testRangeDateOverlap = it "generates time overlap" $ \conn -> do
let date = Time.fromGregorian 2015 1 1
now = Time.UTCTime date (Time.secondsToDiffTime 3600)
later = Time.addUTCTime 10 now
- range1 = O.pgRange O.pgUTCTime (R.Inclusive now) (R.Exclusive later)
- range2 = O.pgRange O.pgUTCTime R.NegInfinity R.PosInfinity
- rangeNow = O.pgRange O.pgUTCTime (R.Inclusive now) (R.Inclusive now)
+ range1 = O.sqlRange O.sqlUTCTime (R.Inclusive now) (R.Exclusive later)
+ range2 = O.sqlRange O.sqlUTCTime R.NegInfinity R.PosInfinity
+ rangeNow = O.sqlRange O.sqlUTCTime (R.Inclusive now) (R.Inclusive now)
qOverlap r = A.pure $ r `O.overlap` rangeNow
testH (qOverlap range1) (`shouldBe` [True]) conn
testH (qOverlap range2) (`shouldBe` [True]) conn
- testH (A.pure $ O.pgUTCTime now `O.liesWithin` range1) (`shouldBe` [True]) conn
- testH (A.pure $ O.pgUTCTime later `O.liesWithin` range1) (`shouldBe` [False]) conn
+ testH (A.pure $ O.sqlUTCTime now `O.liesWithin` range1) (`shouldBe` [True]) conn
+ testH (A.pure $ O.sqlUTCTime later `O.liesWithin` range1) (`shouldBe` [False]) conn
testRangeLeftOf :: Test
testRangeLeftOf = it "generates 'left of'" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
- q = A.pure $ (range 1 10) O..<< (range 100 110)
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)
+ q = A.pure (range 1 10 O..<< range 100 110)
testRangeRightOf :: Test
testRangeRightOf = it "generates 'right of'" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
- q = A.pure $ (range 50 60) O..>> (range 20 30)
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)
+ q = A.pure (range 50 60 O..>> range 20 30)
testRangeRightExtension :: Test
-testRangeRightExtension = it "generates right extension" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
- q = A.pure $ (range 1 20) O..&< (range 18 20)
+testRangeRightExtension = it "generates right extension" $
+ testH q (`shouldBe` [True])
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)
+ q = A.pure (range 1 20 O..&< range 18 20)
testRangeLeftExtension :: Test
-testRangeLeftExtension = it "generates left extension" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b)
- q = A.pure $ (range 7 20) O..&> (range 5 10)
+testRangeLeftExtension = it "generates left extension" $
+ testH q (`shouldBe` [True])
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Inclusive b)
+ q = A.pure (range 7 20 O..&> range 5 10)
testRangeAdjacency :: Test
testRangeAdjacency = it "generates adjacency" $ testH q (`shouldBe` [True])
- where range :: Int -> Int -> Column (O.PGRange O.SqlInt4)
- range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b)
- q = A.pure $ (range 1 2) O..-|- (range 2 3)
+ where range :: Int -> Int -> Field (O.SqlRange O.SqlInt4)
+ range a b = O.sqlRange O.sqlInt4 (R.Inclusive a) (R.Exclusive b)
+ q = A.pure (range 1 2 O..-|- range 2 3)
testRangeBoundsEnum :: forall a b.
( Show a, Eq a, Enum a, O.IsRangeType b
- , O.QueryRunnerColumnDefault (Nullable b) (Maybe a))
- => String -> (a -> Column b) -> a -> a -> Test
+ , DefaultFromField b a )
+ => String -> (a -> Field b) -> a -> a -> Test
testRangeBoundsEnum msg mkCol x y = it msg $ \conn -> do
- -- bound functions for discrete range types return fields as from the form [x,y)
- let pgr = O.pgRange mkCol
+ -- bound functions for discrete range types return fields as from
+ -- the form [x,y)
+ let pgr = O.sqlRange mkCol
ranges_expecteds =
[ (pgr (R.Inclusive x) R.PosInfinity, (Just x, Nothing))
, (pgr R.NegInfinity (R.Inclusive y), (Nothing, Just $ succ y))
@@ -1063,11 +1131,11 @@ testRangeBoundsEnum msg mkCol x y = it msg $ \conn -> do
ranges = map fst ranges_expecteds
expecteds = map ((:[]) . snd) ranges_expecteds
- r <- mapM (O.runQuery conn . pure . (O.lowerBound &&& O.upperBound)) ranges
+ r <- mapM (O.runSelect conn . pure . (O.lowerBound &&& O.upperBound)) ranges
r `shouldBe` expecteds
-jsonTests :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value)
- => Query (Column a) -> Test
+jsonTests :: (O.SqlIsJson a, DefaultFromField a Json.Value)
+ => Select (Field a) -> Test
jsonTests t = do
testJsonGetFieldValue t
testJsonGetFieldText t
@@ -1099,6 +1167,21 @@ testLiterals = do
testH (pure (O.sqlZonedTime value))
(\r -> map Time.zonedTimeToUTC r `shouldBe` [Time.zonedTimeToUTC value])
+-- Check that MaybeFields's "Nothings" are not distinct, even if we
+-- fmap different values over their inner fields.
+testMaybeFieldsDistinct :: Test
+testMaybeFieldsDistinct = do
+ it "MaybeFields distinct" $ testH query (`shouldBe` [Nothing :: Maybe Int])
+ it "MaybeFields equality" $ testH query2 (`shouldBe` [True])
+ where nothing_ = OM.nothingFields :: MaybeFields ()
+ query :: Select (MaybeFields (Field O.SqlInt4))
+ query = O.distinct (O.valuesSafe [ fmap (const 0) nothing_
+ , fmap (const 1) nothing_ ])
+ query2 :: Select (Field O.SqlBool)
+ query2 = pure ((fmap (const (0 :: Field O.SqlInt4)) nothing_)
+ O..=== fmap (const (1 :: Field O.SqlInt4)) nothing_)
+
+
main :: IO ()
main = do
let envVarName = "POSTGRES_CONNSTRING"
@@ -1110,33 +1193,45 @@ main = do
`Dotenv.onMissingFile`
return Nothing
- let connectString = connectStringEnvVar <|> connectStringDotEnv
+ let mconnectString = connectStringEnvVar <|> connectStringDotEnv
- conn <- maybe
+ connectString <- maybe
(fail ("Set " ++ envVarName ++ " environment variable\n"
++ "For example " ++ envVarName ++ "='user=tom dbname=opaleye_test "
++ "host=localhost port=25433 password=tom'"))
- (PGS.connectPostgreSQL . String.fromString)
- connectString
+ (pure . String.fromString)
+ mconnectString
- dropAndCreateDB conn
-
- let insert (t, d) = do { _ <- O.runInsertMany conn t d; return () }
+ conn <- PGS.connectPostgreSQL connectString
- mapM_ insert [ (table1, table1columndata)
- , (table2, table2columndata)
- , (table3, table3columndata)
- , (table4, table4columndata) ]
- insert (table6, table6columndata)
- insert (table7, table7columndata)
- insert (table8, table8columndata)
- insert (table9, table9columndata)
+ dropAndCreateDB conn
+ let insert (t, d) = do {
+ _ <- O.runInsert_ conn O.Insert { O.iTable = t
+ , O.iRows = d
+ , O.iReturning = O.rCount
+ , O.iOnConflict = Nothing }
+ ; return () }
+
+ mapM_ insert [ (table1, table1fielddata)
+ , (table2, table2fielddata)
+ , (table3, table3fielddata)
+ , (table4, table4fielddata) ]
+ insert (table6, table6fielddata)
+ insert (table7, table7fielddata)
+ insert (table8, table8fielddata)
+ insert (table9, table9fielddata)
+
+ PGS.close conn
+
+ conn2 <- Connection.connectPostgreSQL connectString
-- Need to run quickcheck after table data has been inserted
- QuickCheck.run conn
+ QuickCheck.run conn2
+ Connection.close conn2
+ conn3 <- PGS.connectPostgreSQL connectString
hspec $ do
- before (return conn) $ do
+ before (return conn3) $ do
describe "core dsl?" $ do
testSelect
testProduct
@@ -1208,7 +1303,7 @@ main = do
describe "uncat" $ do
testKeywordColNames
testInsertSerial
- testInQuery
+ testInSelect
testAtTimeZone
testUnionAll
testTableFunctor
@@ -1226,8 +1321,10 @@ main = do
testRangeLeftExtension
testRangeAdjacency
testRangeBoundsEnum "can access bounds from an Int8 range"
- O.pgInt8 10 26
+ O.sqlInt8 10 26
testRangeBoundsEnum "can access bounds from a date range"
- O.pgDay (read "2018-01-01") (read "2018-01-12")
+ O.sqlDay (read "2018-01-01") (read "2018-01-12")
describe "literals" $ do
testLiterals
+ describe "MaybeFields" $ do
+ testMaybeFieldsDistinct
diff --git a/Test/TypeFamilies.hs b/Test/TypeFamilies.hs
index 427dd28..3f36a73 100644
--- a/Test/TypeFamilies.hs
+++ b/Test/TypeFamilies.hs
@@ -18,4 +18,4 @@ tests = ()
:~ (((->) :<$> Pure a :<*> Pure b) :<| c)
_ = Eq :: Maybe a :~ ((Maybe :<$> Pure a) :<| b)
_ = Eq :: Maybe a :~ ((Maybe :<$> Id) :<| a)
- _ = Eq :: a :~ ((Pure a) :<| b)
+ _ = Eq :: a :~ (Pure a :<| b)
diff --git a/Test/Wrapped.hs b/Test/Wrapped.hs
new file mode 100644
index 0000000..22e3c4a
--- /dev/null
+++ b/Test/Wrapped.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module Wrapped where
+
+import Control.Arrow (arr, (<<<))
+import qualified Control.Arrow as Arrow
+import qualified Control.Category
+import Control.Category (Category)
+import qualified Data.Functor.Contravariant as C
+import qualified Data.Functor.Contravariant.Divisible as D
+import qualified Data.Profunctor as P
+import qualified Data.Profunctor.Product as PP
+
+data WrappedSumProfunctor p a b where
+ WrappedSumProfunctor :: p a b -> WrappedSumProfunctor p a b
+ WrappedSumProfunctorId :: WrappedSumProfunctor p a a
+ WrappedSumProfunctorArr :: (a -> b) -> WrappedSumProfunctor p a b
+ WrappedSumProfunctorCompose :: WrappedSumProfunctor p b c
+ -> WrappedSumProfunctor p a b
+ -> WrappedSumProfunctor p a c
+ WrappedSumProfunctorChoice ::
+ WrappedSumProfunctor p a a'
+ -> WrappedSumProfunctor p b b'
+ -> WrappedSumProfunctor p (Either a b) (Either a' b')
+
+newtype WrappedDecidable f a b =
+ WrappedDecidable { unWrappedDecidable :: f a }
+
+instance C.Contravariant f => P.Profunctor (WrappedDecidable f) where
+ dimap f _ = WrappedDecidable . C.contramap f . unWrappedDecidable
+
+instance D.Decidable f => PP.SumProfunctor (WrappedDecidable f) where
+ f1 +++! f2 =
+ WrappedDecidable (D.choose id (unWrappedDecidable f1)
+ (unWrappedDecidable f2))
+
+constructor :: P.Profunctor p
+ => (b -> c) -> p a b -> WrappedSumProfunctor p a c
+constructor c p = P.rmap c (WrappedSumProfunctor p)
+
+constructorDecidable :: D.Decidable f
+ => f a
+ -> WrappedSumProfunctor (WrappedDecidable f) a c
+constructorDecidable f = WrappedSumProfunctor (WrappedDecidable f)
+
+asSumProfunctor :: PP.SumProfunctor p
+ => WrappedSumProfunctor p a b -> p a b
+asSumProfunctor w = case unWrappedSumProfunctorE w of
+ Left p -> p
+ Right _ -> error "unWrappedSumProfunctor was function"
+
+asDecidable :: D.Decidable f
+ => WrappedSumProfunctor (WrappedDecidable f) a b -> f a
+asDecidable = unWrappedDecidable . asSumProfunctor
+
+unWrappedSumProfunctorE :: PP.SumProfunctor p
+ => WrappedSumProfunctor p a b -> Either (p a b) (a -> b)
+unWrappedSumProfunctorE = \case
+ WrappedSumProfunctor p -> Left p
+ WrappedSumProfunctorId -> Right id
+ WrappedSumProfunctorArr f -> Right f
+ WrappedSumProfunctorCompose w1 w2 ->
+ case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of
+ (Left _, Left _) -> error "Composing two profunctors"
+ (Right f, Left p) -> Left (P.rmap f p)
+ (Left p, Right f) -> Left (P.lmap f p)
+ (Right f1, Right f2) -> Right (f1 . f2)
+
+ WrappedSumProfunctorChoice w1 w2 ->
+ case (unWrappedSumProfunctorE w1, unWrappedSumProfunctorE w2) of
+ (Left p1, Left p2) -> Left (p1 PP.+++! p2)
+ _ -> error "WrappedSumProfunctorChoice"
+
+instance Category (WrappedSumProfunctor p) where
+ id = WrappedSumProfunctorId
+ (.) = WrappedSumProfunctorCompose
+
+instance Arrow.Arrow (WrappedSumProfunctor p) where
+ arr = WrappedSumProfunctorArr
+ first = error "WrappedSumProfunctor first"
+
+instance PP.SumProfunctor p => Arrow.ArrowChoice (WrappedSumProfunctor p) where
+ (+++) = WrappedSumProfunctorChoice
+
+instance P.Profunctor p => P.Profunctor (WrappedSumProfunctor p) where
+ dimap f g w = arr g <<< w <<< arr f
diff --git a/opaleye.cabal b/opaleye.cabal
index e91883c..b8cb237 100644
--- a/opaleye.cabal
+++ b/opaleye.cabal
@@ -1,6 +1,6 @@
name: opaleye
copyright: Copyright (c) 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis
-version: 0.6.7004.2
+version: 0.6.7005.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
@@ -28,7 +28,7 @@ library
default-language: Haskell2010
hs-source-dirs: src
build-depends:
- aeson >= 0.6 && < 1.5
+ aeson >= 0.6 && < 1.6
, base >= 4.9 && < 5
, base16-bytestring >= 0.1.1.6 && < 0.2
, case-insensitive >= 1.2 && < 1.3
@@ -36,7 +36,7 @@ library
, contravariant >= 1.2 && < 1.6
, postgresql-simple >= 0.5.3 && < 0.7
, pretty >= 1.1.1.0 && < 1.2
- , product-profunctors >= 0.6.2 && < 0.11
+ , product-profunctors >= 0.8.0.0 && < 0.11
, profunctors >= 4.0 && < 5.6
, scientific >= 0.3 && < 0.4
, semigroups >= 0.13 && < 0.20
@@ -47,6 +47,7 @@ library
, uuid >= 1.3 && < 1.4
, void >= 0.4 && < 0.8
exposed-modules: Opaleye,
+ Opaleye.Adaptors,
Opaleye.Aggregate,
Opaleye.Binary,
Opaleye.Column,
@@ -56,8 +57,10 @@ library
Opaleye.FunctionalJoin,
Opaleye.Join,
Opaleye.Label,
+ Opaleye.Lateral,
Opaleye.Manipulation,
Opaleye.Map,
+ Opaleye.MaybeFields,
Opaleye.Operators,
Opaleye.Order,
Opaleye.PGTypes,
@@ -78,7 +81,9 @@ library
Opaleye.Internal.Helpers,
Opaleye.Internal.Join,
Opaleye.Internal.Label,
+ Opaleye.Internal.Lateral,
Opaleye.Internal.Manipulation,
+ Opaleye.Internal.MaybeFields,
Opaleye.Internal.Order,
Opaleye.Internal.Operators,
Opaleye.Internal.Optimize,
@@ -106,12 +111,17 @@ test-suite test
default-language: Haskell2010
type: exitcode-stdio-1.0
main-is: Test.hs
- other-modules: QuickCheck,
- TypeFamilies
+ other-modules: Connection,
+ Opaleye.Test.Arbitrary,
+ Opaleye.Test.Fields,
+ QuickCheck,
+ TypeFamilies,
+ Wrapped
hs-source-dirs: Test
build-depends:
- aeson >= 0.6 && < 1.5,
+ aeson >= 0.6 && < 1.6,
base >= 4 && < 5,
+ bytestring,
containers,
contravariant,
dotenv >= 0.3.1,
diff --git a/src/Opaleye.hs b/src/Opaleye.hs
index 7d8816d..47ca81e 100644
--- a/src/Opaleye.hs
+++ b/src/Opaleye.hs
@@ -13,7 +13,8 @@
-- * If you are confused about the @Default@ typeclass, then
-- the <https://github.com/tomjaguarpaw/haskell-opaleye/blob/master/Doc/Tutorial/DefaultExplanation.lhs Default explanation>
-module Opaleye ( module Opaleye.Aggregate
+module Opaleye ( module Opaleye.Adaptors
+ , module Opaleye.Aggregate
, module Opaleye.Binary
, module Opaleye.Column
, module Opaleye.Constant
@@ -22,7 +23,9 @@ module Opaleye ( module Opaleye.Aggregate
, module Opaleye.FunctionalJoin
, module Opaleye.Join
, module Opaleye.Label
+ , module Opaleye.Lateral
, module Opaleye.Manipulation
+ , module Opaleye.MaybeFields
, module Opaleye.Operators
, module Opaleye.Order
, module Opaleye.PGTypes
@@ -33,9 +36,11 @@ module Opaleye ( module Opaleye.Aggregate
, module Opaleye.Select
, module Opaleye.SqlTypes
, module Opaleye.Table
+ , module Opaleye.ToFields
, module Opaleye.Values
) where
+import Opaleye.Adaptors
import Opaleye.Aggregate
import Opaleye.Binary
import Opaleye.Column
@@ -50,8 +55,12 @@ import Opaleye.Field
maybeToNullable)
import Opaleye.FunctionalJoin
import Opaleye.Join
+ hiding (optional)
import Opaleye.Label
+import Opaleye.Lateral
import Opaleye.Manipulation
+import Opaleye.MaybeFields
+ hiding (optional)
import Opaleye.Operators
import Opaleye.Order
import Opaleye.PGTypes
@@ -66,4 +75,5 @@ import Opaleye.Select
import Opaleye.Sql
import Opaleye.SqlTypes
import Opaleye.Table
+import Opaleye.ToFields
import Opaleye.Values
diff --git a/src/Opaleye/Adaptors.hs b/src/Opaleye/Adaptors.hs
new file mode 100644
index 0000000..f335709
--- /dev/null
+++ b/src/Opaleye/Adaptors.hs
@@ -0,0 +1,84 @@
+-- We have the following groups. Groups could be merged into one.
+--
+-- - p (Column a) (Column a)
+-- Not SumProfunctor
+-- Not SqlType a
+-- - Binaryspec
+-- - IfPP
+--
+-- - p (Column a) (Column a)
+-- Not SumProfunctor
+-- Is SqlType a
+-- - Valuesspec
+--
+-- - p (Column a) (Column a)
+-- Is SumProfunctor
+-- Not SqlType a
+-- - Distinctspec
+-- - Unpackspec
+--
+-- - p (Column a) b
+-- - EqPP
+--
+-- - p a (Column b)
+-- Is SqlType b
+-- - Nullspec
+
+module Opaleye.Adaptors
+ (
+ -- * Binaryspec
+ Binaryspec,
+ binaryspecField,
+ binaryspecMaybeFields,
+ -- * Distinctspec
+ Distinctspec,
+ distinctspecField,
+ distinctspecMaybeFields,
+ -- * EqPP
+ EqPP,
+ eqPPField,
+ eqPPMaybeFields,
+ -- * IfPP
+ IfPP,
+ ifPPField,
+ ifPPMaybeFields,
+ -- * FromFields
+ FromFields,
+ fromFieldsMaybeFields,
+ -- * Nullspec
+ Nullspec,
+ nullspecField,
+ nullspecMaybeFields,
+ nullspecList,
+ nullspecEitherLeft,
+ nullspecEitherRight,
+ -- * ToFields
+ ToFields,
+ toFieldsMaybeFields,
+ -- * Unpackspec
+ Unpackspec,
+ unpackspecField,
+ unpackspecMaybeFields,
+ -- * Updater
+ Updater,
+ -- * Valuesspec
+ ValuesspecSafe,
+ valuesspecField,
+ valuesspecMaybeFields,
+ -- * WithNulls
+ WithNulls,
+ )
+where
+
+import Opaleye.Internal.Unpackspec
+import Opaleye.Internal.Binary
+import Opaleye.Internal.Manipulation
+import Opaleye.Internal.Operators
+import Opaleye.Internal.MaybeFields
+
+import Opaleye.Binary
+import Opaleye.Distinct
+import Opaleye.ToFields
+import Opaleye.MaybeFields
+import Opaleye.RunSelect
+import Opaleye.Values
diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs
index e1fc63e..2f92785 100644
--- a/src/Opaleye/Aggregate.hs
+++ b/src/Opaleye/Aggregate.hs
@@ -53,14 +53,17 @@ import qualified Opaleye.Join as J
{-|
Given a 'S.Select' producing rows of type @a@ and an 'Aggregator' accepting rows of
-type @a@, apply the aggregator to the query.
+type @a@, apply the aggregator to the select.
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' ->
-'S.SelectArr' a b -> 'S.SelectArr' a b'@. Such a function would allow violation
-of SQL's scoping rules and lead to invalid queries.
+If you want to use 'aggregate' with 'S.SelectArr's then you should
+compose it with 'Opaleye.Lateral.laterally':
+
+@
+'Opaleye.Lateral.laterally' . 'aggregate' :: 'Aggregator' a b -> 'S.SelectArr' a b -> 'S.SelectArr' a b
+@
Please note that when aggregating an empty query with no @GROUP BY@
clause, Opaleye's behaviour differs from Postgres's behaviour.
@@ -72,7 +75,7 @@ result of an aggregation.
-}
aggregate :: Aggregator a b -> S.Select a -> S.Select b
-aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)
+aggregate agg q = Q.productQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)
-- | Order the values within each aggregation in `Aggregator` using
-- the given ordering. This is only relevant for aggregations that
@@ -129,7 +132,8 @@ boolAnd = A.makeAggr HPQ.AggrBoolAnd
arrayAgg :: Aggregator (C.Column a) (C.Column (T.SqlArray a))
arrayAgg = A.makeAggr HPQ.AggrArr
-stringAgg :: C.Column T.SqlText -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText)
+stringAgg :: C.Column T.SqlText
+ -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText)
stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn
-- | Count the number of rows in a query. This is different from
diff --git a/src/Opaleye/Binary.hs b/src/Opaleye/Binary.hs
index b157db7..560cb97 100644
--- a/src/Opaleye/Binary.hs
+++ b/src/Opaleye/Binary.hs
@@ -18,10 +18,15 @@
-- -> S.Select (Foo (Field a) (Field b) (Field c))
-- @
--
--- Please note that by design there are no binary relational functions
--- of type @S.SelectArr a b -> S.SelectArr a b -> S.SelectArr a b@. Such
--- functions would allow violation of SQL's scoping rules and lead to
--- invalid queries.
+-- If you want to run a binary relational operator on
+-- 'Select.SelectArr's you should apply 'Opaleye.Lateral.bilaterally'
+-- to it, for example
+--
+-- @
+-- 'Opaleye.Lateral.bilaterally' 'union'
+-- :: 'Data.Profunctor.Product.Default' 'B.Binaryspec' fields fields
+-- => 'S.SelectArr' i fields -> 'S.SelectArr' i fields -> 'S.SelectArr' i fields
+-- @
--
-- `unionAll` is very close to being the @\<|\>@ operator of a
-- @Control.Applicative.Alternative@ instance but it fails to work
@@ -32,6 +37,7 @@
module Opaleye.Binary where
import qualified Opaleye.Internal.Binary as B
+import qualified Opaleye.Internal.Column
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Select as S
@@ -43,7 +49,7 @@ unionAll :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
unionAll = unionAllExplicit def
--- | The same as unionAll, except that it additionally removes any
+-- | The same as 'unionAll', except that it additionally removes any
-- duplicate rows.
union :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
@@ -53,7 +59,7 @@ intersectAll :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
intersectAll = intersectAllExplicit def
--- | The same as intersectAll, except that it additionally removes any
+-- | The same as 'intersectAll', except that it additionally removes any
-- duplicate rows.
intersect :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
@@ -63,7 +69,7 @@ exceptAll :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
exceptAll = exceptAllExplicit def
--- | The same as exceptAll, except that it additionally removes any
+-- | The same as 'exceptAll', except that it additionally removes any
-- duplicate rows.
except :: Default B.Binaryspec fields fields =>
S.Select fields -> S.Select fields -> S.Select fields
@@ -94,3 +100,10 @@ exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll
exceptExplicit :: B.Binaryspec fields fields'
-> S.Select fields -> S.Select fields -> S.Select fields'
exceptExplicit = B.sameTypeBinOpHelper PQ.Except
+
+-- * Adaptors
+
+binaryspecField :: (B.Binaryspec
+ (Opaleye.Internal.Column.Column a)
+ (Opaleye.Internal.Column.Column a))
+binaryspecField = B.binaryspecColumn
diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs
index f08604c..57bd373 100644
--- a/src/Opaleye/Column.hs
+++ b/src/Opaleye/Column.hs
@@ -1,10 +1,13 @@
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
--- | Functions for working directly with 'Column's.
+-- | Do not use. Will be deprecated in version 0.7. Use
+-- "Opaleye.Field" instead.
+--
+-- Functions for working directly with 'Column's.
--
-- Please note that numeric 'Column' types are instances of 'Num', so
-- you can use '*', '/', '+', '-' on them.
--
--- 'Column' will be renamed to "Opaelye.Field.Field_" in version 0.7,
+-- 'Column' will be renamed to 'Opaleye.Field.Field_' in version 0.7,
-- so you might want to use the latter as much as you can.
module Opaleye.Column (-- * 'Column'
diff --git a/src/Opaleye/Distinct.hs b/src/Opaleye/Distinct.hs
index f48e353..0f34f6f 100644
--- a/src/Opaleye/Distinct.hs
+++ b/src/Opaleye/Distinct.hs
@@ -1,10 +1,16 @@
{-# LANGUAGE FlexibleContexts #-}
-module Opaleye.Distinct (module Opaleye.Distinct, distinctExplicit)
+module Opaleye.Distinct (module Opaleye.Distinct, Distinctspec,
+ -- * Explicit versions
+ distinctExplicit,
+ -- * Adaptors
+ distinctspecField,
+ distinctspecMaybeFields,
+ )
where
import Opaleye.Select (Select)
-import Opaleye.Internal.Distinct (distinctExplicit, Distinctspec)
+import Opaleye.Internal.Distinct
import qualified Data.Profunctor.Product.Default as D
@@ -22,9 +28,12 @@ import qualified Data.Profunctor.Product.Default as D
-- distinct :: Select (Foo (Field a) (Field b) (Field c)) -> Select (Foo (Field a) (Field b) (Field c))
-- @
--
--- By design there is no @distinct@ function of type @SelectArr a b ->
--- SelectArr a b@. Such a function would allow violation of SQL's
--- scoping rules and lead to invalid queries.
+-- If you want to run 'distinct' on 'Select.SelectArr's you should
+-- apply 'Opaleye.Lateral.laterally' to it:
+--
+-- @
+-- 'Opaleye.Lateral.laterally' 'distinct' :: 'Data.Profunctor.Product.Default' 'Distinctspec' fields fields => 'Opaleye.Select.SelectArr' i fields -> 'Opaleye.Select.SelectArr' i fields
+-- @
distinct :: D.Default Distinctspec fields fields =>
Select fields -> Select fields
distinct = distinctExplicit D.def
diff --git a/src/Opaleye/Field.hs b/src/Opaleye/Field.hs
index ec02ec4..94c448c 100644
--- a/src/Opaleye/Field.hs
+++ b/src/Opaleye/Field.hs
@@ -80,3 +80,6 @@ toNullable = C.unsafeCoerceColumn
maybeToNullable :: Maybe (Field_ 'NonNullable a)
-> Field_ 'Nullable a
maybeToNullable = C.maybeToNullable
+
+unsafeCoerceField :: C.Column a -> C.Column b
+unsafeCoerceField = C.unsafeCoerceColumn
diff --git a/src/Opaleye/FunctionalJoin.hs b/src/Opaleye/FunctionalJoin.hs
index 1eed381..a43e513 100644
--- a/src/Opaleye/FunctionalJoin.hs
+++ b/src/Opaleye/FunctionalJoin.hs
@@ -1,8 +1,6 @@
--- | Left, right, and full outer joins.
---
--- The interface in this module is much nicer than the standard \"make
--- missing rows NULL\" interface that SQL provides. If you really
--- want the standard interface then use "Opaleye.Join".
+-- | Alternative APIs to inner, left, right, and full outer joins.
+-- See "Opaleye.Join" for details on the best way to do joins in
+-- Opaleye.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
diff --git a/src/Opaleye/Internal/Aggregate.hs b/src/Opaleye/Internal/Aggregate.hs
index 9e6c724..79d6503 100644
--- a/src/Opaleye/Internal/Aggregate.hs
+++ b/src/Opaleye/Internal/Aggregate.hs
@@ -27,14 +27,15 @@ An 'Aggregator' corresponds closely to a 'Control.Foldl.Fold' from the
type @a@ to a single row of type @b@, a 'Control.Foldl.Fold' @a@ @b@
takes a list of @a@ and returns a single value of type @b@.
-}
-newtype Aggregator a b = Aggregator
- (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr],HPQ.AggrDistinct), HPQ.PrimExpr)
- HPQ.PrimExpr
- a b)
+newtype Aggregator a b =
+ Aggregator (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),
+ HPQ.PrimExpr)
+ HPQ.PrimExpr
+ a b)
makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)
-makeAggr' m = Aggregator (PM.PackMap
- (\f (C.Column e) -> fmap C.Column (f (fmap (,[],HPQ.AggrAll) m, e))))
+makeAggr' mAggrOp = Aggregator (PM.PackMap
+ (\f (C.Column e) -> fmap C.Column (f (fmap (, [], HPQ.AggrAll) mAggrOp, e))))
makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)
makeAggr = makeAggr' . Just
@@ -73,25 +74,60 @@ makeAggr = makeAggr' . Just
-- @
orderAggregate :: O.Order a -> Aggregator a b -> Aggregator a b
-orderAggregate o (Aggregator (PM.PackMap pm)) =
- Aggregator (PM.PackMap (\f c -> pm (f . P.first' (fmap ((\f' (a,b,c') -> (a,f' b,c')) (const $ O.orderExprs c o)))) c))
-
-runAggregator :: Applicative f => Aggregator a b
- -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> f HPQ.PrimExpr)
- -> a -> f b
+orderAggregate o (Aggregator (PM.PackMap pm)) = Aggregator (PM.PackMap
+ (\f c -> pm (f . P.first' (fmap ((\f' (a,b,c') -> (a,f' b,c')) (const $ O.orderExprs c o)))) c))
+
+runAggregator
+ :: Applicative f
+ => Aggregator a b
+ -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)
+ -> f HPQ.PrimExpr)
+ -> a -> f b
runAggregator (Aggregator a) = PM.traversePM a
+-- In Postgres (and, I believe, standard SQL) "aggregate functions are
+-- not allowed in FROM clause of their own query level". There
+-- doesn't seem to be any fundamental reason for this, but we are
+-- stuck with it. That means that in a lateral subquery containing an
+-- aggregation over a field C from a previous subquery we have to
+-- create a new field name for C before we are allowed to aggregate it!
+-- For more information see
+--
+-- https://www.postgresql.org/message-id/20200513110251.GC24083%40cloudinit-builder
+--
+-- https://github.com/tomjaguarpaw/haskell-opaleye/pull/460#issuecomment-626716160
+--
+-- Instead of detecting when we are aggregating over a field from a
+-- previous query we just create new names for all field before we
+-- aggregate. On the other hand, referring to a field from a previous
+-- query in an ORDER BY expression is totally fine!
aggregateU :: Aggregator a b
-> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)
aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0)
- where (c1, projPEs) =
+ where (c1, projPEs_inners) =
PM.run (runAggregator agg (extractAggregateFields t0) c0)
- primQ' = PQ.Aggregate projPEs primQ
+ projPEs = map fst projPEs_inners
+ inners = map snd projPEs_inners
+
+ primQ' = PQ.Aggregate projPEs (PQ.Rebind True inners primQ)
+
+extractAggregateFields
+ :: T.Tag
+ -> (m, HPQ.PrimExpr)
+ -> PM.PM [((HPQ.Symbol,
+ (m, HPQ.Symbol)),
+ (HPQ.Symbol, HPQ.PrimExpr))]
+ HPQ.PrimExpr
+extractAggregateFields tag (m, pe) = do
+ i <- PM.new
+
+ let souter = HPQ.Symbol ("result" ++ i) tag
+ sinner = HPQ.Symbol ("inner" ++ i) tag
+
+ PM.write ((souter, (m, sinner)), (sinner, pe))
-extractAggregateFields :: T.Tag -> (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)
- -> PM.PM [(HPQ.Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))] HPQ.PrimExpr
-extractAggregateFields = PM.extractAttr "result"
+ pure (HPQ.AttrExpr souter)
-- { Boilerplate instances
@@ -106,8 +142,8 @@ instance P.Profunctor Aggregator where
dimap f g (Aggregator q) = Aggregator (P.dimap f g q)
instance PP.ProductProfunctor Aggregator where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
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
index 9d4c904..ca348ea 100644
--- a/src/Opaleye/Internal/Binary.hs
+++ b/src/Opaleye/Internal/Binary.hs
@@ -11,7 +11,7 @@ import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Data.Profunctor (Profunctor, dimap)
-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
+import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
@@ -38,7 +38,7 @@ binaryspecColumn = Binaryspec (PM.iso (mapBoth unColumn) Column)
sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns'
-> Q.Query columns -> Q.Query columns -> Q.Query columns'
-sameTypeBinOpHelper binop binaryspec q1 q2 = Q.simpleQueryArr q where
+sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr q where
q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)
where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)
(columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)
@@ -47,7 +47,10 @@ sameTypeBinOpHelper binop binaryspec q1 q2 = Q.simpleQueryArr q where
PM.run (runBinaryspec binaryspec (extractBinaryFields endTag)
(columns1, columns2))
- newPrimQuery = PQ.Binary binop pes (primQuery1, primQuery2)
+ newPrimQuery = PQ.Binary binop
+ ( PQ.Rebind False (map (fmap fst) pes) primQuery1
+ , PQ.Rebind False (map (fmap snd) pes) primQuery2
+ )
instance Default Binaryspec (Column a) (Column a) where
def = binaryspecColumn
@@ -67,7 +70,7 @@ instance Profunctor Binaryspec where
dimap f g (Binaryspec b) = Binaryspec (dimap (f *** f) g b)
instance ProductProfunctor Binaryspec where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
-- }
diff --git a/src/Opaleye/Internal/Distinct.hs b/src/Opaleye/Internal/Distinct.hs
index 1b1a51b..0d6e75f 100644
--- a/src/Opaleye/Internal/Distinct.hs
+++ b/src/Opaleye/Internal/Distinct.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Opaleye.Internal.Distinct where
-import Opaleye.QueryArr (Query)
+import qualified Opaleye.Internal.MaybeFields as M
+import Opaleye.Select (Select)
import Opaleye.Column (Column)
import Opaleye.Aggregate (Aggregator, groupBy, aggregate)
@@ -17,7 +19,7 @@ import Data.Profunctor.Product.Default (Default, def)
-- of something else that we already have is easier at this point.
distinctExplicit :: Distinctspec fields fields'
- -> Query fields -> Query fields'
+ -> Select fields -> Select fields'
distinctExplicit (Distinctspec agg) = aggregate agg
newtype Distinctspec a b = Distinctspec (Aggregator a b)
@@ -25,6 +27,17 @@ newtype Distinctspec a b = Distinctspec (Aggregator a b)
instance Default Distinctspec (Column a) (Column a) where
def = Distinctspec groupBy
+distinctspecField :: Distinctspec (Column a) (Column a)
+distinctspecField = def
+
+distinctspecMaybeFields :: M.WithNulls Distinctspec a b
+ -> Distinctspec (M.MaybeFields a) (M.MaybeFields b)
+distinctspecMaybeFields = M.unWithNulls def
+
+instance Default (M.WithNulls Distinctspec) a b
+ => Default Distinctspec (M.MaybeFields a) (M.MaybeFields b) where
+ def = distinctspecMaybeFields def
+
-- { Boilerplate instances
instance Functor (Distinctspec a) where
@@ -38,8 +51,8 @@ instance P.Profunctor Distinctspec where
dimap f g (Distinctspec q) = Distinctspec (P.dimap f g q)
instance PP.ProductProfunctor Distinctspec where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
instance PP.SumProfunctor Distinctspec where
Distinctspec x1 +++! Distinctspec x2 = Distinctspec (x1 PP.+++! x2)
diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
index ee632d5..9ba08c2 100644
--- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
+++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
@@ -15,10 +15,12 @@ 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.Char
import qualified Data.List.NonEmpty as NEL
import qualified Data.Text.Lazy.Builder.Scientific as Sci
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
+import qualified Text.Printf
mkSqlGenerator :: SqlGenerator -> SqlGenerator
@@ -267,7 +269,9 @@ escape '\n' = "\\n"
escape '\r' = "\\r"
escape '\t' = "\\t"
escape '\\' = "\\\\"
-escape c = [c]
+escape c = if Data.Char.isPrint c
+ then [c]
+ else Text.Printf.printf "\\U%0.8x" (Data.Char.ord c)
-- | Quote binary literals using Postgresql's hex format.
diff --git a/src/Opaleye/Internal/Join.hs b/src/Opaleye/Internal/Join.hs
index 0ec7b9b..f8f8f02 100644
--- a/src/Opaleye/Internal/Join.hs
+++ b/src/Opaleye/Internal/Join.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE Arrows #-}
module Opaleye.Internal.Join where
@@ -9,13 +10,20 @@ import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.Unpackspec as U
import Opaleye.Internal.Column (Column(Column), Nullable)
import qualified Opaleye.Internal.QueryArr as Q
+import qualified Opaleye.Internal.Operators as Op
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.PGTypes as T
+import qualified Opaleye.SqlTypes as T
import qualified Opaleye.Column as C
+import Opaleye.Field (Field)
import qualified Opaleye.Map as Map
+import Opaleye.Internal.MaybeFields (MaybeFields(MaybeFields),
+ mfPresent, mfFields)
+import qualified Opaleye.Select as S
import qualified Opaleye.Internal.TypeFamilies as TF
import qualified Control.Applicative as A
+import qualified Control.Arrow
import Data.Profunctor (Profunctor, dimap)
import qualified Data.Profunctor.Product as PP
@@ -41,7 +49,7 @@ joinExplicit :: U.Unpackspec columnsA columnsA
-> ((columnsA, columnsB) -> Column T.PGBool)
-> Q.Query (returnedColumnsA, returnedColumnsB)
joinExplicit uA uB returnColumnsA returnColumnsB joinType
- qA qB cond = Q.simpleQueryArr q where
+ qA qB cond = Q.productQueryArr 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)
@@ -87,6 +95,36 @@ leftJoinAExplicit uA nullmaker rq =
primQueryR
, T.next t2)
+optionalRestrict :: D.Default U.Unpackspec a a
+ => S.Select a
+ -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)
+optionalRestrict = optionalRestrictExplicit D.def
+
+optionalRestrictExplicit :: U.Unpackspec a a
+ -> S.Select a
+ -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a)
+optionalRestrictExplicit uA q =
+ dimap (. snd) (\(nonNullIfPresent, rest) ->
+ let present = Op.not (C.isNull (C.unsafeCoerceColumn nonNullIfPresent))
+ in MaybeFields { mfPresent = present
+ , mfFields = rest
+ }) $
+ leftJoinAExplicit (PP.p2 (U.unpackspecColumn, uA))
+ (Opaleye.Internal.Join.NullMaker id)
+ (fmap (\x -> (T.sqlBool True, x)) q)
+
+-- | An example to demonstrate how the functionality of @LEFT JOIN@
+-- can be recovered using 'optionalRestrict'.
+leftJoinInTermsOfOptionalRestrict :: D.Default U.Unpackspec fieldsR fieldsR
+ => S.Select fieldsL
+ -> S.Select fieldsR
+ -> ((fieldsL, fieldsR) -> Field T.SqlBool)
+ -> S.Select (fieldsL, MaybeFields fieldsR)
+leftJoinInTermsOfOptionalRestrict qL qR cond = proc () -> do
+ fieldsL <- qL -< ()
+ maybeFieldsR <- optionalRestrict qR -< curry cond fieldsL
+ Control.Arrow.returnA -< (fieldsL, maybeFieldsR)
+
extractLeftJoinFields :: Int
-> T.Tag
-> HPQ.PrimExpr
@@ -106,11 +144,12 @@ instance Profunctor NullMaker where
dimap f g (NullMaker h) = NullMaker (dimap f g h)
instance PP.ProductProfunctor NullMaker where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
--
+-- | Do not use. Nulled will be deprecated in 0.7.
data Nulled
type instance TF.IMap Nulled TF.OT = TF.NullsT
diff --git a/src/Opaleye/Internal/Lateral.hs b/src/Opaleye/Internal/Lateral.hs
new file mode 100644
index 0000000..218c65d
--- /dev/null
+++ b/src/Opaleye/Internal/Lateral.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Opaleye.Internal.Lateral
+ ( lateral
+ , viaLateral
+ , laterally
+ , bilaterally
+ , bind
+ , arrowApply
+ )
+where
+
+import Opaleye.Internal.QueryArr
+
+-- | Lifts operations like 'Opaleye.Aggregate.aggregate',
+-- 'Opaleye.Order.orderBy' and 'Opaleye.Order.limit', which are restricted to
+-- 'Select' normally, to operate on 'SelectArr's taking arbitrary inputs.
+laterally :: (Select a -> Select b) -> SelectArr i a -> SelectArr i b
+laterally f as = lateral (\i -> f (viaLateral as i))
+
+
+-- | Lifts operations like 'Opaleye.Binary.union', 'Opaleye.Binary.intersect'
+-- and 'Opaleye.Binary.except', which are restricted to 'Select' normally, to
+-- operate on 'SelectArr's taking arbitrary inputs.
+bilaterally :: (Select a -> Select b -> Select c)
+ -> SelectArr i a -> SelectArr i b -> SelectArr i c
+bilaterally f as bs = lateral (\i -> f (viaLateral as i) (viaLateral bs i))
diff --git a/src/Opaleye/Internal/Manipulation.hs b/src/Opaleye/Internal/Manipulation.hs
index 13c1ab0..3c1d56c 100644
--- a/src/Opaleye/Internal/Manipulation.hs
+++ b/src/Opaleye/Internal/Manipulation.hs
@@ -118,8 +118,8 @@ instance Profunctor Updater where
dimap f g (Updater h) = Updater (dimap f g h)
instance PP.ProductProfunctor Updater where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
--
diff --git a/src/Opaleye/Internal/MaybeFields.hs b/src/Opaleye/Internal/MaybeFields.hs
new file mode 100644
index 0000000..919c75e
--- /dev/null
+++ b/src/Opaleye/Internal/MaybeFields.hs
@@ -0,0 +1,316 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+module Opaleye.Internal.MaybeFields where
+
+import Control.Applicative hiding (optional)
+import Control.Arrow (returnA, (<<<), (>>>))
+
+import qualified Opaleye.Internal.Binary as B
+import qualified Opaleye.Internal.Column as IC
+import qualified Opaleye.Constant as Constant
+import qualified Opaleye.Internal.PackMap as PM
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
+import qualified Opaleye.Internal.PrimQuery as PQ
+import qualified Opaleye.Internal.QueryArr as IQ
+import qualified Opaleye.Internal.RunQuery as RQ
+import qualified Opaleye.Internal.Tag as Tag
+import qualified Opaleye.Internal.Unpackspec as U
+import qualified Opaleye.Internal.Values as V
+import Opaleye.Select (Select, SelectArr)
+import qualified Opaleye.Column
+import qualified Opaleye.Field
+import Opaleye.Field (Field)
+import Opaleye.Internal.Operators ((.&&), (.||), (.==), restrict, not,
+ ifExplict, IfPP, EqPP(EqPP))
+import qualified Opaleye.Internal.Lateral
+import qualified Opaleye.SqlTypes
+import Opaleye.SqlTypes (SqlBool, IsSqlType)
+
+import Control.Monad (replicateM_)
+
+import qualified Data.Profunctor as P
+import qualified Data.Profunctor.Product as PP
+import qualified Data.Profunctor.Product.Default as PP
+
+import qualified Database.PostgreSQL.Simple.FromRow as PGSR
+
+-- | The Opaleye analogue of 'Data.Maybe.Maybe'
+data MaybeFields fields =
+ MaybeFields {
+ mfPresent :: Opaleye.Column.Column Opaleye.SqlTypes.SqlBool
+ , mfFields :: fields
+ }
+ deriving Functor
+
+instance Applicative MaybeFields where
+ pure fields = MaybeFields { mfPresent = Opaleye.SqlTypes.sqlBool True
+ , mfFields = fields
+ }
+ MaybeFields t f <*> MaybeFields t' a =
+ MaybeFields {
+ mfPresent = t .&& t'
+ , mfFields = f a
+ }
+
+instance Monad MaybeFields where
+ return = pure
+ MaybeFields t a >>= f = case f a of
+ MaybeFields t' b -> MaybeFields (t .&& t') b
+
+-- | The Opaleye analogue of 'Data.Maybe.Nothing'.
+nothingFields :: PP.Default V.Nullspec a a => MaybeFields a
+nothingFields = nothingFieldsExplicit def
+ where def :: PP.Default V.Nullspec a a => V.Nullspec a a
+ def = PP.def
+
+-- | The Opaleye analogue of @'Prelude.const' 'Data.Maybe.Nothing'@.
+-- Can be useful to avoid type inference problems, because it doesn't
+-- pick up a type class constraint.
+nothingFieldsOfTypeOf :: a -> MaybeFields a
+nothingFieldsOfTypeOf a = MaybeFields {
+ mfPresent = Opaleye.SqlTypes.sqlBool False
+ , mfFields = a
+ }
+
+-- | The Opaleye analogue of 'Data.Maybe.Just'. Equivalent to
+-- 'Control.Applicative.pure'.
+justFields :: a -> MaybeFields a
+justFields = pure
+
+-- | The Opaleye analogue of 'Data.Maybe.maybe'
+maybeFields :: PP.Default IfPP b b => b -> (a -> b) -> MaybeFields a -> b
+maybeFields = maybeFieldsExplicit PP.def
+
+-- | The Opaleye analogue of 'Data.Maybe.fromMaybe'
+fromMaybeFields :: PP.Default IfPP b b => b -> MaybeFields b -> b
+fromMaybeFields = fromMaybeFieldsExplicit PP.def
+
+-- | The Opaleye analogue of 'Data.Maybe.maybeToList'
+maybeFieldsToSelect :: SelectArr (MaybeFields a) a
+maybeFieldsToSelect = proc mf -> do
+ restrict -< mfPresent mf
+ returnA -< mfFields mf
+
+-- | The Opaleye analogue of 'Data.Maybe.catMaybes'
+catMaybeFields :: SelectArr i (MaybeFields a) -> SelectArr i a
+catMaybeFields = (>>> maybeFieldsToSelect)
+
+maybeFieldsExplicit :: IfPP b b' -> b -> (a -> b) -> MaybeFields a -> b'
+maybeFieldsExplicit ifpp b f mf =
+ ifExplict ifpp (mfPresent mf) (f (mfFields mf)) b
+
+fromMaybeFieldsExplicit :: IfPP b b -> b -> MaybeFields b -> b
+fromMaybeFieldsExplicit ifpp = flip (maybeFieldsExplicit ifpp) id
+
+nothingFieldsExplicit :: V.Nullspec a b -> MaybeFields b
+nothingFieldsExplicit = nothingFieldsOfTypeOf . V.nullFields
+
+traverseMaybeFields :: SelectArr a b -> SelectArr (MaybeFields a) (MaybeFields b)
+traverseMaybeFields query = proc mfInput -> do
+ mfOutput <- optional (query <<< maybeFieldsToSelect) -< mfInput
+ restrict -< mfPresent mfInput `implies` mfPresent mfOutput
+ returnA -< MaybeFields (mfPresent mfInput) (mfFields mfOutput)
+
+ where a `implies` b = Opaleye.Internal.Operators.not a .|| b
+
+optional :: SelectArr i a -> SelectArr i (MaybeFields a)
+optional = Opaleye.Internal.Lateral.laterally optionalSelect
+ where
+ -- This is basically a left join on TRUE, but Shane (@duairc)
+ -- wrote it to ensure that we don't need an Unpackspec a a.
+ optionalSelect :: Select a -> Select (MaybeFields a)
+ optionalSelect = IQ.QueryArr . go
+
+ go query ((), left, tag) = (MaybeFields present a, join, Tag.next tag')
+ where
+ (MaybeFields t a, right, tag') =
+ IQ.runSimpleQueryArr (justFields <$> query) ((), tag)
+
+ present = isNotNull (IC.unsafeCoerceColumn t')
+
+ (t', bindings) =
+ PM.run (U.runUnpackspec U.unpackspecColumn (PM.extractAttr "maybe" tag') t)
+ join = PQ.Join PQ.LeftJoin true [] bindings left right
+ true = HPQ.ConstExpr (HPQ.BoolLit True)
+ isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull
+
+
+-- | An example to demonstrate how the functionality of (lateral)
+-- @LEFT JOIN@ can be recovered using 'optional'.
+lateralLeftJoinOptional :: SelectArr i a
+ -> SelectArr i b
+ -> ((a, b) -> Opaleye.Field.Field Opaleye.SqlTypes.SqlBool)
+ -> SelectArr i (a, MaybeFields b)
+lateralLeftJoinOptional fieldsL fieldsR cond = proc i -> do
+ fieldsL' <- fieldsL -< i
+ maybeFieldsR' <- optional (proc (fieldsL', i) -> do
+ fieldsR' <- fieldsR -< i
+ restrict -< cond (fieldsL', fieldsR')
+ returnA -< fieldsR'
+ ) -< (fieldsL', i)
+ returnA -< (fieldsL', maybeFieldsR')
+
+-- | An example to demonstrate how the functionality of
+-- 'Opaleye.Join.optionalRestrict' can be recovered using 'optional'.
+optionalRestrictOptional :: Select a
+ -> SelectArr (a -> Field SqlBool) (MaybeFields a)
+optionalRestrictOptional q = optional $ proc cond -> do
+ a <- q -< ()
+ restrict -< cond a
+ returnA -< a
+
+fromFieldsMaybeFields :: RQ.FromFields fields haskells
+ -> RQ.FromFields (MaybeFields fields) (Maybe haskells)
+fromFieldsMaybeFields (RQ.QueryRunner u p c) = RQ.QueryRunner u' p' c'
+ where u' = () <$ productProfunctorMaybeFields U.unpackspecColumn u
+
+ p' = \mf -> do
+ hIsPresent <- PGSR.field
+
+ case hIsPresent of
+ True -> Just <$> p (mfFields mf)
+ False -> Nothing <$ replicateM_ (c (mfFields mf))
+ (PGSR.fieldWith (\_ _ -> pure ()))
+
+ c' = \mf -> c (mfFields mf) + 1
+
+-- | This is not safe in general because it relies on p not doing
+-- anything observable with the @a@s if @mfPresent@ is false. In
+-- particular, it won't work for
+-- 'Opaleye.Internal.Distinct.Distinctspec' because it does indeed
+-- look at the @mfFields@ to check distinctness.
+productProfunctorMaybeFields :: PP.ProductProfunctor p
+ => p (Field SqlBool) (Field SqlBool)
+ -> p a b
+ -> p (MaybeFields a) (MaybeFields b)
+productProfunctorMaybeFields b p = MaybeFields PP.***$ P.lmap mfPresent b
+ PP.**** P.lmap mfFields p
+
+nullspecMaybeFields :: V.Nullspec a b
+ -> V.Nullspec (MaybeFields a) (MaybeFields b)
+nullspecMaybeFields = productProfunctorMaybeFields V.nullspecField
+
+unpackspecMaybeFields :: U.Unpackspec a b
+ -> U.Unpackspec (MaybeFields a) (MaybeFields b)
+unpackspecMaybeFields = productProfunctorMaybeFields U.unpackspecField
+
+valuesspecMaybeFields :: V.ValuesspecSafe a b
+ -> V.ValuesspecSafe (MaybeFields a) (MaybeFields b)
+valuesspecMaybeFields = productProfunctorMaybeFields V.valuesspecField
+
+toFieldsMaybeFields :: V.Nullspec a b
+ -> Constant.ToFields a b
+ -> Constant.ToFields (Maybe a) (MaybeFields b)
+toFieldsMaybeFields n p = Constant.Constant $ \case
+ Nothing -> nothingFieldsExplicit n
+ Just a -> justFields (Constant.constantExplicit p a)
+
+ifPPMaybeFields :: IfPP a b -> IfPP (MaybeFields a) (MaybeFields b)
+ifPPMaybeFields = productProfunctorMaybeFields PP.def
+
+-- I'd rather not crack open EqPP to implement this but the
+-- alternative is adding an operation eqPPOr :: EqPP a b -> EqPP a' b
+-- -> EqPP (a, a') b, and possibly even more than that, so I can't be
+-- bothered right now.
+eqPPMaybeFields :: EqPP a b -> EqPP (MaybeFields a) (MaybeFields b)
+eqPPMaybeFields (EqPP eqFields) = EqPP (\m1 m2 ->
+ (mfPresent m1 .== mfPresent m2)
+ .&& (mfPresent m1 `implies` eqFields (mfFields m1) (mfFields m2)))
+ where a `implies` b = Opaleye.Internal.Operators.not a .|| b
+
+-- | This is only safe if d is OK with having nulls passed through it
+-- when they claim to be non-null.
+unWithNulls :: PP.ProductProfunctor p
+ => p (Field SqlBool) (Field SqlBool)
+ -> WithNulls p a b
+ -> p (MaybeFields a) (MaybeFields b)
+unWithNulls b (WithNulls d) =
+ MaybeFields PP.***$ P.lmap mfPresent b
+ PP.**** d
+
+newtype WithNulls p a b =
+ WithNulls (p (MaybeFields a) b)
+
+-- | This is only safe if d is OK with having nulls passed through it
+-- when they claim to be non-null.
+mapMaybeFieldsWithNulls :: PP.ProductProfunctor p
+ => p (Field SqlBool) (Field SqlBool)
+ -> WithNulls p a b
+ -> WithNulls p (MaybeFields a) (MaybeFields b)
+mapMaybeFieldsWithNulls b d =
+ MaybeFields <$> P.lmap mfPresent (withNullsField b)
+ <*> P.lmap mfFields d
+
+-- | This is only safe if d is OK with having nulls passed through it
+-- when they claim to be non-null.
+withNullsField :: (IsSqlType a, P.Profunctor p)
+ => p (IC.Column a) (IC.Column a)
+ -> WithNulls p (IC.Column a) (IC.Column a)
+withNullsField col = result
+ where result = WithNulls (P.lmap (\(MaybeFields b c) ->
+ ifExplict PP.def b c nullC) col)
+ nullC = IC.Column (V.nullPE (columnProxy result))
+
+ columnProxy :: f (IC.Column sqlType) -> Maybe sqlType
+ columnProxy _ = Nothing
+
+binaryspecMaybeFields
+ :: WithNulls B.Binaryspec a b
+ -> B.Binaryspec (MaybeFields a) (MaybeFields b)
+binaryspecMaybeFields = unWithNulls PP.def
+
+instance P.Profunctor p => P.Profunctor (WithNulls p) where
+ dimap f g (WithNulls d) = WithNulls (P.dimap (fmap f) g d)
+
+instance P.Profunctor p => Functor (WithNulls p a) where
+ fmap = P.rmap
+
+instance PP.ProductProfunctor p => Applicative (WithNulls p a) where
+ pure = WithNulls . PP.purePP
+ WithNulls fd <*> WithNulls xd = WithNulls (fd PP.**** xd)
+
+instance PP.ProductProfunctor p => PP.ProductProfunctor (WithNulls p) where
+ purePP = pure
+ (****) = (<*>)
+
+instance PP.SumProfunctor p => PP.SumProfunctor (WithNulls p) where
+ WithNulls ff +++! WithNulls xf =
+ WithNulls (flip P.lmap (ff PP.+++! xf) $ \case
+ MaybeFields b (Left l) -> Left (MaybeFields b l)
+ MaybeFields b (Right r) -> Right (MaybeFields b r))
+
+instance PP.Default RQ.QueryRunner fields haskells
+ => PP.Default RQ.QueryRunner (MaybeFields fields) (Maybe haskells) where
+ def = fromFieldsMaybeFields PP.def
+
+instance PP.Default U.Unpackspec a b
+ => PP.Default U.Unpackspec (MaybeFields a) (MaybeFields b) where
+ def = unpackspecMaybeFields PP.def
+
+instance PP.Default V.ValuesspecSafe a b
+ => PP.Default V.ValuesspecSafe (MaybeFields a) (MaybeFields b) where
+ def = valuesspecMaybeFields PP.def
+
+instance (PP.Default Constant.Constant a b, PP.Default V.Nullspec a b)
+ => PP.Default Constant.Constant (Maybe a) (MaybeFields b) where
+ def = toFieldsMaybeFields PP.def PP.def
+
+instance PP.Default IfPP a b
+ => PP.Default IfPP (MaybeFields a) (MaybeFields b) where
+ def = ifPPMaybeFields PP.def
+
+instance PP.Default EqPP a b
+ => PP.Default EqPP (MaybeFields a) (MaybeFields b) where
+ def = eqPPMaybeFields PP.def
+
+instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Column a) (IC.Column a))
+ => PP.Default (WithNulls p) (IC.Column a) (IC.Column a) where
+ def = withNullsField PP.def
+
+instance PP.Default (WithNulls B.Binaryspec) a b
+ => PP.Default B.Binaryspec (MaybeFields a) (MaybeFields b) where
+ def = binaryspecMaybeFields PP.def
diff --git a/src/Opaleye/Internal/Operators.hs b/src/Opaleye/Internal/Operators.hs
index da96285..3b37e12 100644
--- a/src/Opaleye/Internal/Operators.hs
+++ b/src/Opaleye/Internal/Operators.hs
@@ -4,7 +4,7 @@
module Opaleye.Internal.Operators where
-import Opaleye.Internal.Column (Column)
+import Opaleye.Internal.Column (Column(Column))
import qualified Opaleye.Internal.Column as C
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
@@ -14,29 +14,47 @@ import qualified Opaleye.Internal.TableMaker as TM
import qualified Opaleye.Internal.Tag as Tag
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.PGTypes as T
+import qualified Opaleye.SqlTypes as T
+import qualified Opaleye.Field as F
+import qualified Opaleye.Select as S
import Data.Profunctor (Profunctor, dimap, lmap, rmap)
import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product.Default as D
+restrict :: S.SelectArr (F.Field T.SqlBool) ()
+restrict = QA.QueryArr f where
+ f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)
+
infix 4 .==
(.==) :: forall columns. D.Default EqPP columns columns
=> columns -> columns -> Column T.PGBool
(.==) = eqExplicit (D.def :: EqPP columns columns)
+infixr 2 .||
+
+(.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool
+(.||) = C.binOp HPQ.OpOr
+
infixr 3 .&&
-- | Boolean and
(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool
(.&&) = C.binOp HPQ.OpAnd
+not :: F.Field T.SqlBool -> F.Field T.SqlBool
+not = C.unOp HPQ.OpNot
+
newtype EqPP a b = EqPP (a -> a -> Column T.PGBool)
+eqPPField :: EqPP (Column a) ignored
+eqPPField = EqPP C.unsafeEq
+
eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool
eqExplicit (EqPP f) = f
instance D.Default EqPP (Column a) (Column a) where
- def = EqPP C.unsafeEq
+ def = eqPPField
newtype IfPP a b = IfPP (Column T.PGBool -> a -> a -> b)
@@ -48,6 +66,9 @@ ifExplict :: IfPP columns columns'
-> columns'
ifExplict (IfPP f) = f
+ifPPField :: IfPP (Column a) (Column a)
+ifPPField = D.def
+
instance D.Default IfPP (Column a) (Column a) where
def = IfPP C.unsafeIfThenElse
@@ -78,7 +99,7 @@ relationValuedExprExplicit :: RelExprMaker strings columns
-> (a -> HPQ.PrimExpr)
-> QA.QueryArr a columns
relationValuedExprExplicit rem_ strings pe =
- QA.simpleQueryArr $ \(a, tag) ->
+ QA.productQueryArr $ \(a, tag) ->
let (primExprs, projcols) = runRelExprMaker rem_ tag strings
primQ :: PQ.PrimQuery
primQ = PQ.RelExpr (pe a) projcols
diff --git a/src/Opaleye/Internal/Optimize.hs b/src/Opaleye/Internal/Optimize.hs
index be4e1ad..bcdf211 100644
--- a/src/Opaleye/Internal/Optimize.hs
+++ b/src/Opaleye/Internal/Optimize.hs
@@ -8,28 +8,29 @@ import qualified Opaleye.Internal.PrimQuery as PQ
import Opaleye.Internal.Helpers ((.:))
import qualified Data.List.NonEmpty as NEL
+import Data.Semigroup ((<>))
import Control.Applicative ((<$>), (<*>), pure)
-import qualified Data.Traversable as T
+import Control.Arrow (first)
optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a
optimize = mergeProduct . removeUnit
removeUnit :: PQ.PrimQuery' a -> PQ.PrimQuery' a
removeUnit = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product = product }
- where product pqs pes = PQ.Product pqs' pes
- where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit) pqs) of
- Nothing -> return PQ.Unit
+ where product pqs = PQ.Product pqs'
+ where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit . snd) pqs) of
+ Nothing -> return (pure PQ.Unit)
Just xs -> xs
mergeProduct :: PQ.PrimQuery' a -> PQ.PrimQuery' a
mergeProduct = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product = product }
where product pqs pes = PQ.Product pqs' (pes ++ pes')
where pqs' = pqs >>= queries
- queries (PQ.Product qs _) = qs
+ queries (lat, PQ.Product qs _) = fmap (first (lat <>)) qs
queries q = return q
pes' = NEL.toList pqs >>= conds
- conds (PQ.Product _ cs) = cs
+ conds (_lat, PQ.Product _ cs) = cs
conds _ = []
removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b)
@@ -37,7 +38,11 @@ removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold {
PQ.unit = return PQ.Unit
, PQ.empty = const Nothing
, PQ.baseTable = return .: PQ.BaseTable
- , PQ.product = \x y -> PQ.Product <$> T.sequence x
+ , PQ.product = let sequenceOf l = traverseOf l id
+ traverseOf = id
+ _2 = traverse
+ in
+ \x y -> PQ.Product <$> sequenceOf (traverse._2) x
<*> pure y
, PQ.aggregate = fmap . PQ.Aggregate
, PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns
@@ -56,11 +61,12 @@ removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold {
PQ.IntersectAll -> binary (const Nothing) (const Nothing) PQ.IntersectAll
, PQ.label = fmap . PQ.Label
, PQ.relExpr = return .: PQ.RelExpr
+ , PQ.rebind = \b -> fmap . PQ.Rebind b
}
where -- If only the first argument is Just, do n1 on it
-- If only the second argument is Just, do n2 on it
- binary n1 n2 jj exprs = \case
+ binary n1 n2 jj = \case
(Nothing, Nothing) -> Nothing
(Nothing, Just pq2) -> n2 pq2
(Just pq1, Nothing) -> n1 pq1
- (Just pq1, Just pq2) -> Just (PQ.Binary jj exprs (pq1, pq2))
+ (Just pq1, Just pq2) -> Just (PQ.Binary jj (pq1, pq2))
diff --git a/src/Opaleye/Internal/PackMap.hs b/src/Opaleye/Internal/PackMap.hs
index 093dd25..211e334 100644
--- a/src/Opaleye/Internal/PackMap.hs
+++ b/src/Opaleye/Internal/PackMap.hs
@@ -9,7 +9,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Control.Applicative (Applicative, pure, (<*>), liftA2)
import qualified Control.Monad.Trans.State as State
import Data.Profunctor (Profunctor, dimap, rmap)
-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
+import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import qualified Data.Functor.Identity as I
@@ -40,7 +40,8 @@ import qualified Data.Functor.Identity as I
-- '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.
-newtype PackMap a b s t = PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)
+newtype PackMap a b s t =
+ PackMap (forall f. Applicative f => (a -> f b) -> s -> f t)
-- | 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
@@ -91,8 +92,10 @@ run m = (r, as)
--
-- 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 :: (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
@@ -101,8 +104,10 @@ extractAttrPE mkName t pe = do
-- | 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 :: String
+ -> T.Tag
+ -> primExpr
+ -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr
extractAttr s = extractAttrPE (const (s ++))
-- }
@@ -134,8 +139,8 @@ instance Profunctor (PackMap a b) where
dimap f g (PackMap q) = PackMap (fmap (dimap f (fmap g)) q)
instance ProductProfunctor (PackMap a b) where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
instance PP.SumProfunctor (PackMap a b) where
PackMap f +++! PackMap g = PackMap (\x -> eitherFunction (f x) (g x))
diff --git a/src/Opaleye/Internal/PrimQuery.hs b/src/Opaleye/Internal/PrimQuery.hs
index 1f3402b..79e96b2 100644
--- a/src/Opaleye/Internal/PrimQuery.hs
+++ b/src/Opaleye/Internal/PrimQuery.hs
@@ -3,6 +3,7 @@ module Opaleye.Internal.PrimQuery where
import Prelude hiding (product)
import qualified Data.List.NonEmpty as NEL
+import Data.Semigroup (Semigroup, (<>))
import qualified Opaleye.Internal.HaskellDB.Sql as HSql
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Opaleye.Internal.HaskellDB.PrimQuery (Symbol)
@@ -18,7 +19,7 @@ data BinOp = Except
| IntersectAll
deriving Show
-data JoinType = LeftJoin | RightJoin | FullJoin | LeftJoinLateral deriving Show
+data JoinType = LeftJoin | RightJoin | FullJoin deriving Show
data TableIdentifier = TableIdentifier
{ tiSchemaName :: Maybe String
@@ -31,6 +32,17 @@ tiToSqlTable ti = HSql.SqlTable { HSql.sqlTableSchemaName = tiSchemaName ti
type Bindings a = [(Symbol, a)]
+data Lateral = NonLateral | Lateral
+ deriving Show
+
+instance Semigroup Lateral where
+ NonLateral <> NonLateral = NonLateral
+ _ <> _ = Lateral
+
+instance Monoid Lateral where
+ mappend = (<>)
+ mempty = NonLateral
+
-- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check
-- for emptiness explicity in the SQL generation phase.
@@ -42,14 +54,21 @@ type Bindings a = [(Symbol, a)]
data PrimQuery' a = Unit
| Empty a
| BaseTable TableIdentifier (Bindings HPQ.PrimExpr)
- | Product (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr]
- | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))
+ | Product (NEL.NonEmpty (Lateral, PrimQuery' a)) [HPQ.PrimExpr]
+ | Aggregate (Bindings (Maybe (HPQ.AggrOp,
+ [HPQ.OrderExpr],
+ HPQ.AggrDistinct),
+ HPQ.Symbol))
(PrimQuery' a)
- -- | Represents both @DISTINCT ON@ and @ORDER BY@ clauses. In order to represent valid
- -- SQL only, @DISTINCT ON@ expressions are always interpreted as the first @ORDER BY@s
- -- when present, preceding any in the provided list.
+ -- | Represents both @DISTINCT ON@ and @ORDER BY@
+ -- clauses. In order to represent valid SQL only,
+ -- @DISTINCT ON@ expressions are always
+ -- interpreted as the first @ORDER BY@s when
+ -- present, preceding any in the provided list.
-- See 'Opaleye.Internal.Sql.distinctOnOrderBy'.
- | DistinctOnOrderBy (Maybe (NEL.NonEmpty HPQ.PrimExpr)) [HPQ.OrderExpr] (PrimQuery' a)
+ | DistinctOnOrderBy (Maybe (NEL.NonEmpty HPQ.PrimExpr))
+ [HPQ.OrderExpr]
+ (PrimQuery' a)
| Limit LimitOp (PrimQuery' a)
| Join JoinType
HPQ.PrimExpr
@@ -60,10 +79,12 @@ data PrimQuery' a = Unit
| Exists Bool (PrimQuery' a) (PrimQuery' a)
| Values [Symbol] (NEL.NonEmpty [HPQ.PrimExpr])
| Binary BinOp
- (Bindings (HPQ.PrimExpr, HPQ.PrimExpr))
(PrimQuery' a, PrimQuery' a)
| Label String (PrimQuery' a)
| RelExpr HPQ.PrimExpr (Bindings HPQ.PrimExpr)
+ | Rebind Bool
+ (Bindings HPQ.PrimExpr)
+ (PrimQuery' a)
deriving Show
type PrimQuery = PrimQuery' ()
@@ -73,9 +94,16 @@ data PrimQueryFold' a p = PrimQueryFold
{ unit :: p
, empty :: a -> p
, baseTable :: TableIdentifier -> Bindings HPQ.PrimExpr -> p
- , product :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p
- , aggregate :: Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> p -> p
- , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> p -> p
+ , product :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p
+ , aggregate :: Bindings (Maybe
+ (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),
+ HPQ.Symbol)
+ -> p
+ -> p
+ , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr)
+ -> [HPQ.OrderExpr]
+ -> p
+ -> p
, limit :: LimitOp -> p -> p
, join :: JoinType
-> HPQ.PrimExpr
@@ -86,10 +114,13 @@ data PrimQueryFold' a p = PrimQueryFold
-> p
, existsf :: Bool -> p -> p -> p
, values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p
- , binary :: BinOp -> Bindings (HPQ.PrimExpr, HPQ.PrimExpr) -> (p, p) -> p
+ , binary :: BinOp
+ -> (p, p)
+ -> p
, label :: String -> p -> p
, relExpr :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p
-- ^ A relation-valued expression
+ , rebind :: Bool -> Bindings HPQ.PrimExpr -> p -> p
}
@@ -108,6 +139,7 @@ primQueryFoldDefault = PrimQueryFold
, label = Label
, relExpr = RelExpr
, existsf = Exists
+ , rebind = Rebind
}
foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p
@@ -116,23 +148,24 @@ foldPrimQuery f = fix fold
Unit -> unit f
Empty a -> empty f a
BaseTable ti syms -> baseTable f ti syms
- Product qs pes -> product f (fmap self qs) pes
+ Product qs pes -> product f (fmap (fmap self) qs) pes
Aggregate aggrs q -> aggregate f aggrs (self q)
DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs (self q)
Limit op q -> limit f op (self q)
Join j cond pe1 pe2 q1 q2 -> join f j cond pe1 pe2 (self q1) (self q2)
Values ss pes -> values f ss pes
- Binary binop pes (q1, q2) -> binary f binop pes (self q1, self q2)
+ Binary binop (q1, q2) -> binary f binop (self q1, self q2)
Label l pq -> label f l (self pq)
RelExpr pe syms -> relExpr f pe syms
Exists b q1 q2 -> existsf f b (self q1) (self q2)
+ Rebind star pes q -> rebind f star pes (self q)
fix g = let x = g x in x
times :: PrimQuery -> PrimQuery -> PrimQuery
-times q q' = Product (q NEL.:| [q']) []
+times q q' = Product (pure q NEL.:| [pure q']) []
restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery
-restrict cond primQ = Product (return primQ) [cond]
+restrict cond primQ = Product (return (pure primQ)) [cond]
exists :: PrimQuery -> PrimQuery -> PrimQuery
exists = Exists True
diff --git a/src/Opaleye/Internal/Print.hs b/src/Opaleye/Internal/Print.hs
index 0677698..baea578 100644
--- a/src/Opaleye/Internal/Print.hs
+++ b/src/Opaleye/Internal/Print.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
module Opaleye.Internal.Print where
import Prelude hiding (product)
@@ -18,6 +20,7 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint
import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,
parens)
+import qualified Data.Char
import qualified Data.List.NonEmpty as NEL
import qualified Data.Text as ST
@@ -72,9 +75,10 @@ ppSelectBinary b = ppSql (Sql.bSelect1 b)
$$ ppSql (Sql.bSelect2 b)
ppSelectLabel :: Label -> Doc
-ppSelectLabel l = text "/*" <+> text (defuseComments (Sql.lLabel l)) <+> text "*/"
+ppSelectLabel l = text "/*" <+> text (preprocess (Sql.lLabel l)) <+> text "*/"
$$ ppSql (Sql.lSelect l)
where
+ preprocess = defuseComments . filter Data.Char.isPrint
defuseComments = ST.unpack
. ST.replace (ST.pack "--") (ST.pack " - - ")
. ST.replace (ST.pack "/*") (ST.pack " / * ")
@@ -95,7 +99,6 @@ 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"
-ppJoinType Sql.LeftJoinLateral = text "LEFT OUTER JOIN LATERAL"
ppAttrs :: Sql.SelectAttrs -> Doc
ppAttrs Sql.Star = text "*"
@@ -108,9 +111,15 @@ nameAs :: (HSql.SqlExpr, Maybe HSql.SqlColumn) -> Doc
nameAs (expr, name) = HPrint.ppAs (fmap unColumn name) (HPrint.ppSqlExpr expr)
where unColumn (HSql.SqlColumn s) = s
-ppTables :: [Select] -> Doc
+ppTables :: [(Sql.Lateral, Select)] -> Doc
ppTables [] = empty
-ppTables ts = text "FROM" <+> HPrint.commaV ppTable (zipWith tableAlias [1..] ts)
+ppTables ts = text "FROM" <+> HPrint.commaV ppTable_tableAlias (zip [1..] ts)
+ where ppTable_tableAlias :: (Int, (Sql.Lateral, Select)) -> Doc
+ ppTable_tableAlias (i, (lat, select)) =
+ lateral lat $ ppTable (tableAlias i select)
+ lateral = \case
+ Sql.NonLateral -> id
+ Sql.Lateral -> (text "LATERAL" $$)
tableAlias :: Int -> Select -> (TableAlias, Select)
tableAlias i select = ("T" ++ show i, select)
diff --git a/src/Opaleye/Internal/QueryArr.hs b/src/Opaleye/Internal/QueryArr.hs
index 57a4262..b7fe25f 100644
--- a/src/Opaleye/Internal/QueryArr.hs
+++ b/src/Opaleye/Internal/QueryArr.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE Arrows #-}
+
module Opaleye.Internal.QueryArr where
import Prelude hiding (id)
@@ -10,10 +12,11 @@ import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Control.Arrow as Arr
-import Control.Arrow ((&&&), (***), arr)
+import Control.Arrow ((&&&), (***), arr, returnA)
import qualified Control.Category as C
import Control.Category ((<<<), id)
import Control.Applicative (Applicative, pure, (<*>))
+import Data.List.NonEmpty ( NonEmpty((:|)) )
import qualified Data.Profunctor as P
import qualified Data.Profunctor.Product as PP
@@ -23,11 +26,15 @@ newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag
type Query = QueryArr ()
-simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
-simpleQueryArr f = QueryArr g
+productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
+productQueryArr f = QueryArr g
where g (a0, primQuery, t0) = (a1, PQ.times primQuery primQuery', t1)
where (a1, primQuery', t1) = f (a0, t0)
+{-# DEPRECATED simpleQueryArr "Use 'productQueryArr' instead. Its name indicates better what it actually does" #-}
+simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
+simpleQueryArr = productQueryArr
+
runQueryArr :: QueryArr a b -> (a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)
runQueryArr (QueryArr f) = f
@@ -46,6 +53,48 @@ runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag)
first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)
first3 f (a1, a2, a3) = (f a1, a2, a3)
+-- | A @SELECT@, i.e. an SQL query which produces a collection of
+-- rows.
+--
+-- @Select a@ is analogous to a Haskell value @[a]@.
+type Select = SelectArr ()
+
+-- | A parametrised 'Select'. A @SelectArr a b@ accepts an argument
+-- of type @a@.
+--
+-- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.
+type SelectArr = QueryArr
+
+-- | Implements @LATERAL@ subqueries.
+--
+-- You might find it easier to use 'Opaleye.Lateral.laterally' (if you
+-- want to apply 'Opaleye.Aggregate.aggregate',
+-- 'Opaleye.Order.orderBy' or 'Opaleye.Order.limit' to a 'SelectArr')
+-- or 'Opaleye.Lateral.bilaterally' (if you want to apply
+-- 'Opaleye.Binary.union', 'Opaleye.Binary.intersect' and
+-- 'Opaleye.Binary.except' to two 'SelectArr's).
+lateral :: (i -> Select a) -> SelectArr i a
+lateral f = QueryArr qa
+ where
+ qa (i, primQueryL, tag) = (a, primQueryJoin, tag')
+ where
+ (a, primQueryR, tag') = runSimpleQueryArr (f i) ((), tag)
+ primQueryJoin = PQ.Product ((PQ.NonLateral, primQueryL)
+ :| [(PQ.Lateral, primQueryR)])
+ []
+
+viaLateral :: SelectArr i a -> i -> Select a
+viaLateral s i = s <<< pure i
+
+bind :: SelectArr i a -> (a -> SelectArr i b) -> SelectArr i b
+bind s f = proc i -> do
+ a <- s -< i
+ b <- lateral (\(a, i) -> viaLateral (f a) i) -< (a, i)
+ returnA -< b
+
+arrowApply :: SelectArr (SelectArr i a, i) a
+arrowApply = lateral (\(f, i) -> viaLateral f i)
+
instance C.Category QueryArr where
id = QueryArr id
QueryArr f . QueryArr g = QueryArr (f . g)
@@ -62,6 +111,9 @@ instance Arr.ArrowChoice QueryArr where
Left a -> first3 Left (runQueryArr f (a, primQ, t0))
Right b -> (Right b, primQ, t0)
+instance Arr.ArrowApply QueryArr where
+ app = arrowApply
+
instance Functor (QueryArr a) where
fmap f = (arr f <<<)
@@ -69,6 +121,10 @@ instance Applicative (QueryArr a) where
pure = arr . const
f <*> g = arr (uncurry ($)) <<< (f &&& g)
+instance Monad (QueryArr a) where
+ return = pure
+ (>>=) = bind
+
instance P.Profunctor QueryArr where
dimap f g a = arr g <<< a <<< arr f
diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs
index 99c78fa..65fa41f 100644
--- a/src/Opaleye/Internal/RunQuery.hs
+++ b/src/Opaleye/Internal/RunQuery.hs
@@ -3,7 +3,8 @@
module Opaleye.Internal.RunQuery where
-import Control.Applicative (Applicative, pure, (*>), (<*>), liftA2)
+import Control.Applicative
+ (Applicative, pure, (<$>), (*>), (<*>), liftA2)
import qualified Database.PostgreSQL.Simple.Cursor as PGSC (Cursor)
import Database.PostgreSQL.Simple.Internal (RowParser)
@@ -24,7 +25,6 @@ import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)
import qualified Data.Profunctor as P
import Data.Profunctor (dimap)
import qualified Data.Profunctor.Product as PP
-import Data.Profunctor.Product (empty, (***!))
import qualified Data.Profunctor.Product.Default as D
import qualified Data.Aeson as Ae
@@ -41,7 +41,6 @@ import GHC.Int (Int32, Int64)
-- { Only needed for postgresql-simple FieldParsers
-import Control.Applicative ((<$>))
import Database.PostgreSQL.Simple.FromField
(ResultError(UnexpectedNull, Incompatible), typeInfo, returnError)
import qualified Database.PostgreSQL.Simple.TypeInfo as TI
@@ -92,8 +91,8 @@ data QueryRunner columns haskells =
(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
+ (columns -> Int)
+ -- How many columns have we requested? 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
@@ -121,7 +120,7 @@ fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell
fromPGSFieldParser = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn)
queryRunner :: FromField a b -> FromFields (Column a) b
-queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True)
+queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const 1)
where QueryRunnerColumn u fp = qrc
queryRunnerColumnNullable :: FromField a b
@@ -288,19 +287,19 @@ instance Functor (FromFields c) where
-- TODO: Seems like this one should be simpler!
instance Applicative (FromFields c) where
- pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const False)
+ pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const 0)
. 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)
+ QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (+) bf bx)
instance P.Profunctor FromFields where
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 FromFields where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
instance PP.SumProfunctor FromFields where
f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu))
@@ -337,8 +336,8 @@ jsonFieldTypeParser jsonTypeName field mData = do
-- }
prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells
-prepareRowParser (QueryRunner _ rowParser nonZeroColumns) cols =
- if nonZeroColumns cols
+prepareRowParser (QueryRunner _ rowParser numColumns) cols =
+ if numColumns cols > 0
then rowParser cols
else (fromRow :: RowParser (Only Int)) *> rowParser cols
-- If we are selecting zero columns then the SQL
diff --git a/src/Opaleye/Internal/Sql.hs b/src/Opaleye/Internal/Sql.hs
index cb43951..9460f39 100644
--- a/src/Opaleye/Internal/Sql.hs
+++ b/src/Opaleye/Internal/Sql.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
module Opaleye.Internal.Sql where
import Prelude hiding (product)
@@ -37,7 +39,7 @@ data SelectAttrs =
data From = From {
attrs :: SelectAttrs,
- tables :: [Select],
+ tables :: [(Lateral, Select)],
criteria :: [HSql.SqlExpr],
groupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr),
orderBy :: [(HSql.SqlExpr, HSql.SqlOrder)],
@@ -65,8 +67,9 @@ data Binary = Binary {
bSelect2 :: Select
} deriving Show
-data JoinType = LeftJoin | RightJoin | FullJoin | LeftJoinLateral deriving Show
+data JoinType = LeftJoin | RightJoin | FullJoin deriving Show
data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show
+data Lateral = Lateral | NonLateral deriving Show
data Label = Label {
lLabel :: String,
@@ -96,6 +99,7 @@ sqlQueryGenerator = PQ.PrimQueryFold
, PQ.label = label
, PQ.relExpr = relExpr
, PQ.existsf = exists
+ , PQ.rebind = rebind
}
exists :: Bool -> Select -> Select -> Select
@@ -103,7 +107,7 @@ exists b q1 q2 = SelectExists (Exists b q1 q2)
sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select
sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes))
- , tables = [pqSelect] }
+ , tables = oneTable pqSelect }
where pqSelect = PQ.foldPrimQuery sqlQueryGenerator pq
makeAttrs = flip (zipWith makeAttr) [1..]
makeAttr pe i = sqlBinding (Symbol ("result" ++ show (i :: Int)) t, pe)
@@ -114,32 +118,58 @@ unit = SelectFrom newSelect { attrs = SelectAttrs (ensureColumns []) }
empty :: V.Void -> select
empty = V.absurd
+oneTable :: t -> [(Lateral, t)]
+oneTable t = [(NonLateral, t)]
+
baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select
baseTable ti columns = SelectFrom $
newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))
- , tables = [Table (HSql.SqlTable (PQ.tiSchemaName ti) (PQ.tiTableName ti))] }
+ , tables = oneTable (Table (HSql.SqlTable (PQ.tiSchemaName ti) (PQ.tiTableName ti))) }
-product :: NEL.NonEmpty Select -> [HPQ.PrimExpr] -> Select
+product :: NEL.NonEmpty (PQ.Lateral, Select) -> [HPQ.PrimExpr] -> Select
product ss pes = SelectFrom $
- newSelect { tables = NEL.toList ss
+ newSelect { tables = NEL.toList ss'
, criteria = map sqlExpr pes }
-
-aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))] -> Select -> Select
-aggregate aggrs s = SelectFrom $ newSelect { attrs = SelectAttrs
- (ensureColumns (map attr aggrs))
- , tables = [s]
- , 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.
+ where ss' = flip fmap ss $ Arr.first $ \case
+ PQ.Lateral -> Lateral
+ PQ.NonLateral -> NonLateral
+
+aggregate :: [(Symbol,
+ (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),
+ HPQ.Symbol))]
+ -> Select
+ -> Select
+aggregate aggrs' s =
+ SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (map attr aggrs))
+ , tables = oneTable s
+ , groupBy = (Just . groupBy') aggrs }
+ where --- Although in the presence of an aggregation function,
+ --- grouping by an empty list is equivalent to omitting group
+ --- by, the equivalence does not hold in the absence of an
+ --- aggregation function. In the absence of an aggregation
+ --- function, group by of an empty list will return a single
+ --- row (if there are any and zero rows otherwise). A query
+ --- without group by will return all rows. This is a weakness
+ --- of SQL. Really there ought to be a separate SELECT
+ --- AGGREGATE operation.
+ ---
+ --- Syntactically one cannot group by an empty list in SQL.
+ --- We take the conservative approach of explicitly grouping
+ --- by a constant if we are provided with an empty list of
+ --- group bys. This yields a single group. (Alternatively,
+ --- we could check whether any aggregation functions have been
+ --- applied and only group by a constant in the case where
+ --- none have. That would make the generated SQL less noisy.)
+ ---
+ --- "GROUP BY 0" means group by the zeroth column so we
+ --- instead use an expression rather than a constant.
handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr
handleEmpty =
M.fromMaybe (return (SP.deliteral (HSql.ConstSqlExpr "0")))
. NEL.nonEmpty
+ aggrs = (map . Arr.second . Arr.second) HPQ.AttrExpr aggrs'
+
groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]
-> NEL.NonEmpty HSql.SqlExpr
groupBy' = handleEmpty
@@ -156,7 +186,7 @@ aggrExpr = maybe id (\(op, ord, distinct) e -> HPQ.AggrExpr distinct op e ord)
distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select
distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect
- { tables = [s]
+ { tables = oneTable s
, distinctOn = fmap (SG.sqlExpr SD.defaultSqlGenerator) <$> distinctExprs
, orderBy = map (SD.toSqlOrder SD.defaultSqlGenerator) $
-- Postgres requires all 'DISTINCT ON' expressions to appear before any other
@@ -169,7 +199,7 @@ distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect
, HPQ.orderNulls = HPQ.NullsLast }
limit_ :: PQ.LimitOp -> Select -> Select
-limit_ lo s = SelectFrom $ newSelect { tables = [s]
+limit_ lo s = SelectFrom $ newSelect { tables = oneTable s
, limit = limit'
, offset = offset' }
where (limit', offset') = case lo of
@@ -190,7 +220,7 @@ join j cond pes1 pes2 s1 s2 =
, jCond = sqlExpr cond }
where selectFrom pes s = SelectFrom $ newSelect {
attrs = SelectAttrsStar (ensureColumns (map sqlBinding pes))
- , tables = [s]
+ , tables = oneTable s
}
-- Postgres seems to name columns of VALUES clauses "column1",
@@ -202,24 +232,17 @@ values columns pes = SelectValues Values { vAttrs = SelectAttrs (mkColumns colu
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 {
+binary :: PQ.BinOp -> (Select, Select) -> Select
+binary op (select1, select2) = SelectBinary Binary {
bOp = binOp op,
- bSelect1 = SelectFrom newSelect { attrs = SelectAttrs
- (ensureColumns (map (mkColumn fst) pes)),
- tables = [select1] },
- bSelect2 = SelectFrom newSelect { attrs = SelectAttrs
- (ensureColumns (map (mkColumn snd) pes)),
- tables = [select2] }
+ bSelect1 = select1,
+ bSelect2 = select2
}
- where mkColumn e = sqlBinding . Arr.second e
joinType :: PQ.JoinType -> JoinType
joinType PQ.LeftJoin = LeftJoin
joinType PQ.RightJoin = RightJoin
joinType PQ.FullJoin = FullJoin
-joinType PQ.LeftJoinLateral = LeftJoinLateral
binOp :: PQ.BinOp -> BinOp
binOp o = case o of
@@ -267,5 +290,14 @@ label l s = SelectLabel (Label l s)
relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> Select
relExpr pe columns = SelectFrom $
newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))
- , tables = [RelExpr (sqlExpr pe)]
+ , tables = oneTable (RelExpr (sqlExpr pe))
}
+
+rebind :: Bool -> [(Symbol, HPQ.PrimExpr)] -> Select -> Select
+rebind star pes select = SelectFrom newSelect
+ { attrs = selectAttrs (ensureColumns (map sqlBinding pes))
+ , tables = oneTable select
+ }
+ where selectAttrs = case star of
+ True -> SelectAttrsStar
+ False -> SelectAttrs
diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs
index c18011a..03ca2f0 100644
--- a/src/Opaleye/Internal/Table.hs
+++ b/src/Opaleye/Internal/Table.hs
@@ -15,7 +15,7 @@ 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 Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import qualified Data.List.NonEmpty as NEL
import Data.Monoid (Monoid, mempty, mappend)
@@ -24,7 +24,7 @@ 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
+-- \"quantity\" and \"radius\" are the table's fields in Postgres and
-- the types are given in the type signature. The @id@ field is an
-- autoincrementing field (i.e. optional for writes).
--
@@ -35,18 +35,18 @@ import qualified Control.Arrow as Arr
-- , quantity :: d
-- , radius :: e }
--
--- $('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)
+-- \$('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)
--
--- widgetTable :: Table (Widget (Maybe (Column PGInt4)) (Column PGText) (Column PGText)
--- (Column PGInt4) (Column PGFloat8))
--- (Widget (Column PGText) (Column PGText) (Column PGText)
--- (Column PGInt4) (Column PGFloat8))
+-- widgetTable :: Table (Widget (Maybe (Field SqlInt4)) (Field SqlText) (Field SqlText)
+-- (Field SqlInt4) (Field SqlFloat8))
+-- (Widget (Field SqlText) (Field SqlText) (Field SqlText)
+-- (Field SqlInt4) (Field SqlFloat8))
-- widgetTable = table \"widgetTable\"
--- (pWidget Widget { wid = tableColumn \"id\"
--- , color = tableColumn \"color\"
--- , location = tableColumn \"location\"
--- , quantity = tableColumn \"quantity\"
--- , radius = tableColumn \"radius\" })
+-- (pWidget Widget { wid = tableField \"id\"
+-- , color = tableField \"color\"
+-- , location = tableField \"location\"
+-- , quantity = tableField \"quantity\"
+-- , radius = tableField \"radius\" })
-- @
--
-- The constructors of Table are internal only and will be
@@ -95,7 +95,7 @@ tableColumnsView = tablePropertiesView
-- | Internal only. Do not use. 'View' will be deprecated in version
-- 0.7.
-data View columns = View columns
+newtype View columns = View columns
-- | Internal only. Do not use. 'Writer' will be deprecated in
-- version 0.7.
@@ -113,41 +113,57 @@ newtype Writer columns dummy =
Writer (forall f. Functor f =>
PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())
--- | 'required' is for fields which are not 'optional'. You must
--- provide them on writes.
-required :: String -> TableFields (Column a) (Column a)
-required columnName = TableProperties
+-- | 'requiredTableField' is for fields which are not optional. You
+-- must provide them on writes.
+requiredTableField :: String -> TableFields (Column a) (Column a)
+requiredTableField columnName = TableProperties
(requiredW columnName)
(View (Column (HPQ.BaseTableAttrExpr columnName)))
--- | 'optional' is for fields that you can omit on writes, such as
--- columns which have defaults or which are SERIAL.
-optional :: String -> TableFields (Maybe (Column a)) (Column a)
-optional columnName = TableProperties
+-- | 'optionalTableField' is for fields that you can omit on writes, such as
+-- fields which have defaults or which are SERIAL.
+optionalTableField :: String -> TableFields (Maybe (Column a)) (Column a)
+optionalTableField columnName = TableProperties
(optionalW columnName)
(View (Column (HPQ.BaseTableAttrExpr columnName)))
--- | 'readOnly' is for fields that you must omit on writes, such as
--- SERIAL columns intended to auto-increment only.
+-- | 'readOnlyTableField' is for fields that you must omit on writes, such as
+-- SERIAL fields intended to auto-increment only.
+readOnlyTableField :: String -> TableFields () (Column a)
+readOnlyTableField = lmap (const Nothing) . optionalTableField
+
+-- | Use 'requiredTableField' instead. 'required' will be deprecated
+-- in 0.7.
+required :: String -> TableFields (Column a) (Column a)
+required = requiredTableField
+
+-- | Use 'optionalTableField' instead. 'optional' will be deprecated
+-- in 0.7.
+optional :: String -> TableFields (Maybe (Column a)) (Column a)
+optional = optionalTableField
+
+-- | Use 'readOnlyTableField' instead. 'readOnly' will be deprecated
+-- in 0.7.
readOnly :: String -> TableFields () (Column a)
-readOnly = lmap (const Nothing) . optional
+readOnly = readOnlyTableField
class TableColumn writeType sqlType | writeType -> sqlType where
-- | Do not use. Use 'tableField' instead. Will be deprecated in
-- 0.7.
tableColumn :: String -> TableFields writeType (Column sqlType)
tableColumn = tableField
- -- | Infer either a 'required' or 'optional' column depending on
+ -- | Infer either a required ('requiredTableField') or optional
+ -- ('optionalTableField') field depending on
-- the write type. It's generally more convenient to use this
-- than 'required' or 'optional' but you do have to provide a type
-- signature instead.
tableField :: String -> TableFields writeType (Column sqlType)
instance TableColumn (Column a) a where
- tableField = required
+ tableField = requiredTableField
instance TableColumn (Maybe (Column a)) a where
- tableField = optional
+ tableField = optionalTableField
queryTable :: U.Unpackspec viewColumns columns
-> Table writeColumns viewColumns
@@ -217,15 +233,15 @@ instance Functor (Writer a) where
fmap _ (Writer g) = Writer g
instance Applicative (Writer a) where
- pure x = Writer (fmap (const ()) (pure x))
+ pure _ = Writer (pure ())
Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)
instance Profunctor Writer where
dimap f _ (Writer h) = Writer (lmap (fmap f) h)
instance ProductProfunctor Writer where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
instance Functor (TableProperties a) where
fmap f (TableProperties w (View v)) = TableProperties (fmap f w) (View (f v))
@@ -239,8 +255,8 @@ instance Profunctor TableProperties where
dimap f g (TableProperties w (View v)) = TableProperties (dimap f g w)
(View (g v))
instance ProductProfunctor TableProperties where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
instance Functor (Table a) where
fmap f (Table t tp) = Table t (fmap f tp)
diff --git a/src/Opaleye/Internal/TableMaker.hs b/src/Opaleye/Internal/TableMaker.hs
index 33043f2..f8c0df9 100644
--- a/src/Opaleye/Internal/TableMaker.hs
+++ b/src/Opaleye/Internal/TableMaker.hs
@@ -8,7 +8,7 @@ import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.Unpackspec as U
import Data.Profunctor (Profunctor, dimap)
-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
+import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
@@ -64,7 +64,7 @@ instance Profunctor ViewColumnMaker where
dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q)
instance ProductProfunctor ViewColumnMaker where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
--}
diff --git a/src/Opaleye/Internal/Unpackspec.hs b/src/Opaleye/Internal/Unpackspec.hs
index 9f09661..43cc553 100644
--- a/src/Opaleye/Internal/Unpackspec.hs
+++ b/src/Opaleye/Internal/Unpackspec.hs
@@ -8,7 +8,7 @@ import qualified Opaleye.Column as C
import Control.Applicative (Applicative, pure, (<*>))
import Data.Profunctor (Profunctor, dimap)
-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
+import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D
@@ -35,10 +35,15 @@ newtype Unpackspec columns columns' =
-- 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' operations.
Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')
--- | Target the single 'HPQ.PrimExpr' inside a 'C.Column'
+-- | Use 'unpackspecField' instead. @unpackspecColumn@ will be
+-- deprecated in version 0.7.
unpackspecColumn :: Unpackspec (C.Column a) (C.Column a)
unpackspecColumn = Unpackspec (PM.iso IC.unColumn IC.Column)
+-- | Target the single 'HPQ.PrimExpr' inside a 'C.Column'
+unpackspecField :: Unpackspec (C.Column a) (C.Column a)
+unpackspecField = Unpackspec (PM.iso IC.unColumn IC.Column)
+
-- | Modify all the targeted 'HPQ.PrimExpr's
runUnpackspec :: Applicative f
=> Unpackspec columns b
@@ -69,8 +74,8 @@ instance Profunctor Unpackspec where
dimap f g (Unpackspec q) = Unpackspec (dimap f g q)
instance ProductProfunctor Unpackspec where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
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
index 52f5e29..0dbb3fc 100644
--- a/src/Opaleye/Internal/Values.hs
+++ b/src/Opaleye/Internal/Values.hs
@@ -8,10 +8,13 @@ import qualified Opaleye.Internal.Tag as T
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
+import qualified Opaleye.Internal.PGTypes
+import qualified Opaleye.SqlTypes
+import Data.Functor.Identity (runIdentity)
import qualified Data.List.NonEmpty as NEL
-import Data.Profunctor (Profunctor, dimap, rmap)
-import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
+import Data.Profunctor (Profunctor, dimap, rmap, lmap)
+import Data.Profunctor.Product (ProductProfunctor)
import qualified Data.Profunctor.Product as PP
import Data.Profunctor.Product.Default (Default, def)
@@ -59,9 +62,105 @@ runValuesspec :: Applicative f => Valuesspec columns columns'
-> (() -> f HPQ.PrimExpr) -> f columns'
runValuesspec (Valuesspec v) f = PM.traversePM v f ()
+-- For 0.7 put an `IsSqlType a` constraint on here, so that we can
+-- later use it without breaking the API
instance Default Valuesspec (Column a) (Column a) where
def = Valuesspec (PM.iso id Column)
+valuesUSafe :: ValuesspecSafe columns columns'
+ -> [columns]
+ -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)
+valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =
+ (newColumns, primQ', T.next t)
+ where runRow row =
+ case PM.run (U.runUnpackspec unpack extractValuesEntry row) of
+ (_, []) -> [zero]
+ (_, xs) -> xs
+
+ (newColumns, valuesPEs_nulls) =
+ PM.run (runValuesspecSafe valuesspec (extractValuesField t))
+
+ valuesPEs = map fst valuesPEs_nulls
+ nulls = case map snd valuesPEs_nulls of
+ [] -> [nullInt]
+ nulls' -> nulls'
+
+ yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery
+ yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))
+
+ zero = HPQ.ConstExpr (HPQ.IntegerLit 0)
+ nullInt = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType
+ (Nothing :: Maybe Opaleye.SqlTypes.SqlInt4))
+ (HPQ.ConstExpr HPQ.NullLit)
+
+ (values, wrap) = case NEL.nonEmpty rows of
+ Nothing -> (pure nulls, yieldNoRows)
+ Just rows' -> (fmap runRow rows', id)
+
+ primQ' = wrap (PQ.Values valuesPEs values)
+
+data ValuesspecSafe columns columns' =
+ ValuesspecSafe (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')
+ (U.Unpackspec columns columns')
+
+runValuesspecSafe :: Applicative f
+ => ValuesspecSafe columns columns'
+ -> (HPQ.PrimExpr -> f HPQ.PrimExpr)
+ -> f columns'
+runValuesspecSafe (ValuesspecSafe v _) f = PM.traversePM v f ()
+
+valuesspecField :: Opaleye.SqlTypes.IsSqlType a
+ => ValuesspecSafe (Column a) (Column a)
+valuesspecField = def
+
+instance Opaleye.Internal.PGTypes.IsSqlType a
+ => Default ValuesspecSafe (Column a) (Column a) where
+ def = def_
+ where def_ = ValuesspecSafe (PM.PackMap (\f () -> fmap Column (f null_)))
+ U.unpackspecColumn
+ null_ = nullPE sqlType
+
+ sqlType = columnProxy def_
+ columnProxy :: f (Column sqlType) -> Maybe sqlType
+ columnProxy _ = Nothing
+
+nullPE :: Opaleye.SqlTypes.IsSqlType a => proxy a -> HPQ.PrimExpr
+nullPE sqlType = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType sqlType)
+ (HPQ.ConstExpr HPQ.NullLit)
+
+-- Implementing this in terms of Valuesspec for convenience
+newtype Nullspec fields fields' = Nullspec (ValuesspecSafe fields fields')
+
+nullspecField :: Opaleye.SqlTypes.IsSqlType b
+ => Nullspec a (Column b)
+nullspecField = Nullspec (lmap e valuesspecField)
+ where e = error (concat [ "We looked at the argument of a Nullspec when we "
+ , "expected that we never would! This is a bug in "
+ , "Opaleye. Please report it, if you can reproduce "
+ , "it."
+ ])
+
+nullspecList :: Nullspec a [b]
+nullspecList = pure []
+
+nullspecEitherLeft :: Nullspec a b
+ -> Nullspec a (Either b b')
+nullspecEitherLeft = fmap Left
+
+nullspecEitherRight :: Nullspec a b'
+ -> Nullspec a (Either b b')
+nullspecEitherRight = fmap Right
+
+instance Opaleye.SqlTypes.IsSqlType b
+ => Default Nullspec a (Column b) where
+ def = nullspecField
+
+-- | All fields @NULL@, even though technically the type may forbid
+-- that! Used to create such fields when we know we will never look
+-- at them expecting to find something non-NULL.
+nullFields :: Nullspec a fields -> fields
+nullFields (Nullspec v) = runIdentity (runValuesspecSafe v pure)
+
-- {
-- Boilerplate instance definitions. Theoretically, these are derivable.
@@ -77,7 +176,36 @@ instance Profunctor Valuesspec where
dimap _ g (Valuesspec q) = Valuesspec (rmap g q)
instance ProductProfunctor Valuesspec where
- empty = PP.defaultEmpty
- (***!) = PP.defaultProfunctorProduct
+ purePP = pure
+ (****) = (<*>)
+
+instance Functor (ValuesspecSafe a) where
+ fmap f (ValuesspecSafe g h) = ValuesspecSafe (fmap f g) (fmap f h)
+
+instance Applicative (ValuesspecSafe a) where
+ pure a = ValuesspecSafe (pure a) (pure a)
+ ValuesspecSafe f f' <*> ValuesspecSafe x x' =
+ ValuesspecSafe (f <*> x) (f' <*> x')
+
+instance Profunctor ValuesspecSafe where
+ dimap f g (ValuesspecSafe q q') = ValuesspecSafe (rmap g q) (dimap f g q')
+
+instance ProductProfunctor ValuesspecSafe where
+ purePP = pure
+ (****) = (<*>)
+
+instance Functor (Nullspec a) where
+ fmap f (Nullspec g) = Nullspec (fmap f g)
+
+instance Applicative (Nullspec a) where
+ pure = Nullspec . pure
+ Nullspec f <*> Nullspec x = Nullspec (f <*> x)
+
+instance Profunctor Nullspec where
+ dimap f g (Nullspec q) = Nullspec (dimap f g q)
+
+instance ProductProfunctor Nullspec where
+ purePP = pure
+ (****) = (<*>)
-- }
diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs
index 1119c8d..dbae479 100644
--- a/src/Opaleye/Join.hs
+++ b/src/Opaleye/Join.hs
@@ -1,23 +1,4 @@
-- | Left, right, and full outer joins.
---
--- "Opaleye.FunctionalJoin" provides a much nicer, Haskelly, interface
--- to joins than this module, which sticks to the (horrible) standard
--- \"make missing rows NULL\" interface that SQL provides.
---
--- 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 :: Select (Field a, Field b)
--- -> Select (Field c, FieldNullable d)
--- -> (((Field a, Field b), (Field c, FieldNullable d)) -> Field 'Opaleye.SqlTypes.SqlBool')
--- -> Select ((Field a, Field b), (FieldNullable c, FieldNullable d))
--- @
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -29,6 +10,7 @@ module Opaleye.Join where
import qualified Opaleye.Field as F
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.Join as J
+import qualified Opaleye.Internal.MaybeFields as M
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Map as Map
import qualified Opaleye.Select as S
@@ -36,8 +18,144 @@ import qualified Opaleye.SqlTypes as T
import qualified Data.Profunctor.Product.Default as D
--- * Joins
+-- * The recommended way of performing joins in Opaleye
+
+-- $ref
+--
+-- Opaleye supports inner joins, left/right joins and full outer
+-- joins. Instead of using them directly we recommend the following,
+-- which provide APIs that are more familiar to a Haskell programmer
+-- and more composable:
+--
+-- - Inner joins: use 'Opaleye.Operators.restrict' directly (along
+-- with 'Control.Applicative.<*>' or arrow notation)
+--
+-- - Left/right joins: use 'optionalRestrict'
+--
+-- - Lateral left/right joins: use 'optional'
+--
+-- - Full outer joins: use 'Opaleye.FunctionalJoin.fullJoinF' (If you
+-- have a real-world use case for full outer joins then we'd love to
+-- hear about it. Please [open a new issue on the Opaleye
+-- project](http://github.com/tomjaguarpaw/haskell-opaleye/issues/new)
+-- and tell us about it.)
+
+-- | Convenient access to left/right join functionality. Performs a
+-- @LEFT JOIN@ under the hood and has behaviour equivalent to the
+-- following Haskell function:
+--
+-- @
+-- optionalRestrict :: [a] -> (a -> Bool) -> [Maybe a]
+-- optionalRestrict xs p =
+-- case filter p xs of [] -> [Nothing]
+-- xs' -> map Just xs'
+-- @
+--
+-- For example,
+--
+-- @
+-- > let l = [1, 10, 100, 1000] :: [Field SqlInt4]
+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 100000)) :: IO [Maybe Int]
+-- [Nothing]
+--
+-- > 'Opaleye.RunSelect.runSelect' conn (proc () -> optionalRestrict ('Opaleye.Values.valuesSafe' l) -\< (.> 15)) :: IO [Maybe Int]
+-- [Just 100,Just 1000]
+-- @
+--
+-- See the documentation of 'leftJoin' for how to use
+-- 'optionalRestrict' to replace 'leftJoin' (and by symmetry,
+-- 'rightJoin').
+optionalRestrict :: D.Default U.Unpackspec a a
+ => S.Select a
+ -- ^ Input query
+ -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)
+ -- ^ If any rows of the input query satisfy the
+ -- condition then return them (wrapped in \"Just\").
+ -- If none of them satisfy the condition then return a
+ -- single row of \"Nothing\"
+optionalRestrict = J.optionalRestrict
+
+-- | NB Opaleye exports @Opaleye.Table.'Opaleye.Table.optional'@ from
+-- the top level. If you want this @optional@ you will have to import
+-- it from this module.
+--
+-- Convenient access to lateral left/right join
+-- functionality. Performs a @LATERAL LEFT JOIN@ under the hood and
+-- has behaviour equivalent to the following Haskell function:
+--
+-- @
+-- optional :: [a] -> [Maybe a]
+-- optional q = case q of
+-- [] -> [Nothing]
+-- xs -> map Just xs
+-- @
+--
+-- That is, if @q :: 'SelectArr' i a@ returns no rows, @'optional' q
+-- :: 'SelectArr' i ('MaybeFields' a)@ returns exactly one \"Nothing\"
+-- row. Otherwise, @'optional' q@ returns exactly the rows of @q@
+-- wrapped in \"Just\". For example,
+--
+-- @
+-- > let l1 = ["one", "two", "three"] :: [Field SqlText]
+-- > 'Opaleye.RunSelect.runSelect' conn ('optional' ('Opaleye.Values.valuesSafe' l1)) :: IO [Maybe String]
+-- [Just "one", Just "two", Just "three"]
+--
+-- > let l2 = [] :: [Field SqlText]
+-- > 'Opaleye.RunSelect.runSelect' conn ('optional' ('Opaleye.Values.valuesSafe' l2)) :: IO [Maybe String]
+-- [Nothing]
+-- @
+--
+-- 'optionalRestrict' is a special case of @optional@ and could be
+-- written in terms of @optional@ as follows (except that
+-- 'optionalRestrict' doesn't use @LATERAL@ under the hood and
+-- @optional@ does).
+--
+-- @
+-- optionalRestrict q = optional $ proc cond -> do
+-- a <- q -< ()
+-- restrict -< cond a
+-- returnA -< a
+-- @
+optional :: D.Default U.Unpackspec a a
+ => S.SelectArr i a
+ -- ^ Input query
+ -> S.SelectArr i (M.MaybeFields a)
+ -- ^ The rows of the input query wrapped in \"Just\", unless
+ -- the input query has no rows in which case a single row of
+ -- \"Nothing\"
+optional = M.optional
+
+-- * Direct access to joins (not recommended)
+
+-- $ref2
+--
+-- You probably want use the alternatives listed at the top of this
+-- module instead of these.
+-- The use of the @'D.Default' 'NullMaker'@ 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 :: Select (Field a, Field b)
+-- -> Select (Field c, FieldNullable d)
+-- -> (((Field a, Field b), (Field c, FieldNullable d)) -> Field 'Opaleye.SqlTypes.SqlBool')
+-- -> Select ((Field a, Field b), (FieldNullable c, FieldNullable d))
+-- @
+-- | We suggest you use 'optionalRestrict' instead. Instead of writing
+-- \"@'Opaleye.Join.leftJoin' qL qR cond@\" you can write
+--
+-- @
+-- proc () -> do
+-- fieldsL <- qL -< ()
+-- maybeFieldsR \<- 'optionalRestrict' qR -\< 'Prelude.curry' cond fieldsL
+-- 'Control.Arrow.returnA' -< (fieldsL, maybeFieldsR)
+-- @
+--
+-- Typically everything except the 'optionalRestrict' line can be
+-- inlined in surrounding arrow notation. In such cases, readability
+-- and maintainibility increase dramatically.
leftJoin :: (D.Default U.Unpackspec fieldsL fieldsL,
D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsR nullableFieldsR)
@@ -47,8 +165,11 @@ leftJoin :: (D.Default U.Unpackspec fieldsL fieldsL,
-> S.Select (fieldsL, nullableFieldsR) -- ^ Left join
leftJoin = leftJoinExplicit D.def D.def D.def
--- | 'leftJoinA' is a convenient way of using left joins within arrow
--- notation
+-- | We suggest you don't use this. 'optionalRestrict' is probably
+-- better for your use case. 'Opaleye.Join.leftJoinA' is the same as
+-- except 'optionalRestrict' without the return type wrapped in
+-- 'Opaleye.Internal.MaybeFields.MaybeFields'.
+
leftJoinA :: (D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsR nullableFieldsR)
=> S.Select fieldsR
@@ -58,6 +179,8 @@ leftJoinA :: (D.Default U.Unpackspec fieldsR fieldsR,
-- result comes out
leftJoinA = leftJoinAExplict D.def D.def
+-- | We suggest you use 'optionalRestrict' instead. See 'leftJoin'
+-- for more details.
rightJoin :: (D.Default U.Unpackspec fieldsL fieldsL,
D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsL nullableFieldsL)
@@ -115,8 +238,22 @@ fullJoinExplicit :: U.Unpackspec fieldsL fieldsL
fullJoinExplicit uA uB nullmakerA nullmakerB =
J.joinExplicit uA uB (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin
--- * Inferrable versions
+optionalRestrictExplicit :: U.Unpackspec a a
+ -> S.Select a
+ -> S.SelectArr (a -> F.Field T.SqlBool) (M.MaybeFields a)
+optionalRestrictExplicit = J.optionalRestrictExplicit
+
+-- The Unpackpec is not used but I'm adding it in case we discover we
+-- need it in the future. Then we can use it without breaking the
+-- API.
+optionalExplicit :: U.Unpackspec a a
+ -> S.SelectArr i a
+ -> S.SelectArr i (M.MaybeFields a)
+optionalExplicit _ = M.optional
+
+-- * Inferrable versions (deprecated)
+-- | Do not use. Will be deprecated in 0.7. Use 'optionalRestrict' instead.
leftJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,
D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsR nullableFieldsR,
@@ -131,6 +268,8 @@ leftJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,
-- ^ Left join
leftJoinInferrable = leftJoin
+-- | Do not use. Will be deprecated in 0.7. Use 'optionalRestrict'
+-- instead.
rightJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,
D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsL nullableFieldsL,
@@ -146,6 +285,8 @@ rightJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,
rightJoinInferrable = rightJoin
+-- | Do not use. Will be deprecated in 0.7. Use
+-- 'Opaleye.FunctionalJoin.rightJoinF' instead.
fullJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,
D.Default U.Unpackspec fieldsR fieldsR,
D.Default J.NullMaker fieldsL nullableFieldsL,
diff --git a/src/Opaleye/Label.hs b/src/Opaleye/Label.hs
index 9184955..d77fb0a 100644
--- a/src/Opaleye/Label.hs
+++ b/src/Opaleye/Label.hs
@@ -5,5 +5,5 @@ import qualified Opaleye.Internal.QueryArr as Q
import qualified Opaleye.Select as S
-- | Add a commented label to the generated SQL.
-label :: String -> S.Select a -> S.Select a
-label l a = Q.simpleQueryArr (L.label' l . Q.runSimpleQueryArr a)
+label :: String -> S.SelectArr a b -> S.SelectArr a b
+label l a = Q.QueryArr (L.label' l . Q.runQueryArr a)
diff --git a/src/Opaleye/Lateral.hs b/src/Opaleye/Lateral.hs
new file mode 100644
index 0000000..07167a2
--- /dev/null
+++ b/src/Opaleye/Lateral.hs
@@ -0,0 +1,9 @@
+module Opaleye.Lateral
+ ( lateral
+ , viaLateral
+ , laterally
+ , bilaterally
+ )
+where
+
+import Opaleye.Internal.Lateral
diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs
index 7678edf..59866ed 100644
--- a/src/Opaleye/Manipulation.hs
+++ b/src/Opaleye/Manipulation.hs
@@ -170,11 +170,12 @@ rCount = MI.Count
-- | Return a function of the inserted or updated rows
--
--- 'rReturning''s use of the 'D.Default' typeclass means that the
+-- 'rReturning''s use of the @'D.Default' 'Opaleye.RunSelect.FromFields'@
+-- typeclass means that the
-- compiler will have trouble inferring types. It is strongly
-- recommended that you provide full type signatures when using
-- 'rReturning'.
-rReturning :: D.Default RQ.QueryRunner fields haskells
+rReturning :: D.Default RQ.FromFields fields haskells
=> (fieldsR -> fields)
-- ^
-> MI.Returning fieldsR [haskells]
@@ -182,7 +183,7 @@ rReturning = rReturningExplicit D.def
-- | Return a function of the inserted or updated rows. Explicit
-- version. You probably just want to use 'rReturning' instead.
-rReturningExplicit :: RQ.QueryRunner fields haskells
+rReturningExplicit :: RQ.FromFields fields haskells
-- ^
-> (fieldsR -> fields)
-- ^
@@ -324,7 +325,7 @@ arrangeUpdateReturningSql =
show . Print.ppUpdateReturning .::. arrangeUpdateReturning
-- | Insert rows into a table with @ON CONFLICT DO NOTHING@
-{-# DEPRECATED runInsertManyOnConflictDoNothing "Use runInsert_" #-}
+{-# DEPRECATED runInsertManyOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-}
runInsertManyOnConflictDoNothing :: PGS.Connection
-- ^
-> T.Table columns columns'
@@ -347,7 +348,7 @@ runInsertManyOnConflictDoNothing conn table_ columns =
-- 'D.Default' typeclass means that the compiler will have trouble
-- inferring types. It is strongly recommended that you provide full
-- type signatures when using it.
-{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use runInsert_" #-}
+{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-}
runInsertManyReturningOnConflictDoNothing
:: (D.Default RQ.QueryRunner columnsReturned haskells)
=> PGS.Connection
diff --git a/src/Opaleye/Map.hs b/src/Opaleye/Map.hs
index 34c6f72..e9154a1 100644
--- a/src/Opaleye/Map.hs
+++ b/src/Opaleye/Map.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
+-- | Do not use. This module will be deprecated in 0.7.
+
module Opaleye.Map where
type family Map f x
diff --git a/src/Opaleye/MaybeFields.hs b/src/Opaleye/MaybeFields.hs
new file mode 100644
index 0000000..a863ff2
--- /dev/null
+++ b/src/Opaleye/MaybeFields.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | 'MaybeFields' is Opaleye's analogue to 'Data.Maybe.Maybe'. You
+-- probably won't want to create values of type 'MaybeFields'
+-- directly; instead they will appear as the result of
+-- left\/right\/outer join-like operations, such as
+-- 'Opaleye.Join.optionalRestrict' and 'Opaleye.Join.optional'.
+
+module Opaleye.MaybeFields (
+ MaybeFields,
+ nothingFields,
+ justFields,
+ fromMaybeFields,
+ maybeFields,
+ maybeFieldsToSelect,
+ nothingFieldsOfTypeOf,
+ catMaybeFields,
+ Opaleye.Join.optional,
+ Opaleye.MaybeFields.traverseMaybeFields,
+ -- * Adaptors
+ Nullspec,
+ nullspecField,
+ nullspecMaybeFields,
+ nullspecList,
+ nullspecEitherLeft,
+ nullspecEitherRight,
+ binaryspecMaybeFields,
+ distinctspecMaybeFields,
+ fromFieldsMaybeFields,
+ toFieldsMaybeFields,
+ unpackspecMaybeFields,
+ valuesspecMaybeFields,
+ -- * Explicit versions
+ nothingFieldsExplicit,
+ fromMaybeFieldsExplicit,
+ maybeFieldsExplicit,
+ Opaleye.Join.optionalExplicit,
+ traverseMaybeFieldsExplicit,
+ ) where
+
+import Opaleye.Internal.Distinct
+import Opaleye.Internal.MaybeFields
+import Opaleye.Internal.Values
+import Opaleye.Join
+import Opaleye.Internal.Unpackspec
+import Opaleye.Select
+
+import Data.Profunctor.Product.Default
+
+-- | 'traverseMaybeFields' is analogous to Haskell's
+-- @'Data.Traversable.traverse' :: (a -> [b]) -> 'Data.Maybe.Maybe' a
+-- -> ['Data.Maybe.Maybe' b]@. In particular,
+-- 'Data.Traversable.traverse' has the following definition that
+-- generalises to 'traverseMaybeFields':
+--
+-- * @traverse _ Nothing = pure Nothing@
+-- * @traverse f (Just x) = fmap Just (f x)@
+traverseMaybeFields :: (Default Unpackspec a a, Default Unpackspec b b)
+ => SelectArr a b
+ -- ^
+ -> SelectArr (MaybeFields a) (MaybeFields b)
+ -- ^
+traverseMaybeFields = Opaleye.Internal.MaybeFields.traverseMaybeFields
+
+-- The Unpackspecs are currently redundant, but I'm adding them in
+-- case they become necessary in the future. Then we can use them
+-- without breaking the API.
+traverseMaybeFieldsExplicit :: Unpackspec a a
+ -> Unpackspec b b
+ -> SelectArr a b
+ -> SelectArr (MaybeFields a) (MaybeFields b)
+traverseMaybeFieldsExplicit _ _ =
+ Opaleye.Internal.MaybeFields.traverseMaybeFields
diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs
index 90e99ea..b1dc197 100644
--- a/src/Opaleye/Operators.hs
+++ b/src/Opaleye/Operators.hs
@@ -26,7 +26,7 @@ import qualified Opaleye.SqlTypes as T
import qualified Opaleye.Column as Column
import qualified Opaleye.Distinct as Distinct
-import qualified Opaleye.Join as Join
+import qualified Opaleye.Join as Join
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
@@ -48,8 +48,7 @@ then 'keepWhen' will suit you better.
'Control.Applicative.Alternative' it may help you to know that
'restrict' corresponds to the 'Control.Monad.guard' function.) -}
restrict :: S.SelectArr (F.Field T.SqlBool) ()
-restrict = QueryArr f where
- f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0)
+restrict = O.restrict
{-| Add a @WHERE EXISTS@ clause to the current query. -}
restrictExists :: S.SelectArr a b -> S.SelectArr a ()
@@ -159,7 +158,7 @@ infixr 2 .||
-- | Boolean or
(.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool
-(.||) = C.binOp HPQ.OpOr
+(.||) = (O..||)
infixr 3 .&&
@@ -169,7 +168,7 @@ infixr 3 .&&
-- | Boolean not
not :: F.Field T.SqlBool -> F.Field T.SqlBool
-not = C.unOp HPQ.OpNot
+not = O.not
-- | True when any element of the container is true
ors :: F.Foldable f => f (F.Field T.SqlBool) -> F.Field T.SqlBool
@@ -218,9 +217,9 @@ in_ fcas (Column a) = Column $ case NEL.nonEmpty (F.toList fcas) of
-- This operation is equivalent to Postgres's @IN@ operator but, for
-- expediency, is currently implemented using a @LEFT JOIN@. Please
-- file a bug if this causes any issues in practice.
-inQuery :: D.Default O.EqPP fields fields
- => fields -> Query fields -> S.Select (F.Field T.SqlBool)
-inQuery c q = qj'
+inSelect :: D.Default O.EqPP fields fields
+ => fields -> S.Select fields -> S.Select (F.Field T.SqlBool)
+inSelect c q = qj'
where -- Remove every row that isn't equal to c
-- Replace the ones that are with '1'
q' = A.arr (const 1)
@@ -412,3 +411,8 @@ exists = restrictExists
-- | Identical to 'restrictNotExists'. Will be deprecated in version 0.7.
notExists :: QueryArr a b -> QueryArr a ()
notExists = restrictNotExists
+
+-- | Identical to 'inSelect'. Will be deprecated in version 0.7.
+inQuery :: D.Default O.EqPP fields fields
+ => fields -> Query fields -> S.Select (F.Field T.SqlBool)
+inQuery = inSelect
diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs
index b337e51..b349ab9 100644
--- a/src/Opaleye/Order.hs
+++ b/src/Opaleye/Order.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
--- | Ordering, @LIMIT@, @OFFSET@ and @DISTINCT ON@
+-- | @ORDER BY@, @LIMIT@, @OFFSET@ and @DISTINCT ON@
module Opaleye.Order ( -- * Order by
orderBy
@@ -52,7 +52,7 @@ example = 'orderBy' ('asc' fst \<\> 'desc' snd)
-}
orderBy :: O.Order a -> S.Select a -> S.Select a
orderBy os q =
- Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q)
+ Q.productQueryArr (O.orderByU os . Q.runSimpleQueryArr q)
-- | Specify an ascending ordering by the given expression.
-- (Any NULLs appear last)
@@ -82,18 +82,18 @@ descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc
-- * Limit and offset
{- |
-Limit the results of the given query to the given maximum number of
+Limit the results of the given 'S.Select' to the given maximum number of
items.
/WARNING:/ If you're planning on using limit/offset together please use
'offset' /before/ you use 'limit', e.g.:
@
-limit 10 (offset 50 yourQuery)
+limit 10 (offset 50 yourSelect)
@
-This is because Opaleye applies OFFSET and LIMIT to the query separately.
-The result of the query given above is the following, which will return
+This is because Opaleye applies @OFFSET@ and @LIMIT@ to the @SELECT@ separately.
+The result of the 'S.Select' given above is the following, which will return
10 rows after skipping the first 50 (probably what you want).
@
@@ -109,26 +109,26 @@ SELECT * FROM (SELECT * FROM yourTable LIMIT 10) OFFSET 50
@
-}
limit :: Int -> S.Select a -> S.Select a
-limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a)
+limit n a = Q.productQueryArr (O.limit' n . Q.runSimpleQueryArr a)
{- |
-Offset the results of the given query by the given amount, skipping
+Offset the results of the given 'S.Select' by the given amount, skipping
that many result rows.
/WARNING:/ Please read the documentation of 'limit' before combining
'offset' with 'limit'.
-}
offset :: Int -> S.Select a -> S.Select a
-offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)
+offset n a = Q.productQueryArr (O.offset' n . Q.runSimpleQueryArr a)
-- * Distinct on
-- | Keep a row from each set where the given function returns the same result. No
--- ordering is guaranteed. Mutliple fields may be distinguished by projecting out
+-- ordering is guaranteed. Multiple fields may be distinguished by projecting out
-- tuples of 'Opaleye.Field.Field_'s. Use 'distinctOnBy' to control how the rows
-- are chosen.
distinctOn :: D.Default U.Unpackspec b b => (a -> b) -> S.Select a -> S.Select a
-distinctOn proj q = Q.simpleQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)
+distinctOn proj q = Q.productQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)
-- | Keep the row from each set where the given function returns the same result. The
@@ -137,7 +137,7 @@ distinctOn proj q = Q.simpleQueryArr (O.distinctOn D.def proj . Q.runSimpleQuery
-- out tuples of 'Opaleye.Field.Field_'s.
distinctOnBy :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a
-> S.Select a -> S.Select a
-distinctOnBy proj ord q = Q.simpleQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)
+distinctOnBy proj ord q = Q.productQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)
-- * Other
diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs
index e618760..04c01e5 100644
--- a/src/Opaleye/PGTypes.hs
+++ b/src/Opaleye/PGTypes.hs
@@ -110,7 +110,8 @@ pgCiStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack . CI.original
pgCiLazyText :: CI.CI LText.Text -> Column PGCitext
pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original
--- No CI String instance since postgresql-simple doesn't define FromField (CI String)
+-- 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
@@ -143,15 +144,19 @@ pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8
pgValueJSONB :: Ae.ToJSON a => a -> Column PGJsonb
pgValueJSONB = pgLazyJSONB . Ae.encode
-pgArray :: forall a b. IsSqlType b => (a -> C.Column b) -> [a] -> C.Column (PGArray b)
+pgArray :: forall a b. IsSqlType b
+ => (a -> C.Column b) -> [a] -> C.Column (PGArray b)
pgArray pgEl xs = C.unsafeCast arrayTy $
C.Column (HPQ.ArrayExpr (map oneEl xs))
where
oneEl = C.unColumn . pgEl
arrayTy = showSqlType ([] :: [PGArray b])
-pgRange :: forall a b. IsRangeType b => (a -> C.Column b) -> R.RangeBound a -> R.RangeBound a -> C.Column (PGRange b)
-pgRange pgEl start end = C.Column (HPQ.RangeExpr (showRangeType ([] :: [b])) (oneEl start) (oneEl end))
+pgRange :: forall a b. IsRangeType b
+ => (a -> C.Column b) -> R.RangeBound a -> R.RangeBound a
+ -> C.Column (PGRange b)
+pgRange pgEl start end =
+ C.Column (HPQ.RangeExpr (showRangeType ([] :: [b])) (oneEl start) (oneEl end))
where oneEl (R.Inclusive a) = HPQ.Inclusive . C.unColumn $ pgEl a
oneEl (R.Exclusive a) = HPQ.Exclusive . C.unColumn $ pgEl a
oneEl R.NegInfinity = HPQ.NegInfinity
diff --git a/src/Opaleye/RunSelect.hs b/src/Opaleye/RunSelect.hs
index 974f0e7..a757f0b 100644
--- a/src/Opaleye/RunSelect.hs
+++ b/src/Opaleye/RunSelect.hs
@@ -7,7 +7,12 @@ module Opaleye.RunSelect
-- * Datatypes
IRQ.Cursor,
IRQ.FromFields,
- IRQ.FromField) where
+ IRQ.FromField,
+ IRQ.DefaultFromField,
+ IRQ.defaultFromField,
+ -- * Helper functions
+ IRQ.fromPGSFromField,
+ IRQ.fromPGSFieldParser) where
import qualified Data.Profunctor as P
import qualified Database.PostgreSQL.Simple as PGS
@@ -23,7 +28,8 @@ import qualified Data.Profunctor.Product.Default as D
-- * Running 'S.Select's
--- | @runSelect@'s use of the 'D.Default' typeclass means that the
+-- | @runSelect@'s use of the @'D.Default' 'FromFields'@
+-- typeclass means that the
-- compiler will have trouble inferring types. It is strongly
-- recommended that you provide full type signatures when using
-- @runSelect@.
@@ -80,8 +86,6 @@ runSelectFold = RQ.runQueryFold
-- | Declare a temporary cursor. The cursor is given a unique name for the given
-- connection.
---
--- Returns 'Nothing' when the query returns zero rows.
declareCursor
:: D.Default FromFields fields haskells
=> PGS.Connection
diff --git a/src/Opaleye/Select.hs b/src/Opaleye/Select.hs
index eac6df7..c3b9436 100644
--- a/src/Opaleye/Select.hs
+++ b/src/Opaleye/Select.hs
@@ -5,18 +5,6 @@
-- 'SelectArr' is a parametrised version of 'Select', i.e. it can be
-- passed arguments.
-module Opaleye.Select where
+module Opaleye.Select (Select, SelectArr) where
-import qualified Opaleye.QueryArr as Q
-
--- | A @SELECT@, i.e. an SQL query which produces a collection of
--- rows.
---
--- @Select a@ is analogous to a Haskell value @[a]@.
-type Select = SelectArr ()
-
--- | A parametrised 'Select'. A @SelectArr a b@ accepts an argument
--- of type @a@.
---
--- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.
-type SelectArr = Q.QueryArr
+import Opaleye.Internal.QueryArr
diff --git a/src/Opaleye/Sql.hs b/src/Opaleye/Sql.hs
index fe39b55..f084adf 100644
--- a/src/Opaleye/Sql.hs
+++ b/src/Opaleye/Sql.hs
@@ -19,9 +19,9 @@ import qualified Data.Profunctor.Product.Default as D
-- * Showing SQL
--- | Show the SQL query string generated from the query.
+-- | Show the SQL query string generated from the 'S.Select'.
--
--- When 'Nothing' is returned it means that the 'Query' returns zero
+-- When 'Nothing' is returned it means that the 'S.Select' returns zero
-- rows.
--
-- Example type specialization:
@@ -42,7 +42,7 @@ showSql :: forall fields.
-> Maybe String
showSql = showSqlExplicit (D.def :: U.Unpackspec fields fields)
--- | Show the unoptimized SQL query string generated from the query.
+-- | Show the unoptimized SQL query string generated from the 'S.Select'.
showSqlUnopt :: forall fields.
D.Default U.Unpackspec fields fields
=> S.Select fields
diff --git a/src/Opaleye/SqlTypes.hs b/src/Opaleye/SqlTypes.hs
index 4451556..1583c04 100644
--- a/src/Opaleye/SqlTypes.hs
+++ b/src/Opaleye/SqlTypes.hs
@@ -1,5 +1,5 @@
-- | SQL types and functions to create 'Opaleye.Field.Field_'s of
--- those types. You may find it more convenient to use
+-- those types. To create fields you may find it more convenient to use
-- "Opaleye.ToFields" instead.
module Opaleye.SqlTypes (module Opaleye.SqlTypes,
diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs
index 8cf68e1..10990ac 100644
--- a/src/Opaleye/Table.hs
+++ b/src/Opaleye/Table.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
{- |
@@ -66,15 +65,18 @@ module Opaleye.Table (-- * Defining tables
tableWithSchema,
T.Table,
T.tableField,
- T.optional,
- T.readOnly,
- T.required,
- -- * Querying tables
+ T.optionalTableField,
+ T.readOnlyTableField,
+ T.requiredTableField,
+ -- * Selecting from tables
selectTable,
-- * Other
T.TableColumns,
TableFields,
-- * Deprecated
+ T.optional,
+ T.readOnly,
+ T.required,
T.tableColumn,
View,
Writer,
@@ -137,7 +139,7 @@ selectTableExplicit :: U.Unpackspec tablefields fields
-> Table a tablefields
-- ^
-> S.Select fields
-selectTableExplicit cm table' = Q.simpleQueryArr f where
+selectTableExplicit cm table' = Q.productQueryArr f where
f ((), t0) = (retwires, primQ, Tag.next t0) where
(retwires, primQ) = T.queryTable cm table' t0
diff --git a/src/Opaleye/Values.hs b/src/Opaleye/Values.hs
index 258426e..435e58b 100644
--- a/src/Opaleye/Values.hs
+++ b/src/Opaleye/Values.hs
@@ -1,6 +1,18 @@
{-# LANGUAGE FlexibleContexts #-}
-module Opaleye.Values where
+module Opaleye.Values(
+ valuesSafe,
+ -- * Explicit versions
+ valuesExplicit,
+ valuesSafeExplicit,
+ valuesUnsafeExplicit,
+ -- * Adaptors
+ V.ValuesspecSafe,
+ V.valuesspecField,
+ -- * Deprecated versions
+ values,
+ valuesUnsafe,
+ ) where
import qualified Opaleye.Internal.QueryArr as Q
import Opaleye.Internal.Values as V
@@ -9,28 +21,55 @@ import qualified Opaleye.Select as S
import Data.Profunctor.Product.Default (Default, def)
--- | 'values' implements Postgres's @VALUES@ construct and allows you
--- to create a query that consists of the given rows.
+-- | Please note that 'values' of an empty list generates incorrect
+-- queries when mixed with @OUTER@\/@LEFT@\/@RIGHT JOIN@. You should
+-- use 'valuesSafe' instead. 'valuesSafe' will replace 'values' in
+-- version 0.7.
+values :: (Default V.Valuesspec fields fields,
+ Default U.Unpackspec fields fields) =>
+ [fields] -> S.Select fields
+values = valuesExplicit def def
+
+valuesExplicit :: U.Unpackspec fields fields'
+ -> V.Valuesspec fields fields'
+ -> [fields] -> S.Select fields'
+valuesExplicit unpack valuesspec fields =
+ Q.productQueryArr (V.valuesU unpack valuesspec fields)
+
+-- | 'valuesSafe' implements Postgres's @VALUES@ construct and allows you
+-- to create a @SELECT@ that consists of the given rows.
--
-- Example type specialization:
--
-- @
--- values :: [(Field a, Field b)] -> Select (Field a, Field b)
+-- valuesSafe :: [(Field a, Field b)] -> Select (Field a, Field b)
-- @
--
-- Assuming the @makeAdaptorAndInstance@ splice has been run for the
-- product type @Foo@:
--
-- @
--- selectTable :: [Foo (Field a) (Field b) (Field c)] -> S.Select (Foo (Field a) (Field b) (Field c))
+-- valuesSafe :: [Foo (Field a) (Field b) (Field c)] -> S.Select (Foo (Field a) (Field b) (Field c))
-- @
-values :: (Default V.Valuesspec fields fields,
- Default U.Unpackspec fields fields) =>
- [fields] -> S.Select fields
-values = valuesExplicit def def
+valuesSafe :: Default V.ValuesspecSafe fields fields =>
+ [fields] -> S.Select fields
+valuesSafe = valuesSafeExplicit def
-valuesExplicit :: U.Unpackspec fields fields'
- -> V.Valuesspec fields fields'
- -> [fields] -> S.Select fields'
-valuesExplicit unpack valuesspec fields =
- Q.simpleQueryArr (V.valuesU unpack valuesspec fields)
+valuesSafeExplicit :: V.ValuesspecSafe fields fields'
+ -> [fields] -> S.Select fields'
+valuesSafeExplicit valuesspec fields =
+ Q.productQueryArr (V.valuesUSafe valuesspec fields)
+
+-- | Forward-compatible version of unsafe 'values' that will not be
+-- deprecated in 0.7, but in 0.8.
+valuesUnsafe :: (Default V.Valuesspec fields fields,
+ Default U.Unpackspec fields fields) =>
+ [fields] -> S.Select fields
+valuesUnsafe = values
+
+-- | Forward compatible version of unsafe 'valuesExplicit' that will
+-- not be deprecated in 0.7, but in 0.8.
+valuesUnsafeExplicit :: U.Unpackspec fields fields'
+ -> V.Valuesspec fields fields'
+ -> [fields] -> S.Select fields'
+valuesUnsafeExplicit = valuesExplicit