diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- a/Doc/Tutorial/TutorialAdvanced.lhs +++ b/Doc/Tutorial/TutorialAdvanced.lhs @@ -72,4 +72,4 @@ =============== > 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 --- 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 @@ 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 --- 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 @@ 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 --- 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 @@ > 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 @@ 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 --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -50,7 +50,7 @@ > delete :: Delete Int64 > delete = Delete > { dTable = myTable -> , dWhere = (\(_, x, y, _) -> x .< y) +> , dWhere = \(_, x, y, _) -> x .< y > , dReturning = rCount > } @@ -133,7 +133,7 @@ > 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 --- /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 --- /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 --- /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 --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -1,269 +1,288 @@ +{-# 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] +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 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 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] } +newtype SelectArrDenotation a b = + SelectArrDenotation { unSelectArrDenotation :: PGS.Connection -> [a] -> IO [b] } -data Order = Asc | Desc deriving Show +type SelectDenotation = SelectArrDenotation () -unpackColumns :: O.Unpackspec Columns Columns -unpackColumns = eitherPP +instance Functor (SelectArrDenotation a) where + fmap f = SelectArrDenotation + . (fmap . fmap . fmap . fmap) f + . unSelectArrDenotation -instance Show ArbitraryQuery where - show (ArbitraryQuery q) = maybe "Empty query" id - (O.showSqlForPostgresExplicit unpackColumns q) +instance Applicative (SelectArrDenotation a) where + pure = SelectArrDenotation . pure . pure . pure . pure + f <*> x = SelectArrDenotation ((liftA2 . liftA2 . liftA2 . liftA2) ($) + (unSelectArrDenotation f) + (unSelectArrDenotation x)) -instance Show ArbitraryGarble where - show = const "A permutation" +instance Category SelectArrDenotation where + id = SelectArrDenotation (\_ -> pure) + (.) = \(SelectArrDenotation f) (SelectArrDenotation g) -> + SelectArrDenotation (\conn -> f conn <=< g conn) -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) +runSelectArrDenotation :: SelectArrDenotation a b + -> a + -> PGS.Connection + -> IO [b] +runSelectArrDenotation sab a conn = unSelectArrDenotation sab conn [a] - , do - ArbitraryQuery q <- TQ.arbitrary - f <- TQ.arbitrary - aq (fmap (unArbitraryGarble f) q) +onList :: ([a] -> [b]) -> SelectDenotation a -> SelectDenotation b +onList f = SelectArrDenotation . (fmap . fmap . fmap) f . unSelectArrDenotation - , 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 +-- 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 -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) +optionalDenotation :: [Haskells] -> [Maybe Haskells] +optionalDenotation = \case + [] -> [Nothing] + xs -> map Just xs -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) +optionalRestrictDenotation :: [Haskells] -> [Maybe Haskells] +optionalRestrictDenotation = optionalDenotation . restrictFirstBoolList -instance TQ.Arbitrary ArbitraryPositiveInt where - arbitrary = fmap ArbitraryPositiveInt (TQ.choose (0, 100)) +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) -instance TQ.Arbitrary ArbitraryOrder where - arbitrary = fmap ArbitraryOrder - (TQ.listOf ((,) - <$> TQ.oneof [return Asc, return Desc] - <*> TQ.choose (0, 100))) + justs' <- f conn justs + let _ = justs' :: [Haskells] -odds :: [a] -> [a] -odds [] = [] -odds (x:xs) = x : evens xs + return ((Just <$> justs') + ++ (Nothing <$ nothings)))) -evens :: [a] -> [a] -evens [] = [] -evens (_:xs) = odds xs +lateralDenotation :: (a -> SelectDenotation r) + -> SelectArrDenotation a r +lateralDenotation f = SelectArrDenotation (\conn l -> + concatMapM (\r -> unSelectArrDenotation (f r) conn [()]) l) -instance TQ.Arbitrary ArbitraryGarble where - arbitrary = do - i <- TQ.choose (0 :: Int, 4) +pureList :: [a] -> SelectDenotation a +pureList = SelectArrDenotation . pure . pure . pure - 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)) +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = fmap concat . mapM f -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 +denotationExplicit :: O.FromFields fields a + -> O.Select fields + -> SelectDenotation a +denotationExplicit qr q = + SelectArrDenotation (\conn rs -> + flip concatMapM rs (\() -> O.runSelectExplicit qr conn q)) -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 +denotation :: O.Select Fields -> SelectDenotation Haskells +denotation = denotationExplicit fromFieldsFields -instance Functor QueryDenotation where - fmap f = QueryDenotation . (fmap . fmap . fmap) f .unQueryDenotation +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)) -pureList :: [a] -> QueryDenotation a -pureList = QueryDenotation . pure . pure +denotation2 :: O.Select (Fields, Fields) + -> SelectDenotation (Haskells, Haskells) +denotation2 = denotationExplicit (fromFieldsFields PP.***! fromFieldsFields) -instance Applicative QueryDenotation where - pure = QueryDenotation . pure . pure . pure - f <*> x = QueryDenotation ((liftA2 . liftA2 . liftA2) ($) - (unQueryDenotation f) (unQueryDenotation x)) +denotationMaybeFields :: O.Select (O.MaybeFields Fields) + -> SelectDenotation (Maybe Haskells) +denotationMaybeFields = + denotationExplicit (O.fromFieldsMaybeFields fromFieldsFields) -denotation :: O.QueryRunner columns a -> O.Query columns -> QueryDenotation a -denotation qr q = QueryDenotation (\conn -> O.runQueryExplicit qr conn q) +unSelectDenotations :: Connection + -> SelectDenotation a + -> SelectDenotation b + -> ([a] -> [b] -> IO TQ.Property) + -> IO TQ.Property +unSelectDenotations conn one two k = unSelectArrDenotations conn one two () k -denotation' :: O.Query Columns -> QueryDenotation Haskells -denotation' = denotation eitherPP +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 -denotation2 :: O.Query (Columns, Columns) - -> QueryDenotation (Haskells, Haskells) -denotation2 = denotation (eitherPP PP.***! eitherPP) + 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') +-- 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!") -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') + return (one' === two') -compareSortedBy :: Ord a +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)) +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 -apply :: PGS.Connection -> ArbitraryQuery -> ArbitraryQuery -> IO Bool -apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) = - compare' conn (denotation2 ((,) <$> q1 <*> q2)) - ((,) <$> denotation' q1 <*> denotation' q2) +-- 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 -- limit. Without some ordering applied before the limit the returned @@ -272,77 +291,134 @@ -- 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 + 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) + 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)) +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 :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool -order conn o (ArbitraryQuery 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)) +restrict :: Connection -> ArbitrarySelect -> IO TQ.Property +restrict conn (ArbitrarySelect q) = + compare conn (denotation (restrictFirstBool <<< 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)) +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 @@ -- { 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 @@ 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 @@ 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 @@ -402,22 +490,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 diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -24,10 +24,13 @@ 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 @@ 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. - -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. - -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. - - "The denotation is an arrow morphism" means that for each arrow - operation, the denotation preserves the operation. If we have - - f :: QueryArr wiresa wiresb - - then [f] should be something like - - [f] :: a -> IO [b] - f as = runQuery (toValues as >>> f) - - For example, take the operation >>>. We need to check that - - [f >>> g] = [f] >>> [g] +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. - for all f and g, where [] means the denotation. We would also want - to check that +For example, using brackets "[.]" to stand for denotation, we want to +ensure the property - [id] = id +* [f <<< g] = [f] <<< [g] - and +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 - [first f] = first [f] +* [id] = id - I think checking these operations is sufficient because all the - other QueryArr operations are implemented in terms of them. +* [f <*> g] = [f] <*> [g] - (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.)) +as well as Postgres-specific properties like - 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. +* [restrict] = guard -Note ----- +* [limit n q] = arr (take n) . [q] -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ ] ] -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 (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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ , (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 @@ -- | 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 @@ -- 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 @@ -- 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 @@ ] 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 = 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 @@ 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 @@ 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 @@ 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 @@ {- 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 @@ 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 @@ , (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 @@ 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 @@ 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 @@ 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 @@ _ <- 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 @@ , (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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ `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 + conn <- PGS.connectPostgreSQL connectString + dropAndCreateDB conn - let insert (t, d) = do { _ <- O.runInsertMany conn t d; return () } + 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, table1columndata) - , (table2, table2columndata) - , (table3, table3columndata) - , (table4, table4columndata) ] - insert (table6, table6columndata) - insert (table7, table7columndata) - insert (table8, table8columndata) - insert (table9, table9columndata) + 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 @@ describe "uncat" $ do testKeywordColNames testInsertSerial - testInQuery + testInSelect testAtTimeZone testUnionAll testTableFunctor @@ -1226,8 +1321,10 @@ 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 --- a/Test/TypeFamilies.hs +++ b/Test/TypeFamilies.hs @@ -18,4 +18,4 @@ :~ (((->) :<$> 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 --- /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 --- 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 @@ 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 @@ , 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 @@ , 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 @@ Opaleye.FunctionalJoin, Opaleye.Join, Opaleye.Label, + Opaleye.Lateral, Opaleye.Manipulation, Opaleye.Map, + Opaleye.MaybeFields, Opaleye.Operators, Opaleye.Order, Opaleye.PGTypes, @@ -78,7 +81,9 @@ 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 @@ 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 --- a/src/Opaleye.hs +++ b/src/Opaleye.hs @@ -13,7 +13,8 @@ -- * If you are confused about the @Default@ typeclass, then -- the -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.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.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 @@ 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.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 --- /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 --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -53,15 +53,18 @@ {-| 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. Postgres returns a single row whereas Opaleye returns zero rows. @@ -72,7 +75,7 @@ -} 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 @@ 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 --- a/src/Opaleye/Binary.hs +++ b/src/Opaleye/Binary.hs @@ -18,11 +18,16 @@ -- -> 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 -- only because of the typeclass constraint it has. @@ -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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 --- 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 @@ -- 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 --- a/src/Opaleye/Field.hs +++ b/src/Opaleye/Field.hs @@ -80,3 +80,6 @@ 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 --- 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 --- a/src/Opaleye/Internal/Aggregate.hs +++ b/src/Opaleye/Internal/Aggregate.hs @@ -27,14 +27,15 @@ 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,26 +74,61 @@ -- @ 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)) +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 + :: 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 -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" + 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)) + + pure (HPQ.AttrExpr souter) + -- { Boilerplate instances instance Functor (Aggregator a) where @@ -106,8 +142,8 @@ 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 --- a/src/Opaleye/Internal/Binary.hs +++ b/src/Opaleye/Internal/Binary.hs @@ -11,7 +11,7 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 @@ -- 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 @@ 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 @@ 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 --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -15,10 +15,12 @@ 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 '\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 --- 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.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 @@ -> ((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 @@ 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 @@ 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 --- /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 --- a/src/Opaleye/Internal/Manipulation.hs +++ b/src/Opaleye/Internal/Manipulation.hs @@ -118,8 +118,8 @@ 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 --- /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 --- 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.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 @@ -> 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 @@ -> (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 --- a/src/Opaleye/Internal/Optimize.hs +++ b/src/Opaleye/Internal/Optimize.hs @@ -8,28 +8,29 @@ 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 @@ 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 @@ 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 --- a/src/Opaleye/Internal/PackMap.hs +++ b/src/Opaleye/Internal/PackMap.hs @@ -9,7 +9,7 @@ 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 @@ -- '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 @@ -- -- 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 @@ -- | 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 @@ 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 --- a/src/Opaleye/Internal/PrimQuery.hs +++ b/src/Opaleye/Internal/PrimQuery.hs @@ -3,6 +3,7 @@ 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 @@ | 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 @@ 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 @@ 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 @@ | 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 @@ { 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 @@ -> 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 @@ , label = Label , relExpr = RelExpr , existsf = Exists + , rebind = Rebind } foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p @@ -116,23 +148,24 @@ 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 --- 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 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 @@ $$ 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.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 (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 --- 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.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 @@ 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 @@ 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,12 +111,19 @@ 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 <<<) 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 --- 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 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 @@ -- { 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 @@ (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 = 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 @@ -- 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 @@ -- } 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 --- 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 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 @@ 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 @@ , PQ.label = label , PQ.relExpr = relExpr , PQ.existsf = exists + , PQ.rebind = rebind } exists :: Bool -> Select -> Select -> Select @@ -103,7 +107,7 @@ 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 @@ 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 } + where ss' = flip fmap ss $ Arr.first $ \case + PQ.Lateral -> Lateral + PQ.NonLateral -> NonLateral -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. +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 @@ 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 @@ , 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 @@ , 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 @@ 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 @@ 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 --- a/src/Opaleye/Internal/Table.hs +++ b/src/Opaleye/Internal/Table.hs @@ -15,7 +15,7 @@ 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 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 @@ -- , 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 @@ -- | 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 @@ 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 @@ 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 @@ 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 --- a/src/Opaleye/Internal/TableMaker.hs +++ b/src/Opaleye/Internal/TableMaker.hs @@ -8,7 +8,7 @@ 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 @@ 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 --- a/src/Opaleye/Internal/Unpackspec.hs +++ b/src/Opaleye/Internal/Unpackspec.hs @@ -8,7 +8,7 @@ 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 @@ -- '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 @@ 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 --- a/src/Opaleye/Internal/Values.hs +++ b/src/Opaleye/Internal/Values.hs @@ -8,10 +8,13 @@ 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 @@ -> (() -> 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 @@ 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 --- 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 @@ 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 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 @@ -> 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 @@ -- 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 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 @@ -- ^ 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 = 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 --- a/src/Opaleye/Label.hs +++ b/src/Opaleye/Label.hs @@ -5,5 +5,5 @@ 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 --- /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 --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -170,11 +170,12 @@ -- | 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 @@ -- | 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 @@ 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 @@ -- '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 --- 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 --- /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 --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -26,7 +26,7 @@ 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 @@ '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 @@ -- | 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 @@ -- | 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 @@ -- 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 @@ -- | 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 --- 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 @@ -} 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 @@ -- * 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 @@ @ -} 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 @@ -- 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 --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -110,7 +110,8 @@ 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 @@ 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 --- a/src/Opaleye/RunSelect.hs +++ b/src/Opaleye/RunSelect.hs @@ -7,7 +7,12 @@ -- * 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 @@ -- * 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 @@ -- | 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 --- 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 - -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 () +module Opaleye.Select (Select, SelectArr) where --- | 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 --- a/src/Opaleye/Sql.hs +++ b/src/Opaleye/Sql.hs @@ -19,9 +19,9 @@ -- * 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 @@ -> 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 --- 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 --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {- | @@ -66,15 +65,18 @@ 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 @@ -> 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 --- 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 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