diff --git a/Doc/Tutorial/TutorialBasic.lhs b/Doc/Tutorial/TutorialBasic.lhs --- a/Doc/Tutorial/TutorialBasic.lhs +++ b/Doc/Tutorial/TutorialBasic.lhs @@ -22,7 +22,7 @@ > import Data.Profunctor.Product.TH (makeAdaptorAndInstance) > import Data.Time.Calendar (Day) > -> import Control.Arrow (returnA, (<<<)) +> import Control.Arrow (returnA) > > import qualified Database.PostgreSQL.Simple as PGS @@ -599,11 +599,11 @@ > aggregateWidgets :: Query (Widget (Column PGText) (Column PGText) (Column PGInt8) > (Column PGInt4) (Column PGFloat8)) -> aggregateWidgets = aggregate (pWidget (Widget { style = groupBy -> , color = groupBy -> , location = count -> , quantity = sum -> , radius = avg })) +> aggregateWidgets = aggregate (pWidget Widget { style = groupBy +> , color = groupBy +> , location = count +> , quantity = sum +> , radius = avg }) > (queryTable widgetTable) The generated SQL is diff --git a/Doc/Tutorial/TutorialBasicMonomorphic.lhs b/Doc/Tutorial/TutorialBasicMonomorphic.lhs --- a/Doc/Tutorial/TutorialBasicMonomorphic.lhs +++ b/Doc/Tutorial/TutorialBasicMonomorphic.lhs @@ -17,7 +17,7 @@ > > import qualified Opaleye as O > -> import Control.Applicative ((<$>), (<*>), Applicative) +> import Control.Applicative ((<$>), (<*>)) > > import qualified Data.Profunctor as P > import Data.Profunctor.Product (p3) diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -9,7 +9,7 @@ > PGInt4, PGFloat8) > > import Data.Profunctor.Product (p4) -> import Data.Profunctor.Product.Default (Default, def) +> import Data.Profunctor.Product.Default (def) > import qualified Opaleye.Internal.Unpackspec as U > import qualified Opaleye.PGTypes as P > import qualified Opaleye.Constant as C diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Brief introduction to Opaleye [![Hackage version](https://img.shields.io/hackage/v/opaleye.svg?style=flat)](https://hackage.haskell.org/package/opaleye) [![Build Status](https://img.shields.io/travis/tomjaguarpaw/haskell-opaleye.svg?style=flat)](https://travis-ci.org/tomjaguarpaw/haskell-opaleye) +# Brief introduction to Opaleye [![Hackage version](https://img.shields.io/hackage/v/opaleye.svg?label=Hackage)](https://hackage.haskell.org/package/opaleye) [![Linux Build Status](https://img.shields.io/travis/tomjaguarpaw/haskell-opaleye.svg?label=Linux%20build)](https://travis-ci.org/tomjaguarpaw/haskell-opaleye) Opaleye is a Haskell library that provides an SQL-generating embedded domain specific language for targeting Postgres. You need Opaleye if @@ -64,6 +64,15 @@ The interface of `Internal` modules does not follow the PVP and may break between minor releases, so be careful. + +# Running tests + +You must have running PostgreSQL server to run tests. Specify the database +by setting the `POSTGRES_CONNSTRING` environment variable: + +``` +POSTGRES_CONNSTRING="user=tom dbname=opaleye_test" stack test +``` # Commercial support diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -243,7 +243,7 @@ one' <- unQueryDenotation one conn two' <- unQueryDenotation two conn return ((sort one' == sort two') - && (isSortedBy o one')) + && isSortedBy o one') -- } @@ -255,12 +255,12 @@ (pure c) fmap' :: PGS.Connection -> ArbitraryGarble -> ArbitraryQuery -> IO Bool -fmap' conn f (ArbitraryQuery q) = do +fmap' conn f (ArbitraryQuery q) = compareNoSort conn (denotation' (fmap (unArbitraryGarble f) q)) (onList (fmap (unArbitraryGarble f)) (denotation' q)) apply :: PGS.Connection -> ArbitraryQuery -> ArbitraryQuery -> IO Bool -apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) = do +apply conn (ArbitraryQuery q1) (ArbitraryQuery q2) = compare' conn (denotation2 ((,) <$> q1 <*> q2)) ((,) <$> denotation' q1 <*> denotation' q2) @@ -299,19 +299,19 @@ && condBool) offset :: PGS.Connection -> ArbitraryPositiveInt -> ArbitraryQuery -> IO Bool -offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = do +offset conn (ArbitraryPositiveInt l) (ArbitraryQuery q) = compareNoSort conn (denotation' (O.offset l q)) (onList (drop l) (denotation' q)) order :: PGS.Connection -> ArbitraryOrder -> ArbitraryQuery -> IO Bool -order conn o (ArbitraryQuery q) = do +order conn o (ArbitraryQuery q) = compareSortedBy (arbitraryOrdering o) conn (denotation' (O.orderBy (arbitraryOrder o) q)) (denotation' q) distinct :: PGS.Connection -> ArbitraryQuery -> IO Bool -distinct conn (ArbitraryQuery q) = do +distinct conn (ArbitraryQuery q) = compare' conn (denotation' (O.distinctExplicit eitherPP q)) (onList nub (denotation' q)) @@ -319,12 +319,12 @@ -- consequences to do with the order of the returned rows and so -- restrict had to start being compared sorted. restrict :: PGS.Connection -> ArbitraryQuery -> IO Bool -restrict conn (ArbitraryQuery q) = do +restrict conn (ArbitraryQuery q) = compare' conn (denotation' (restrictFirstBool Arrow.<<< q)) (onList restrictFirstBoolList (denotation' q)) values :: PGS.Connection -> ArbitraryColumnsList -> IO Bool -values conn (ArbitraryColumnsList l) = do +values conn (ArbitraryColumnsList l) = compareNoSort conn (denotation' (fmap columnsList (O.values (fmap O.constant l)))) (pureList (fmap columnsList l)) diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -23,36 +23,18 @@ import qualified Data.Aeson as Json import qualified Data.Text as T -import qualified System.Exit as Exit -import qualified System.Environment as Environment +import System.Environment (lookupEnv) -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>), (<*>), (<|>)) import qualified Control.Applicative as A import qualified Control.Arrow as Arr import Control.Arrow ((&&&), (***), (<<<), (>>>)) import GHC.Int (Int64) --- { Set your test database info here. Then invoke the 'main' --- function to run the tests, or just use 'cabal test'. The test --- database must already exist and the test user must have --- permissions to modify it. - -connectInfo :: PGS.ConnectInfo -connectInfo = PGS.ConnectInfo { PGS.connectHost = "localhost" - , PGS.connectPort = 25433 - , PGS.connectUser = "tom" - , PGS.connectPassword = "tom" - , PGS.connectDatabase = "opaleye_test" } - -connectInfoTravis :: PGS.ConnectInfo -connectInfoTravis = PGS.ConnectInfo { PGS.connectHost = "localhost" - , PGS.connectPort = 5432 - , PGS.connectUser = "postgres" - , PGS.connectPassword = "" - , PGS.connectDatabase = "opaleye_test" } +import Test.Hspec --- } +import qualified Configuration.Dotenv as Dotenv {- @@ -257,7 +239,7 @@ where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";" ++ "CREATE TABLE \"public\".\"" ++ t ++ "\"" ++ " (" ++ commas cols ++ ");" - integer c = ("\"" ++ c ++ "\"" ++ " " ++ columnType) + integer c = "\"" ++ c ++ "\"" ++ " " ++ columnType commas = L.intercalate "," . map integer dropAndCreateTableInt :: (String, [String]) -> PGS.Query @@ -273,7 +255,7 @@ where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";" ++ "CREATE TABLE \"public\".\"" ++ t ++ "\"" ++ " (" ++ commas cols ++ ");" - integer c = ("\"" ++ c ++ "\"" ++ " SERIAL") + integer c = "\"" ++ c ++ "\"" ++ " SERIAL" commas = L.intercalate "," . map integer dropAndCreateTableJson :: (String, [String]) -> PGS.Query @@ -319,61 +301,80 @@ executeJson = PGS.execute_ conn . dropAndCreateTableJson -- executeJsonb = PGS.execute_ conn . dropAndCreateTableJsonb -type Test = PGS.Connection -> IO Bool +type Test = SpecWith PGS.Connection -testG :: D.Default O.QueryRunner wires haskells => +testH :: D.Default O.QueryRunner wires haskells => Query wires - -> ([haskells] -> b) + -> ([haskells] -> IO expectation) -> PGS.Connection - -> IO b -testG q p conn = do + -> IO expectation + +testH q p conn = do result <- O.runQuery conn q - return (p result) + p result +queryShouldReturnSorted :: (D.Default O.QueryRunner wires haskells, Show haskells, Ord haskells) => + Query wires + -> [haskells] + -> PGS.Connection + -> Expectation +queryShouldReturnSorted q expected = testH q (\res -> L.sort res `shouldBe` L.sort expected) + testSelect :: Test -testSelect = testG table1Q - (\r -> L.sort table1data == L.sort r) +testSelect = it "selects" $ table1Q `queryShouldReturnSorted` table1data testProduct :: Test -testProduct = testG query - (\r -> L.sort (A.liftA2 (,) table1data table2data) == L.sort r) +testProduct = it "joins tables" $ query `queryShouldReturnSorted` (A.liftA2 (,) table1data table2data) where query = table1Q &&& table2Q testRestrict :: Test -testRestrict = testG query - (\r -> filter ((== 1) . fst) (L.sort table1data) == L.sort r) +testRestrict = it "restricts the rows returned" $ query `queryShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data) where query = 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 + t <- table1Q -< () + () <- O.exists (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 + t <- table1Q -< () + () <- O.notExists (proc t -> do + t' <- table1Q -< () + O.restrict -< fst t' .> fst t) -< t + Arr.returnA -< t + testIn :: Test -testIn = testG query expected +testIn = it "restricts values to a range" $ query `queryShouldReturnSorted` filter (flip elem [100, 200] . snd) (L.sort table1data) where query = proc () -> do t <- table1Q -< () O.restrict -< O.in_ [O.pgInt4 100, O.pgInt4 200] (snd t) O.restrict -< O.not (O.in_ [] (fst t)) -- Making sure empty lists work. Arr.returnA -< t - expected = \r -> - filter (flip elem [100, 200] . snd) (L.sort table1data) == L.sort r testNum :: Test -testNum = testG query expected +testNum = it "" $ query `queryShouldReturnSorted` (map op table1data) where query :: Query (Column O.PGInt4) query = proc () -> do t <- table1Q -< () Arr.returnA -< op t - expected = \r -> L.sort (map op table1data) == L.sort r op :: Num a => (a, a) -> a op (x, y) = abs (x - 5) * signum (x - 4) * (y * y + 1) testDiv :: Test -testDiv = testG query expected +testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1data) where query :: Query (Column O.PGFloat8) query = proc () -> do t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< () Arr.returnA -< op t - expected r = L.sort (map (op . toDoubles) table1data) == L.sort r op :: Fractional a => (a, a) -> a -- Choosing 0.5 here as it should be exactly representable in -- floating point @@ -383,7 +384,7 @@ -- TODO: need to implement and test case_ returning tuples testCase :: Test -testCase = testG q (== expected) +testCase = it "" $ q `queryShouldReturnSorted` expected where q :: Query (Column O.PGInt4) q = table1Q >>> proc (i, j) -> do Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33 @@ -393,7 +394,7 @@ -- This tests case_ with an empty list of cases, to make sure it generates valid -- SQL. testCaseEmpty :: Test -testCaseEmpty = testG q (== expected) +testCaseEmpty = it "" $ q `queryShouldReturnSorted` expected where q :: Query (Column O.PGInt4) q = table1Q >>> proc _ -> Arr.returnA -< O.case_ [] 33 @@ -401,8 +402,7 @@ expected = [33, 33, 33, 33] testDistinct :: Test -testDistinct = testG (O.distinct table1Q) - (\r -> L.sort (L.nub table1data) == L.sort r) +testDistinct = it "" $ O.distinct table1Q `queryShouldReturnSorted` (L.nub table1data) -- FIXME: the unsafeCoerceColumn is currently needed because the type -- changes required for aggregation are not currently dealt with by @@ -414,137 +414,139 @@ aggregateCoerceFIXME' = O.unsafeCoerceColumn testAggregate :: Test -testAggregate = testG (Arr.second aggregateCoerceFIXME +testAggregate = it "" $ (Arr.second aggregateCoerceFIXME <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) - table1Q) - (\r -> [(1, 400) :: (Int, Int64), (2, 300)] == L.sort r) + table1Q) `queryShouldReturnSorted` [(1, 400) :: (Int, Int64), (2, 300)] testAggregate0 :: Test -testAggregate0 = testG (Arr.second aggregateCoerceFIXME +testAggregate0 = it "" $ (Arr.second aggregateCoerceFIXME <<< O.aggregate (PP.p2 (O.sum, O.sum)) (O.keepWhen (const (O.pgBool False)) - <<< table1Q)) - (== ([] :: [(Int, Int64)])) + <<< table1Q)) `queryShouldReturnSorted` ([] :: [(Int, Int64)]) testAggregateFunction :: Test -testAggregateFunction = testG (Arr.second aggregateCoerceFIXME +testAggregateFunction = it "" $ (Arr.second aggregateCoerceFIXME <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) (fmap (\(x, y) -> (x + 1, y)) table1Q)) - (\r -> [(2, 400) :: (Int, Int64), (3, 300)] == L.sort r) + `queryShouldReturnSorted` [(2, 400) :: (Int, Int64), (3, 300)] testAggregateProfunctor :: Test -testAggregateProfunctor = testG q expected +testAggregateProfunctor = it "" $ q `queryShouldReturnSorted` [(1, 1200) :: (Int, Int64), (2, 300)] where q = O.aggregate (PP.p2 (O.groupBy, countsum)) table1Q - expected r = [(1, 1200) :: (Int, Int64), (2, 300)] == L.sort r countsum = P.dimap (\x -> (x,x)) (\(x, y) -> aggregateCoerceFIXME' x * y) (PP.p2 (O.sum, O.count)) testStringArrayAggregate :: Test -testStringArrayAggregate = testG q expected +testStringArrayAggregate = it "" $ q `queryShouldReturnSorted` [(map fst table6data, minimum (map snd table6data))] where q = O.aggregate (PP.p2 (O.arrayAgg, O.min)) table6Q - expected r = [(map fst table6data, minimum (map snd table6data))] == r testStringAggregate :: Test -testStringAggregate = testG q expected +testStringAggregate = it "" $ q `queryShouldReturnSorted` expected where q = O.aggregate (PP.p2 ((O.stringAgg . O.pgString) "_", O.groupBy)) table6Q - expected r = [( + expected = [( (foldl1 (\x y -> x ++ "_" ++ y) . map fst) table6data , - head (map snd table6data))] == r + head (map snd table6data))] -- | Using aggregateOrdered applies the ordering to all aggregates. testStringArrayAggregateOrdered :: Test -testStringArrayAggregateOrdered = testG q expected +testStringArrayAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected where q = O.aggregateOrdered (O.asc snd) (PP.p2 (O.arrayAgg, O.stringAgg . O.pgString $ ",")) table7Q - expected r = [( map fst sortedData + expected = [( map fst sortedData , L.intercalate "," . map snd $ sortedData ) - ] == r + ] sortedData = L.sortBy (Ord.comparing snd) table7data -- | Using orderAggregate you can apply different orderings to -- different aggregates. testMultipleAggregateOrdered :: Test -testMultipleAggregateOrdered = testG q expected +testMultipleAggregateOrdered = it "" $ q `queryShouldReturnSorted` 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 $ ",")) ) table7Q - expected r = [( map fst . L.sortBy (Ord.comparing snd) $ table7data + expected = [( map fst . L.sortBy (Ord.comparing snd) $ table7data , L.intercalate "," . map snd . L.sortBy (Ord.comparing (Ord.Down . snd)) $ table7data ) - ] == r + ] -- | Applying an order to an ordered aggregate overwrites the old -- order, just like with ordered queries. -- testOverwriteAggregateOrdered :: Test -testOverwriteAggregateOrdered = testG q expected +testOverwriteAggregateOrdered = it "" $ q `queryShouldReturnSorted` expected where q = O.aggregate ( IA.orderAggregate (O.asc snd) . IA.orderAggregate (O.desc snd) $ PP.p2 (O.arrayAgg, O.max) ) table7Q - expected r = [( map fst (L.sortBy (Ord.comparing snd) table7data) + expected = [( map fst (L.sortBy (Ord.comparing snd) table7data) , maximum (map snd table7data) ) - ] == r + ] testCountRows0 :: Test -testCountRows0 = testG q expected +testCountRows0 = it "" $ q `queryShouldReturnSorted` [0 :: Int64] where q = O.countRows (O.keepWhen (const (O.pgBool False)) <<< table7Q) - expected = (== [0 :: Int64]) testCountRows3 :: Test -testCountRows3 = testG q expected +testCountRows3 = it "" $ q `queryShouldReturnSorted` [3 :: Int64] where q = O.countRows table7Q - expected = (== [3 :: Int64]) -testOrderByG :: O.Order (Column O.PGInt4, Column O.PGInt4) +queryShouldReturnSortBy :: O.Order (Column O.PGInt4, Column O.PGInt4) -> ((Int, Int) -> (Int, Int) -> Ordering) - -> Test -testOrderByG orderQ order = testG (O.orderBy orderQ table1Q) - (L.sortBy order table1data ==) + -> (PGS.Connection -> Expectation) +queryShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q) + (L.sortBy order table1data `shouldBe`) testOrderBy :: Test -testOrderBy = testOrderByG (O.desc snd) +testOrderBy = it "" $ queryShouldReturnSortBy (O.desc snd) (flip (Ord.comparing snd)) testOrderBy2 :: Test -testOrderBy2 = testOrderByG (O.desc fst <> O.asc snd) +testOrderBy2 = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc snd) (flip (Ord.comparing fst) <> Ord.comparing snd) testOrderBySame :: Test -testOrderBySame = testOrderByG (O.desc fst <> O.asc fst) +testOrderBySame = it "" $ queryShouldReturnSortBy (O.desc fst <> O.asc fst) (flip (Ord.comparing fst) <> Ord.comparing fst) -testLOG :: (Query (Column O.PGInt4, Column O.PGInt4) -> Query (Column O.PGInt4, Column O.PGInt4)) - -> ([(Int, Int)] -> [(Int, Int)]) -> Test -testLOG olQ ol = testG (olQ (orderQ table1Q)) - (ol (order table1data) ==) +testOrderExact :: Test +testOrderExact = it "" $ testH (O.orderBy (O.exact cols snd) table1Q) (result `shouldBe`) + where cols = map O.constant [300,200::Int] + result = [ (2::Int, 300::Int) + , (1, 200) + , (1, 100) + , (1, 100) + ] + +limitOrderShouldMatch :: (Query (Column O.PGInt4, Column O.PGInt4) -> Query (Column O.PGInt4, Column O.PGInt4)) + -> ([(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) order = L.sortBy (flip (Ord.comparing snd)) testLimit :: Test -testLimit = testLOG (O.limit 2) (take 2) +testLimit = it "" $ limitOrderShouldMatch (O.limit 2) (take 2) testOffset :: Test -testOffset = testLOG (O.offset 2) (drop 2) +testOffset = it "" $ limitOrderShouldMatch (O.offset 2) (drop 2) testLimitOffset :: Test -testLimitOffset = testLOG (O.limit 2 . O.offset 2) (take 2 . drop 2) +testLimitOffset = it "" $ limitOrderShouldMatch (O.limit 2 . O.offset 2) (take 2 . drop 2) testOffsetLimit :: Test -testOffsetLimit = testLOG (O.offset 2 . O.limit 2) (drop 2 . take 2) +testOffsetLimit = it "" $ limitOrderShouldMatch (O.offset 2 . O.limit 2) (drop 2 . take 2) testDistinctAndAggregate :: Test -testDistinctAndAggregate = testG q expected +testDistinctAndAggregate = it "" $ q `queryShouldReturnSorted` expectedResult where q = O.distinct table1Q &&& (Arr.second aggregateCoerceFIXME <<< O.aggregate (PP.p2 (O.groupBy, O.sum)) table1Q) - expected r = L.sort r == L.sort expectedResult expectedResult = A.liftA2 (,) (L.nub table1data) [(1 :: Int, 400 :: Int64), (2, 300)] @@ -553,31 +555,31 @@ -- The point of the "double" tests is to ensure that we do not -- introduce name clashes in the operations which create new column names -testDoubleG :: (Eq haskells, D.Default O.QueryRunner columns haskells) => +testDoubleH :: (Show haskells, Eq haskells, D.Default O.QueryRunner columns haskells) => (QueryArr () (Column O.PGInt4) -> QueryArr () columns) -> [haskells] - -> Test -testDoubleG q expected1 = testG (q one &&& q one) (== expected2) + -> (PGS.Connection -> Expectation) +testDoubleH q expected1 = testH (q one &&& q one) (`shouldBe` expected2) where expected2 = A.liftA2 (,) expected1 expected1 testDoubleDistinct :: Test -testDoubleDistinct = testDoubleG O.distinct [1 :: Int] +testDoubleDistinct = it "" $ testDoubleH O.distinct [1 :: Int] testDoubleAggregate :: Test -testDoubleAggregate = testDoubleG (O.aggregate O.count) [1 :: Int64] +testDoubleAggregate = it "" $ testDoubleH (O.aggregate O.count) [1 :: Int64] testDoubleLeftJoin :: Test -testDoubleLeftJoin = testDoubleG lj [(1 :: Int, Just (1 :: Int))] +testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))] where lj :: Query (Column O.PGInt4) -> Query (Column O.PGInt4, Column (Nullable O.PGInt4)) lj q = O.leftJoin q q (uncurry (.==)) testDoubleValues :: Test -testDoubleValues = testDoubleG v [1 :: Int] +testDoubleValues = it "" $ testDoubleH v [1 :: Int] where v :: Query (Column O.PGInt4) -> Query (Column O.PGInt4) v _ = O.values [1] testDoubleUnionAll :: Test -testDoubleUnionAll = testDoubleG u [1 :: Int, 1] +testDoubleUnionAll = it "" $ testDoubleH u [1 :: Int, 1] where u q = q `O.unionAll` q aLeftJoin :: Query ((Column O.PGInt4, Column O.PGInt4), @@ -585,7 +587,7 @@ aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r) testLeftJoin :: Test -testLeftJoin = testG aLeftJoin (== expected) +testLeftJoin = it "" $ testH aLeftJoin (`shouldBe` expected) where expected :: [((Int, Int), (Maybe Int, Maybe Int))] expected = [ ((1, 100), (Just 1, Just 50)) , ((1, 100), (Just 1, Just 50)) @@ -593,7 +595,7 @@ , ((2, 300), (Nothing, Nothing)) ] testLeftJoinNullable :: Test -testLeftJoinNullable = testG q (== expected) +testLeftJoinNullable = it "" $ testH q (`shouldBe` expected) where q :: Query ((Column O.PGInt4, Column O.PGInt4), ((Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)), (Column (Nullable O.PGInt4), @@ -608,7 +610,7 @@ , ((1, 50), ((Just 1, Just 200), (Just 1, Just 50))) ] testLeftJoinF :: Test -testLeftJoinF = testG q (== expected) +testLeftJoinF = it "" $ testH q (`shouldBe` expected) where q = O.leftJoinF (,) (\x -> (x, (-1, -2))) (\l r -> fst l .== fst r) @@ -622,12 +624,12 @@ , ((2, 300), (-1, -2)) ] testThreeWayProduct :: Test -testThreeWayProduct = testG q (== expected) +testThreeWayProduct = it "" $ testH q (`shouldBe` expected) where q = A.liftA3 (,,) table1Q table2Q table3Q expected = A.liftA3 (,,) table1data table2data table3data testValues :: Test -testValues = testG (O.values values) (values' ==) +testValues = it "" $ testH (O.values values) (values' `shouldBe`) where values :: [(Column O.PGInt4, Column O.PGInt4)] values = [ (1, 10) , (2, 100) ] @@ -647,40 +649,36 @@ -} testValuesEmpty :: Test -testValuesEmpty = testG (O.values values) (values' ==) +testValuesEmpty = it "" $ testH (O.values values) (values' `shouldBe`) where values :: [Column O.PGInt4] values = [] values' :: [Int] values' = [] testUnionAll :: Test -testUnionAll = testG (table1Q `O.unionAll` table2Q) - (\r -> L.sort (table1data ++ table2data) == L.sort r) +testUnionAll = it "" $ (table1Q `O.unionAll` table2Q) `queryShouldReturnSorted` (table1data ++ table2data) testTableFunctor :: Test -testTableFunctor = testG (O.queryTable table1F) (result ==) +testTableFunctor = it "" $ testH (O.queryTable table1F) (result `shouldBe`) where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data -- TODO: This is getting too complicated testUpdate :: Test -testUpdate conn = do +testUpdate = it "" $ \conn -> do _ <- O.runUpdate conn table4 update cond - result <- runQueryTable4 + result <- runQueryTable4 conn + result `shouldBe` expected - if result /= expected - then return False - else do - _ <- O.runDelete conn table4 condD - resultD <- runQueryTable4 + _ <- O.runDelete conn table4 condD + resultD <- runQueryTable4 conn + resultD `shouldBe` expectedD - if resultD /= expectedD - then return False - else do - returned <- O.runInsertManyReturning conn table4 insertT returning - _ <- O.runInsertMany conn table4 insertTMany - resultI <- runQueryTable4 + returned <- O.runInsertManyReturning conn table4 insertT returning + _ <- O.runInsertMany conn table4 insertTMany + resultI <- runQueryTable4 conn - return ((resultI == expectedI) && (returned == expectedR)) + resultI `shouldBe` expectedI + returned `shouldBe` expectedR where update (x, y) = (x + y, x - y) cond (_, y) = y .> 15 @@ -690,7 +688,7 @@ , (22, -18)] expectedD :: [(Int, Int)] expectedD = [(1, 10)] - runQueryTable4 = O.runQuery conn (O.queryTable table4) + runQueryTable4 conn = O.runQuery conn (O.queryTable table4) insertT :: [(Column O.PGInt4, Column O.PGInt4)] insertT = [(1, 2), (3, 5)] @@ -705,14 +703,14 @@ expectedR = [-1, -2] testKeywordColNames :: Test -testKeywordColNames conn = do +testKeywordColNames = it "" $ \conn -> do let q :: IO [(Int, Int)] q = O.runQuery conn (O.queryTable tableKeywordColNames) _ <- q - return True + True `shouldBe` True testInsertSerial :: Test -testInsertSerial conn = do +testInsertSerial = it "" $ \conn -> do _ <- O.runInsert conn table5 (Just 10, Just 20) _ <- O.runInsert conn table5 (Just 30, Nothing) _ <- O.runInsert conn table5 (Nothing, Nothing) @@ -720,7 +718,7 @@ resultI <- O.runQuery conn (O.queryTable table5) - return (resultI == expected) + resultI `shouldBe` expected where expected :: [(Int, Int)] expected = [ (10, 20) @@ -729,41 +727,52 @@ , (2, 40) ] testInQuery :: Test -testInQuery conn = do - let q (x, e) = testG (O.inQuery x (O.queryTable table1)) (== [e]) conn +testInQuery = it "" $ \conn -> do + let q (x, e) = testH (O.inQuery x (O.queryTable table1)) (`shouldBe` [e]) conn - r <- mapM (q . (\x -> (x, True))) table1dataG - s <- mapM (q . (\(x, y) -> ((x, y+1), False))) table1dataG + mapM_ (q . (\x -> (x, True))) table1dataG + mapM_ (q . (\(x, y) -> ((x, y+1), False))) table1dataG - return (and r && and s) + -- and r && and s `shouldBe` True testAtTimeZone :: Test -testAtTimeZone = testG (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (== [t']) +testAtTimeZone = it "" $ testH (A.pure (O.timestamptzAtTimeZone t (O.pgString "CET"))) (`shouldBe` [t']) where t = O.pgUTCTime (Time.UTCTime d (Time.secondsToDiffTime 3600)) t' = Time.LocalTime d (Time.TimeOfDay 2 0 0) d = Time.fromGregorian 2015 1 1 testArrayLiterals :: Test -testArrayLiterals = testG (A.pure $ O.pgArray O.pgInt4 vals) (== [vals]) +testArrayLiterals = it "" $ testH (A.pure $ O.pgArray O.pgInt4 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 = testG (A.pure $ O.pgArray O.pgInt4 []) (== [[] :: [Int]]) +testEmptyArray = it "" $ testH (A.pure $ O.pgArray O.pgInt4 []) (`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 = testG (A.pure $ O.pgArray O.pgDouble doubles) (== [doubles]) +testFloatArray = it "" $ testH (A.pure $ O.pgArray O.pgDouble 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) + (`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) + (`shouldBe` ([Nothing] :: [Maybe Int])) + +type JsonTest a = SpecWith (Query (Column a) -> PGS.Connection -> Expectation) -- Test opaleye's equivalent of c1->'c' testJsonGetFieldValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test -testJsonGetFieldValue dataQuery = testG q (== expected) +testJsonGetFieldValue dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c" expected :: [Maybe Json.Value] @@ -771,7 +780,7 @@ -- Test opaleye's equivalent of c1->>'c' testJsonGetFieldText :: (O.PGIsJson a) => Query (Column a) -> Test -testJsonGetFieldText dataQuery = testG q (== expected) +testJsonGetFieldText dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c" expected :: [Maybe T.Text] @@ -779,7 +788,7 @@ -- Test opaleye's equivalent of c1->'a'->2 testJsonGetArrayValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test -testJsonGetArrayValue dataQuery = testG q (== expected) +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 expected :: [Maybe Json.Value] @@ -787,7 +796,7 @@ -- Test opaleye's equivalent of c1->'a'->>2 testJsonGetArrayText :: (O.PGIsJson a) => Query (Column a) -> Test -testJsonGetArrayText dataQuery = testG q (== expected) +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 expected :: [Maybe T.Text] @@ -796,7 +805,7 @@ -- Test opaleye's equivalent of c1->>'missing' -- Note that the missing field does not exist. testJsonGetMissingField :: (O.PGIsJson a) => Query (Column a) -> Test -testJsonGetMissingField dataQuery = testG q (== expected) +testJsonGetMissingField dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing" expected :: [Maybe T.Text] @@ -804,7 +813,7 @@ -- Test opaleye's equivalent of c1#>'{b,x}' testJsonGetPathValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test -testJsonGetPathValue dataQuery = testG q (== expected) +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"] expected :: [Maybe Json.Value] @@ -812,7 +821,7 @@ -- Test opaleye's equivalent of c1#>>'{b,x}' testJsonGetPathText :: (O.PGIsJson a) => Query (Column a) -> Test -testJsonGetPathText dataQuery = testG q (== expected) +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"] expected :: [Maybe T.Text] @@ -820,100 +829,77 @@ -- Test opaleye's equivalent of c1 @> '{"c":21}'::jsonb testJsonbRightInLeft :: Test -testJsonbRightInLeft = testG q (== [True]) +testJsonbRightInLeft = it "" $ testH q (`shouldBe` [True]) where q = table9Q >>> proc c1 -> do Arr.returnA -< c1 O..@> O.pgJSONB "{\"c\":21}" -- Test opaleye's equivalent of '{"c":21}'::jsonb <@ c1 testJsonbLeftInRight :: Test -testJsonbLeftInRight = testG q (== [True]) +testJsonbLeftInRight = it "" $ testH q (`shouldBe` [True]) where q = table9Q >>> proc c1 -> do Arr.returnA -< O.pgJSONB "{\"c\":21}" O..<@ c1 -- Test opaleye's equivalent of c1 ? 'b' testJsonbContains :: Test -testJsonbContains = testG q (== [True]) +testJsonbContains = it "" $ testH q (`shouldBe` [True]) where q = table9Q >>> proc c1 -> do Arr.returnA -< c1 O..? O.pgStrictText "c" -- Test opaleye's equivalent of c1 ? 'missing' -- Note that the missing field does not exist. testJsonbContainsMissing :: Test -testJsonbContainsMissing = testG q (== [False]) +testJsonbContainsMissing = it "" $ testH q (`shouldBe` [False]) where q = table9Q >>> proc c1 -> do Arr.returnA -< c1 O..? O.pgStrictText "missing" -- Test opaleye's equivalent of c1 ?| array['b', 'missing'] testJsonbContainsAny :: Test -testJsonbContainsAny = testG q (== [True]) +testJsonbContainsAny = it "" $ testH q (`shouldBe` [True]) where q = table9Q >>> proc c1 -> do Arr.returnA -< c1 O..?| O.pgArray O.pgStrictText ["b", "missing"] -- Test opaleye's equivalent of c1 ?& array['a', 'b', 'c'] testJsonbContainsAll :: Test -testJsonbContainsAll = testG q (== [True]) +testJsonbContainsAll = it "" $ testH q (`shouldBe` [True]) where q = table9Q >>> proc c1 -> do Arr.returnA -< c1 O..?& O.pgArray O.pgStrictText ["a", "b", "c"] testRangeOverlap :: Test -testRangeOverlap = testG q (== [True]) +testRangeOverlap = it "generates overlap" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 3 7) `O.overlap` (range 4 12) testRangeLeftOf :: Test -testRangeLeftOf = testG q (== [True]) +testRangeLeftOf = it "generates 'left of'" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 1 10) O..<< (range 100 110) testRangeRightOf :: Test -testRangeRightOf = testG q (== [True]) +testRangeRightOf = it "generates 'right of'" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 50 60) O..>> (range 20 30) testRangeRightExtension :: Test -testRangeRightExtension = testG q (== [True]) +testRangeRightExtension = it "generates right extension" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 1 20) O..&< (range 18 20) testRangeLeftExtension :: Test -testRangeLeftExtension = testG q (== [True]) +testRangeLeftExtension = it "generates left extension" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 7 20) O..&> (range 5 10) testRangeAdjacency :: Test -testRangeAdjacency = testG q (== [True]) +testRangeAdjacency = it "generates adjacency" $ testH q (`shouldBe` [True]) where range :: Int -> Int -> Column (O.PGRange O.PGInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b) q = A.pure $ (range 1 2) O..-|- (range 2 3) -allTests :: [Test] -allTests = [testSelect, testProduct, testRestrict, testNum, testDiv, testCase, - testDistinct, testAggregate, testAggregate0, testAggregateFunction, - testAggregateProfunctor, testStringArrayAggregate, testStringAggregate, - testOrderBy, testOrderBy2, testOrderBySame, testLimit, testOffset, - testLimitOffset, testOffsetLimit, testDistinctAndAggregate, testIn, - testDoubleDistinct, testDoubleAggregate, testDoubleLeftJoin, - testDoubleValues, testDoubleUnionAll, - testLeftJoin, testLeftJoinNullable, testThreeWayProduct, testValues, - testLeftJoinF, - testValuesEmpty, testUnionAll, testTableFunctor, testUpdate, - testKeywordColNames, testInsertSerial, testInQuery, testAtTimeZone, - testStringArrayAggregateOrdered, testMultipleAggregateOrdered, - testOverwriteAggregateOrdered, testCountRows0, testCountRows3, - testArrayLiterals, testEmptyArray, testFloatArray, testCaseEmpty, - testJsonGetFieldValue table8Q, testJsonGetFieldText table8Q, - testJsonGetMissingField table8Q, testJsonGetArrayValue table8Q, - testJsonGetArrayText table8Q, testJsonGetPathValue table8Q, - testJsonGetPathText table8Q, - testRangeOverlap, testRangeLeftOf, testRangeRightOf, - testRangeRightExtension, testRangeLeftExtension, testRangeAdjacency - ] - -- Note: these tests are left out of allTests until Travis supports -- Postgresql >= 9.4 jsonbTests :: [Test] @@ -926,30 +912,26 @@ testJsonbContainsAny, testJsonbContainsAll ] --- Environment.getEnv throws an exception on missing environment variable! -getEnv :: String -> IO (Maybe String) -getEnv var = do - environment <- Environment.getEnvironment - return (lookup var environment) - --- Using an envvar is unpleasant, but it will do for now. -travis :: IO Bool -travis = do - travis' <- getEnv "TRAVIS" - - return (case travis' of - Nothing -> False - Just "yes" -> True - Just _ -> False) - main :: IO () main = do - travis' <- travis + let envVarName = "POSTGRES_CONNSTRING" - let connectInfo' = if travis' then connectInfoTravis else connectInfo + connectStringEnvVar <- lookupEnv envVarName - conn <- PGS.connect connectInfo' + connectStringDotEnv <- do vars <- Dotenv.parseFile ".env" + return (lookup envVarName vars) + `Dotenv.onMissingFile` + return Nothing + let connectString = connectStringEnvVar <|> connectStringDotEnv + + conn <- 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 + dropAndCreateDB conn let insert (writeable, columndata) = @@ -968,12 +950,85 @@ -- Need to run quickcheck after table data has been inserted QuickCheck.run conn - results <- mapM ($ conn) allTests - - print results - - let passed = and results - - putStrLn (if passed then "All passed" else "Failure") - Exit.exitWith (if passed then Exit.ExitSuccess - else Exit.ExitFailure 1) + hspec $ do + before (return conn) $ do + describe "core dsl?" $ do + testSelect + testProduct + testRestrict + testExists + testNotExists + testIn + testNum + testDiv + describe "cases" $ do + testCase + testCaseEmpty + describe "aggregate" $ do + testAggregate + testAggregate0 + testAggregateFunction + testAggregateProfunctor + testStringArrayAggregate + testStringAggregate + testOverwriteAggregateOrdered + testMultipleAggregateOrdered + testStringArrayAggregateOrdered + testDistinctAndAggregate + testDoubleAggregate + describe "distinct" $ do + testDistinct + describe "order" $ do + testOrderBy + testOrderBy2 + testOrderBySame + testOrderExact + describe "count" $ do + testCountRows0 + testCountRows3 + describe "limit" $ do + testLimit + testOffset + testLimitOffset + testOffsetLimit + describe "double" $ do + testDoubleDistinct + testDoubleLeftJoin + testDoubleValues + testDoubleUnionAll + describe "arrays" $ do + testArrayLiterals + testEmptyArray + testFloatArray + testArrayIndex + testArrayIndexOOB + describe "joins" $ do + testLeftJoin + testLeftJoinNullable + testThreeWayProduct + testLeftJoinF + describe "json" $ do + testJsonGetFieldValue table8Q + testJsonGetFieldText table8Q + testJsonGetMissingField table8Q + testJsonGetArrayValue table8Q + testJsonGetArrayText table8Q + testJsonGetPathValue table8Q + testJsonGetPathText table8Q + describe "uncat" $ do + testKeywordColNames + testInsertSerial + testInQuery + testAtTimeZone + testUnionAll + testTableFunctor + testValues + testValuesEmpty + testUpdate + describe "range" $ do + testRangeOverlap + testRangeLeftOf + testRangeRightOf + testRangeRightExtension + testRangeLeftExtension + testRangeAdjacency diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -1,6 +1,6 @@ name: opaleye copyright: Copyright (c) 2014-2017 Purely Agile Limited -version: 0.5.3.0 +version: 0.5.3.1 synopsis: An SQL-generating DSL targeting PostgreSQL description: An SQL-generating DSL targeting PostgreSQL. Allows Postgres queries to be written within Haskell in a @@ -14,9 +14,11 @@ category: Database build-type: Simple cabal-version: >= 1.18 -extra-doc-files: *.md, +extra-doc-files: README.md + CHANGELOG.md + *.md Doc/*.md -tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 source-repository head type: git @@ -28,7 +30,7 @@ build-depends: -- attoparsec can be removed once postgresql-simple patch in -- Internal.RunQuery is merged upstream - aeson >= 0.6 && < 1.2 + aeson >= 0.6 && < 1.3 , attoparsec >= 0.10.3 && < 0.14 , base >= 4.6 && < 5 , base16-bytestring >= 0.1.1.6 && < 0.2 @@ -37,12 +39,12 @@ , contravariant >= 1.2 && < 1.5 , postgresql-simple >= 0.5 && < 0.6 , pretty >= 1.1.1.0 && < 1.2 - , product-profunctors >= 0.6.2 && < 0.8 + , product-profunctors >= 0.6.2 && < 0.9 , profunctors >= 4.0 && < 5.3 , semigroups >= 0.13 && < 0.19 , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.6 - , time >= 1.4 && < 1.7 + , time >= 1.4 && < 1.9 , time-locale-compat >= 0.1 && < 0.2 , uuid >= 1.3 && < 1.4 , void >= 0.4 && < 0.8 @@ -100,10 +102,11 @@ other-modules: QuickCheck hs-source-dirs: Test build-depends: - aeson >= 0.6 && < 1.2, + aeson >= 0.6 && < 1.3, base >= 4 && < 5, containers, contravariant, + dotenv >= 0.3.1, multiset, postgresql-simple, profunctors, @@ -112,6 +115,9 @@ semigroups, text >= 0.11 && < 1.3, time, + transformers, + hspec, + hspec-discover, opaleye ghc-options: -Wall diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | Perform aggregation on 'Query's. To aggregate a 'Query' you -- should construct an 'Aggregator' encoding how you want the -- aggregation to proceed, then call 'aggregate' on it. The @@ -30,12 +31,14 @@ import Control.Applicative (pure) import Data.Profunctor (lmap) +import qualified Data.Profunctor as P import qualified Opaleye.Internal.Aggregate as A import Opaleye.Internal.Aggregate (Aggregator, orderAggregate) import qualified Opaleye.Internal.Column as IC import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import qualified Opaleye.Internal.PackMap as PM import Opaleye.QueryArr (Query) import qualified Opaleye.Column as C @@ -82,6 +85,11 @@ aggregateOrdered :: Ord.Order a -> Aggregator a b -> Query a -> Query b aggregateOrdered o agg = aggregate (orderAggregate o agg) + +-- | Aggregate only distinct values +distinctAggregator :: Aggregator a b -> Aggregator a b +distinctAggregator (A.Aggregator (PM.PackMap pm)) = + A.Aggregator (PM.PackMap (\f c -> pm (f . P.first' (fmap (\(a,b,_) -> (a,b,HPQ.AggrDistinct)))) c)) -- | Group the aggregation by equality on the input to 'groupBy'. groupBy :: Aggregator (C.Column a) (C.Column a) diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | Functions for working directly with 'Column's. -- -- Please note that numeric 'Column' types are instances of 'Num', so @@ -63,3 +64,6 @@ -- provided value coerced to a nullable type. maybeToNullable :: Maybe (Column a) -> Column (Nullable a) maybeToNullable = maybe null toNullable + +joinNullable :: Column (Nullable (Nullable a)) -> Column (Nullable a) +joinNullable = unsafeCoerceColumn diff --git a/src/Opaleye/FunctionalJoin.hs b/src/Opaleye/FunctionalJoin.hs --- a/src/Opaleye/FunctionalJoin.hs +++ b/src/Opaleye/FunctionalJoin.hs @@ -57,7 +57,7 @@ where a1 = fmap (\x -> (x, T.pgBool True)) j = J.leftJoinExplicit D.def D.def - (PP.p2 ((IJ.NullMaker id), nullmakerBool)) + (PP.p2 (IJ.NullMaker id, nullmakerBool)) l (a1 r) (\(l', (r', _)) -> cond l' r') @@ -88,7 +88,7 @@ where a1 = fmap (\x -> (x, T.pgBool True)) j = J.rightJoinExplicit D.def D.def - (PP.p2 ((IJ.NullMaker id), nullmakerBool)) + (PP.p2 (IJ.NullMaker id, nullmakerBool)) (a1 l) r (\((l', _), r') -> cond l' r') @@ -124,8 +124,8 @@ where a1 = fmap (\x -> (x, T.pgBool True)) j = J.fullJoinExplicit D.def D.def - (PP.p2 ((IJ.NullMaker id), nullmakerBool)) - (PP.p2 ((IJ.NullMaker id), nullmakerBool)) + (PP.p2 (IJ.NullMaker id, nullmakerBool)) + (PP.p2 (IJ.NullMaker id, nullmakerBool)) (a1 l) (a1 r) (\((l', _), (r', _)) -> cond l' r') 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 @@ -28,13 +28,13 @@ takes a list of @a@ and returns a single row of type @b@. -} newtype Aggregator a b = Aggregator - (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr) + (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 (,[]) m, e)))) + (\f (C.Column e) -> fmap C.Column (f (fmap (,[],HPQ.AggrAll) m, e)))) makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b) makeAggr = makeAggr' . Just @@ -74,10 +74,10 @@ 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 (P.second' (const $ O.orderExprs c o)))) c)) + 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.PrimExpr) -> f HPQ.PrimExpr) + -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> f HPQ.PrimExpr) -> a -> f b runAggregator (Aggregator a) = PM.traversePM a @@ -89,8 +89,8 @@ primQ' = PQ.Aggregate projPEs primQ -extractAggregateFields :: T.Tag -> (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr) - -> PM.PM [(HPQ.Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] HPQ.PrimExpr +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" -- { Boilerplate instances diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs --- a/src/Opaleye/Internal/Column.hs +++ b/src/Opaleye/Internal/Column.hs @@ -7,6 +7,9 @@ -- | A column of a @Query@, of type @pgType@. For example 'Column' -- @PGInt4@ is an @int4@ column and a 'Column' @PGText@ is a @text@ -- column. +-- +-- Do not use the 'Show' instance of 'Column'. It will be deprecated +-- in version 0.6. newtype Column pgType = Column HPQ.PrimExpr deriving Show -- | Only used within a 'Column', to indicate that it can be @NULL@. diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs --- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -21,7 +21,7 @@ | CompositeExpr PrimExpr Attribute -- ^ Composite Type Query | BinExpr BinOp PrimExpr PrimExpr | UnExpr UnOp PrimExpr - | AggrExpr AggrOp PrimExpr [OrderExpr] + | AggrExpr AggrDistinct AggrOp PrimExpr [OrderExpr] | ConstExpr Literal | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr | ListExpr (NEL.NonEmpty PrimExpr) @@ -35,6 +35,7 @@ -- needed for insert expressions. | ArrayExpr [PrimExpr] -- ^ ARRAY[..] | RangeExpr BoundExpr BoundExpr + | ArrayIndex PrimExpr PrimExpr deriving (Read,Show) data Literal = NullLit @@ -78,6 +79,9 @@ | AggrBoolOr | AggrBoolAnd | AggrArr | AggrStringAggr PrimExpr | AggrOther String deriving (Show,Read) + +data AggrDistinct = AggrDistinct | AggrAll + deriving (Eq,Show,Read) data OrderExpr = OrderExpr OrderOp PrimExpr deriving (Show,Read) diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -34,14 +34,18 @@ data SqlRangeBound = Inclusive SqlExpr | Exclusive SqlExpr | PosInfinity | NegInfinity deriving Show +data SqlDistinct = SqlDistinct | SqlNotDistinct + deriving Show + -- | Expressions in SQL statements. data SqlExpr = ColumnSqlExpr SqlColumn | CompositeSqlExpr SqlExpr String | BinSqlExpr String SqlExpr SqlExpr + | SubscriptSqlExpr SqlExpr SqlExpr | PrefixSqlExpr String SqlExpr | PostfixSqlExpr String SqlExpr | FunSqlExpr String [SqlExpr] - | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] -- ^ Aggregate functions separate from normal functions. + | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct -- ^ Aggregate functions separate from normal functions. | ConstSqlExpr String | CaseSqlExpr (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr | ListSqlExpr (NEL.NonEmpty SqlExpr) diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -45,7 +45,7 @@ toSqlColumn :: Attribute -> SqlColumn -toSqlColumn attr = SqlColumn attr +toSqlColumn = SqlColumn toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)] toSqlAssoc gen = map (\(attr,expr) -> (toSqlColumn attr, sqlExpr gen expr)) @@ -122,13 +122,16 @@ -- because it leads to a non-uniformity of treatment, as seen -- below. Perhaps we should have just `AggrExpr AggrOp` and -- always put the `PrimExpr` in the `AggrOp`. - AggrExpr op e ord -> let op' = showAggrOp op - e' = sqlExpr gen e - ord' = toSqlOrder gen <$> ord - moreAggrFunParams = case op of - AggrStringAggr primE -> [sqlExpr gen primE] - _ -> [] - in AggrFunSqlExpr op' (e' : moreAggrFunParams) ord' + AggrExpr distinct op e ord -> let op' = showAggrOp op + e' = sqlExpr gen e + ord' = toSqlOrder gen <$> ord + distinct' = case distinct of + AggrDistinct -> SqlDistinct + AggrAll -> SqlNotDistinct + moreAggrFunParams = case op of + AggrStringAggr primE -> [sqlExpr gen primE] + _ -> [] + in AggrFunSqlExpr op' (e' : moreAggrFunParams) ord' distinct' ConstExpr l -> ConstSqlExpr (sqlLiteral gen l) CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] e' = sqlExpr gen e @@ -144,9 +147,10 @@ RangeExpr l r -> let bound :: PQ.BoundExpr -> Sql.SqlRangeBound bound (PQ.Inclusive a) = Sql.Inclusive (sqlExpr gen a) bound (PQ.Exclusive a) = Sql.Exclusive (sqlExpr gen a) - bound (PQ.PosInfinity) = Sql.PosInfinity - bound (PQ.NegInfinity) = Sql.NegInfinity + bound PQ.PosInfinity = Sql.PosInfinity + bound PQ.NegInfinity = Sql.NegInfinity in RangeSqlExpr (bound l) (bound r) + ArrayIndex e1 e2 -> SubscriptSqlExpr (ParensSqlExpr $ sqlExpr gen e1) (ParensSqlExpr $ sqlExpr gen e2) showBinOp :: BinOp -> String showBinOp (:==) = "=" @@ -239,7 +243,7 @@ defaultSqlQuote :: SqlGenerator -> String -> String -defaultSqlQuote _ s = quote s +defaultSqlQuote _ = quote -- | Quote a string and escape characters that need escaping -- We use Postgres "escape strings", i.e. strings prefixed diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -48,7 +48,7 @@ ppGroupBy es = text "GROUP BY" <+> ppGroupAttrs es where ppGroupAttrs :: [SqlExpr] -> Doc - ppGroupAttrs cs = commaV (ppSqlExpr . deliteral) cs + ppGroupAttrs = commaV (ppSqlExpr . deliteral) ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty @@ -71,6 +71,10 @@ Sql.SqlNullsFirst -> "NULLS FIRST" Sql.SqlNullsLast -> "NULLS LAST" +ppSqlDistinct :: Sql.SqlDistinct -> Doc +ppSqlDistinct Sql.SqlDistinct = text "DISTINCT" +ppSqlDistinct Sql.SqlNotDistinct = empty + ppAs :: Maybe String -> Doc -> Doc ppAs Nothing expr = expr ppAs (Just alias) expr = expr <+> hsep [text "as", doubleQuotes (text alias)] @@ -94,7 +98,7 @@ ppInsert (SqlInsert table names values) = text "INSERT INTO" <+> ppTable table <+> parens (commaV ppColumn names) - $$ text "VALUES" <+> commaV (\v -> parens (commaV ppSqlExpr v)) + $$ text "VALUES" <+> commaV (parens . commaV ppSqlExpr) (NEL.toList values) -- If we wanted to make the SQL slightly more readable this would be @@ -116,38 +120,39 @@ ppStartBound :: SqlRangeBound -> Doc ppStartBound (Inclusive a) = text "'[" <> ppSqlExpr a ppStartBound (Exclusive a) = text "'(" <> ppSqlExpr a -ppStartBound (PosInfinity) = text "'(infinity" -ppStartBound (NegInfinity) = text "'(-infinity" +ppStartBound PosInfinity = text "'(infinity" +ppStartBound NegInfinity = text "'(-infinity" ppEndBound :: SqlRangeBound -> Doc ppEndBound (Inclusive a) = ppSqlExpr a <> text "]'" ppEndBound (Exclusive a) = ppSqlExpr a <> text ")'" -ppEndBound (PosInfinity) = text "infinity)'" -ppEndBound (NegInfinity) = text "-infinity)'" +ppEndBound PosInfinity = text "infinity)'" +ppEndBound NegInfinity = text "-infinity)'" ppSqlExpr :: SqlExpr -> Doc ppSqlExpr expr = case expr of - ColumnSqlExpr c -> ppColumn c - CompositeSqlExpr s x -> parens (ppSqlExpr s) <> text "." <> text x - ParensSqlExpr e -> parens (ppSqlExpr e) - BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2 - PrefixSqlExpr op e -> text op <+> ppSqlExpr e - PostfixSqlExpr op e -> ppSqlExpr e <+> text op - FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es) - AggrFunSqlExpr f es ord -> text f <> parens (commaH ppSqlExpr es <+> ppOrderBy ord) - ConstSqlExpr c -> text c + ColumnSqlExpr c -> ppColumn c + CompositeSqlExpr s x -> parens (ppSqlExpr s) <> text "." <> text x + ParensSqlExpr e -> parens (ppSqlExpr e) + SubscriptSqlExpr e1 e2 -> ppSqlExpr e1 <> brackets (ppSqlExpr e2) + BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2 + PrefixSqlExpr op e -> text op <+> ppSqlExpr e + PostfixSqlExpr op e -> ppSqlExpr e <+> text op + FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es) + ConstSqlExpr c -> text c + ListSqlExpr es -> parens (commaH ppSqlExpr (NEL.toList es)) + ParamSqlExpr _ v -> ppSqlExpr v + PlaceHolderSqlExpr -> text "?" + CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ) + DefaultSqlExpr -> text "DEFAULT" + ArraySqlExpr es -> text "ARRAY" <> brackets (commaH ppSqlExpr es) + RangeSqlExpr start end -> (hcat . punctuate comma) [ppStartBound start, ppEndBound end] + AggrFunSqlExpr f es ord distinct -> text f <> parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord) CaseSqlExpr cs el -> text "CASE" <+> vcat (toList (fmap ppWhen cs)) <+> text "ELSE" <+> ppSqlExpr el <+> text "END" where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w <+> text "THEN" <+> ppSqlExpr t - ListSqlExpr es -> parens (commaH ppSqlExpr (NEL.toList es)) - ParamSqlExpr _ v -> ppSqlExpr v - PlaceHolderSqlExpr -> text "?" - CastSqlExpr typ e -> text "CAST" <> parens (ppSqlExpr e <+> text "AS" <+> text typ) - DefaultSqlExpr -> text "DEFAULT" - ArraySqlExpr es -> text "ARRAY" <> brackets (commaH ppSqlExpr es) - RangeSqlExpr start end -> (hcat . punctuate comma) [ppStartBound start, ppEndBound end] commaH :: (a -> Doc) -> [a] -> Doc commaH f = hcat . punctuate comma . map f 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 @@ -44,6 +44,7 @@ , PQ.order = fmap . PQ.Order , PQ.limit = fmap . PQ.Limit , PQ.join = \jt pe pes1 pes2 pq1 pq2 -> PQ.Join jt pe pes1 pes2 <$> pq1 <*> pq2 + , PQ.existsf = \b pq1 pq2 -> PQ.Exists b <$> pq1 <*> pq2 , PQ.values = return .: PQ.Values , PQ.binary = \case -- Some unfortunate duplication here diff --git a/src/Opaleye/Internal/Order.hs b/src/Opaleye/Internal/Order.hs --- a/src/Opaleye/Internal/Order.hs +++ b/src/Opaleye/Internal/Order.hs @@ -1,5 +1,9 @@ module Opaleye.Internal.Order where +import Data.Function (on) + +import qualified Data.List.NonEmpty as NL + import qualified Opaleye.Column as C import qualified Opaleye.Internal.Column as IC import qualified Opaleye.Internal.Tag as T @@ -62,3 +66,31 @@ offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t) + +-- | Order the results of a given query exactly, as determined by the given list +-- of input columns. Note that this list does not have to contain an entry for +-- every result in your query: you may exactly order only a subset of results, +-- if you wish. Rows that are not ordered according to the input list are +-- returned __after__ the ordered results, in the usual order the database would +-- return them (e.g. sorted by primary key). Exactly-ordered results always come +-- first in a result set. Entries in the input list that are __not__ present in +-- result of a query are ignored. +exact :: [IC.Column b] -> (a -> IC.Column b) -> Order a +exact xs k = maybe M.mempty go (NL.nonEmpty xs) where + -- Create an equality AST node, between two columns, essentially + -- stating "(column = value)" syntactically. + mkEq = HPQ.BinExpr (HPQ.:=) `on` IC.unColumn + + -- The AST operation: ORDER BY (equalities...) DESC NULLS FIRST + -- NOTA BENE: DESC is mandatory (otherwise the result is reversed, as you are + -- "descending" down the list of equalities from the front, rather than + -- "ascending" from the end of the list.) NULLS FIRST strictly isn't needed; + -- but HPQ.OrderOp currently mandates a value for both the direction + -- (OrderDirection) and the rules for null (OrderNulls) values, in the + -- OrderOp constructor. + astOp = HPQ.OrderOp HPQ.OpDesc HPQ.NullsFirst + + -- Final result: ORDER BY (equalities...) DESC NULLS FIRST, with a given + -- list of equality operations, created via 'mkEq' + go givenOrder = Order $ flip fmap k $ \col -> + [(astOp, HPQ.ListExpr $ NL.map (mkEq col) givenOrder)] 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 @@ -43,7 +43,7 @@ | Empty a | BaseTable TableIdentifier (Bindings HPQ.PrimExpr) | Product (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr] - | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr)) + | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)) (PrimQuery' a) | Order [HPQ.OrderExpr] (PrimQuery' a) | Limit LimitOp (PrimQuery' a) @@ -53,6 +53,7 @@ (Bindings HPQ.PrimExpr) (PrimQuery' a) (PrimQuery' a) + | Exists Bool (PrimQuery' a) (PrimQuery' a) | Values [Symbol] (NEL.NonEmpty [HPQ.PrimExpr]) | Binary BinOp (Bindings (HPQ.PrimExpr, HPQ.PrimExpr)) @@ -67,22 +68,23 @@ data PrimQueryFold' a p = PrimQueryFold { unit :: p , empty :: a -> p - , baseTable :: TableIdentifier -> (Bindings HPQ.PrimExpr) -> p + , baseTable :: TableIdentifier -> Bindings HPQ.PrimExpr -> p , product :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p - , aggregate :: (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr)) -> p -> p + , aggregate :: Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> p -> p , order :: [HPQ.OrderExpr] -> p -> p , limit :: LimitOp -> p -> p , join :: JoinType -> HPQ.PrimExpr - -> (Bindings HPQ.PrimExpr) - -> (Bindings HPQ.PrimExpr) + -> Bindings HPQ.PrimExpr + -> Bindings HPQ.PrimExpr -> p -> p -> p - , values :: [Symbol] -> (NEL.NonEmpty [HPQ.PrimExpr]) -> p - , binary :: BinOp -> (Bindings (HPQ.PrimExpr, HPQ.PrimExpr)) -> (p, p) -> p + , existsf :: Bool -> p -> p -> p + , values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p + , binary :: BinOp -> Bindings (HPQ.PrimExpr, HPQ.PrimExpr) -> (p, p) -> p , label :: String -> p -> p - , relExpr :: HPQ.PrimExpr -> (Bindings HPQ.PrimExpr) -> p + , relExpr :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p -- ^ A relation-valued expression } @@ -101,6 +103,7 @@ , binary = Binary , label = Label , relExpr = RelExpr + , existsf = Exists } foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p @@ -118,6 +121,7 @@ Binary binop pes (q1, q2) -> binary f binop pes (self q1, self q2) Label l pq -> label f l (self pq) RelExpr pe syms -> relExpr f pe syms + Exists b q1 q2 -> existsf f b (self q1) (self q2) fix g = let x = g x in x times :: PrimQuery -> PrimQuery -> PrimQuery @@ -125,6 +129,12 @@ restrict :: HPQ.PrimExpr -> PrimQuery -> PrimQuery restrict cond primQ = Product (return primQ) [cond] + +exists :: PrimQuery -> PrimQuery -> PrimQuery +exists = Exists True + +notExists :: PrimQuery -> PrimQuery -> PrimQuery +notExists = Exists False isUnit :: PrimQuery' a -> Bool isUnit Unit = 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 @@ -9,8 +9,9 @@ SelectJoin, SelectValues, SelectBinary, - SelectLabel), - From, Join, Values, Binary, Label) + SelectLabel, + SelectExists), + From, Join, Values, Binary, Label, Exists) import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint @@ -30,6 +31,7 @@ ppSql (SelectValues v) = ppSelectValues v ppSql (SelectBinary v) = ppSelectBinary v ppSql (SelectLabel v) = ppSelectLabel v +ppSql (SelectExists v) = ppSelectExists v ppSelectFrom :: From -> Doc ppSelectFrom s = text "SELECT" @@ -73,6 +75,16 @@ . ST.replace (ST.pack "*/") (ST.pack " * / ") . ST.pack +ppSelectExists :: Exists -> Doc +ppSelectExists v = + text "SELECT *" + $$ text "FROM" + $$ ppTable (tableAlias 1 (Sql.existsTable v)) + $$ case Sql.existsBool v of + True -> text "WHERE EXISTS" + False -> text "WHERE NOT EXISTS" + $$ parens (ppSql (Sql.existsCriteria v)) + ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" ppJoinType Sql.RightJoin = text "RIGHT OUTER JOIN" @@ -106,6 +118,7 @@ SelectValues slv -> parens (ppSelectValues slv) SelectBinary slb -> parens (ppSelectBinary slb) SelectLabel sll -> parens (ppSelectLabel sll) + SelectExists saj -> parens (ppSelectExists saj) ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppGroupBy Nothing = empty 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 @@ -18,6 +18,9 @@ import qualified Data.Profunctor.Product as PP -- | @QueryArr a b@ is analogous to a Haskell function @a -> [b]@. + +-- Ideally this should be wrapped in a monad which automatically +-- increments the Tag, but I couldn't be bothered to do that. newtype QueryArr a b = QueryArr ((a, PQ.PrimQuery, Tag) -> (b, PQ.PrimQuery, Tag)) -- | A Postgres query, i.e. some functionality that can run via SQL 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 @@ -39,16 +39,9 @@ import Control.Applicative ((<$>)) import Database.PostgreSQL.Simple.FromField - (Field, typoid, typeOid, typelem, TypeInfo, - ResultError(UnexpectedNull, ConversionFailed, Incompatible), - typdelim, typeInfo, returnError, Conversion) -import Database.PostgreSQL.Simple.Types (PGArray(PGArray)) -import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) + (ResultError(UnexpectedNull, Incompatible), typeInfo, returnError) import qualified Database.PostgreSQL.Simple.TypeInfo as TI -import qualified Database.PostgreSQL.Simple.Arrays as Arrays -import Database.PostgreSQL.Simple.Arrays (array, fmt) import qualified Database.PostgreSQL.Simple.Range as PGSR -import Data.String (fromString) import Data.Typeable (Typeable) -- } @@ -88,6 +81,13 @@ -- have to put a dummy 0 into the SELECT statement, -- since we can't select zero columns. In that case we -- have to make sure we read a single Int. + -- + -- NB this does have to be a function of 'columns' + -- because we have a `SumProfunctor` instance. For some + -- values of 'columns' there may be zero columns and for + -- other values one or more, for example, 'Maybe (Column + -- PGInt4)' has no columns when it is Nothing and one + -- column when it is Just. fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn pgType haskell fieldQueryRunnerColumn = fieldParserQueryRunnerColumn fromField 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 @@ -26,6 +26,7 @@ | SelectValues Values | SelectBinary Binary | SelectLabel Label + | SelectExists Exists deriving Show data SelectAttrs = @@ -73,6 +74,12 @@ data Returning a = Returning a (NEL.NonEmpty HSql.SqlExpr) +data Exists = Exists + { existsBool :: Bool + , existsTable :: Select + , existsCriteria :: Select + } deriving Show + sqlQueryGenerator :: PQ.PrimQueryFold' V.Void Select sqlQueryGenerator = PQ.PrimQueryFold { PQ.unit = unit @@ -87,8 +94,12 @@ , PQ.binary = binary , PQ.label = label , PQ.relExpr = relExpr + , PQ.existsf = exists } +exists :: Bool -> Select -> Select -> Select +exists b q1 q2 = SelectExists (Exists b q1 q2) + sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select sql (pes, pq, t) = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (makeAttrs pes)) , tables = [pqSelect] } @@ -112,7 +123,7 @@ newSelect { tables = NEL.toList ss , criteria = map sqlExpr pes } -aggregate :: [(Symbol, (Maybe (HPQ.AggrOp, [HPQ.OrderExpr]), HPQ.PrimExpr))] -> Select -> Select +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] @@ -130,17 +141,17 @@ groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))] -> NEL.NonEmpty HSql.SqlExpr - groupBy' = (handleEmpty - . map sqlExpr - . map expr - . filter (M.isNothing . aggrOp)) + groupBy' = handleEmpty + . map sqlExpr + . map expr + . filter (M.isNothing . aggrOp) attr = sqlBinding . Arr.second (uncurry aggrExpr) expr (_, (_, e)) = e aggrOp (_, (x, _)) = x -aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr]) -> HPQ.PrimExpr -> HPQ.PrimExpr -aggrExpr = maybe id (\(op, ord) e -> HPQ.AggrExpr op e ord) +aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct) -> HPQ.PrimExpr -> HPQ.PrimExpr +aggrExpr = maybe id (\(op, ord, distinct) e -> HPQ.AggrExpr distinct op e ord) order :: [HPQ.OrderExpr] -> Select -> Select order oes s = SelectFrom $ diff --git a/src/Opaleye/Internal/Tag.hs b/src/Opaleye/Internal/Tag.hs --- a/src/Opaleye/Internal/Tag.hs +++ b/src/Opaleye/Internal/Tag.hs @@ -1,5 +1,6 @@ module Opaleye.Internal.Tag where +-- | Tag is for use as a source of unique IDs in QueryArr newtype Tag = UnsafeTag Int deriving (Read, Show) start :: Tag diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -82,7 +82,12 @@ -- ^ Returned rows after @f@ has been applied runInsertManyReturning = runInsertManyReturningExplicit D.def --- | Update rows in a table +-- | Update rows in a table. +-- +-- Be careful: providing 'Nothing' to a column created by @optional@ +-- updates the column to its default value. Many users have been +-- confused by this because they assume it means that the column is to +-- be left unchanged. runUpdate :: PGS.Connection -> T.Table columnsW columnsR -- ^ Table to update @@ -98,6 +103,11 @@ -- | Update rows in a table and return a function of the updated rows +-- +-- Be careful: providing 'Nothing' to a column created by @optional@ +-- updates the column to its default value. Many users have been +-- confused by this because they assume it means that the column is to +-- be left unchanged. -- -- @runUpdateReturning@'s use of the 'D.Default' typeclass means -- that the compiler will have trouble inferring types. It is diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -13,7 +13,7 @@ import Opaleye.Internal.Column (Column(Column), unsafeCase_, unsafeIfThenElse, unsafeGt) import qualified Opaleye.Internal.Column as C -import Opaleye.Internal.QueryArr (QueryArr(QueryArr), Query) +import Opaleye.Internal.QueryArr (QueryArr(QueryArr), Query, runSimpleQueryArr) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Operators as O import Opaleye.Internal.Helpers ((.:)) @@ -37,6 +37,18 @@ restrict = QueryArr f where f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0) +{-| Add a @WHERE EXSITS@ clause to the current query. -} +exists :: QueryArr a b -> QueryArr a () +exists criteria = QueryArr f where + f (a, primQ, t0) = ((), PQ.exists primQ existsQ, t1) where + (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0) + +{-| Add a @WHERE EXSITS@ clause to the current query. -} +notExists :: QueryArr a b -> QueryArr a () +notExists criteria = QueryArr f where + f (a, primQ, t0) = ((), PQ.notExists primQ existsQ, t1) where + (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0) + {-| Filter a 'QueryArr' to only those rows where the given condition holds. This is the 'QueryArr' equivalent of 'Prelude.filter' from the 'Prelude'. You would typically use 'keepWhen' if you want to use a @@ -93,6 +105,8 @@ quot_ :: C.PGIntegral a => Column a -> Column a -> Column a quot_ = C.binOp (HPQ.:/) +-- | The remainder of division named after 'Prelude.rem'. +-- It maps to 'MOD' ('%') in Postgres, confusingly described as "modulo (remainder)". rem_ :: C.PGIntegral a => Column a -> Column a -> Column a rem_ = C.binOp HPQ.OpMod @@ -181,7 +195,7 @@ -- expediency, is currently implemented using a @LEFT JOIN@. Please -- file a bug if this causes any issues in practice. inQuery :: D.Default O.EqPP columns columns - => columns -> QueryArr () columns -> Query (Column T.PGBool) + => columns -> Query columns -> Query (Column T.PGBool) inQuery c q = qj' where -- Remove every row that isn't equal to c -- Replace the ones that are with '1' @@ -282,12 +296,7 @@ (.?&) :: Column T.PGJsonb -> Column (T.PGArray T.PGText) -> Column T.PGBool (.?&) = C.binOp (HPQ.:?&) --- * Other operators - -timestamptzAtTimeZone :: Column T.PGTimestamptz - -> Column T.PGText - -> Column T.PGTimestamp -timestamptzAtTimeZone = C.binOp HPQ.OpAtTimeZone +-- * PGArray Operators emptyArray :: T.IsSqlType a => Column (T.PGArray a) emptyArray = T.pgArray id [] @@ -298,7 +307,18 @@ singletonArray :: T.IsSqlType a => Column a -> Column (T.PGArray a) singletonArray x = arrayPrepend x emptyArray --- | Cast a 'PGInt4' to a 'PGFloat8' +index :: (C.PGIntegral n) => Column (T.PGArray a) -> Column n -> Column (C.Nullable a) +index (Column a) (Column b) = Column (HPQ.ArrayIndex a b) + +-- * Other operators + +timestamptzAtTimeZone :: Column T.PGTimestamptz + -> Column T.PGText + -> Column T.PGTimestamp +timestamptzAtTimeZone = C.binOp HPQ.OpAtTimeZone + +-- | Do not use. Will be deprecated in version 0.6. Use +-- 'C.unsafeCast' instead. doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs --- a/src/Opaleye/Order.hs +++ b/src/Opaleye/Order.hs @@ -11,6 +11,8 @@ -- * Limit and offset , limit , offset + -- * Exact ordering + , O.exact -- * Other , PGOrd ) where diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -140,57 +140,64 @@ C.Column (HPQ.ArrayExpr (map oneEl xs)) where oneEl = C.unColumn . pgEl - arrayTy = showPGType ([] :: [PGArray b]) + 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.CastExpr (showRangeType ([] :: [b])) $ HPQ.RangeExpr (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 - oneEl (R.PosInfinity) = HPQ.PosInfinity + oneEl R.NegInfinity = HPQ.NegInfinity + oneEl R.PosInfinity = HPQ.PosInfinity class IsSqlType pgType where + -- | 'showSqlType' will be deprecated in version 0.6. Use + -- 'showSqlType' instead. showPGType :: proxy pgType -> String + showPGType = showSqlType + + showSqlType :: proxy pgType -> String + showSqlType = showPGType + instance IsSqlType PGBool where - showPGType _ = "boolean" + showSqlType _ = "boolean" instance IsSqlType PGDate where - showPGType _ = "date" + showSqlType _ = "date" instance IsSqlType PGFloat4 where - showPGType _ = "real" + showSqlType _ = "real" instance IsSqlType PGFloat8 where - showPGType _ = "double precision" + showSqlType _ = "double precision" instance IsSqlType PGInt8 where - showPGType _ = "bigint" + showSqlType _ = "bigint" instance IsSqlType PGInt4 where - showPGType _ = "integer" + showSqlType _ = "integer" instance IsSqlType PGInt2 where - showPGType _ = "smallint" + showSqlType _ = "smallint" instance IsSqlType PGNumeric where - showPGType _ = "numeric" + showSqlType _ = "numeric" instance IsSqlType PGText where - showPGType _ = "text" + showSqlType _ = "text" instance IsSqlType PGTime where - showPGType _ = "time" + showSqlType _ = "time" instance IsSqlType PGTimestamp where - showPGType _ = "timestamp" + showSqlType _ = "timestamp" instance IsSqlType PGTimestamptz where - showPGType _ = "timestamp with time zone" + showSqlType _ = "timestamp with time zone" instance IsSqlType PGUuid where - showPGType _ = "uuid" + showSqlType _ = "uuid" instance IsSqlType PGCitext where - showPGType _ = "citext" + showSqlType _ = "citext" instance IsSqlType PGBytea where - showPGType _ = "bytea" + showSqlType _ = "bytea" instance IsSqlType a => IsSqlType (PGArray a) where - showPGType _ = showPGType ([] :: [a]) ++ "[]" + showSqlType _ = showSqlType ([] :: [a]) ++ "[]" instance IsSqlType a => IsSqlType (C.Nullable a) where - showPGType _ = showPGType ([] :: [a]) + showSqlType _ = showSqlType ([] :: [a]) instance IsSqlType PGJson where - showPGType _ = "json" + showSqlType _ = "json" instance IsSqlType PGJsonb where - showPGType _ = "jsonb" + showSqlType _ = "jsonb" instance IsRangeType a => IsSqlType (PGRange a) where - showPGType _ = showRangeType ([] :: [a]) + showSqlType _ = showRangeType ([] :: [a]) class IsSqlType pgType => IsRangeType pgType where showRangeType :: proxy pgType -> String diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -1,10 +1,64 @@ {-# LANGUAGE FlexibleContexts #-} +{- | + + Columns can be required or optional and, independently, nullable or + non-nullable. + + A required non-nullable @PGInt4@ (for example) is created with + 'required' and gives rise to a + + @ + TableProperties (Column PGInt4) (Column PGInt4) + @ + + The leftmost argument is the type of writes. When you insert or + update into this column you must give it a @Column PGInt4@ (which you + can create with @pgInt4 :: Int -> Column PGInt4@). + + A required nullable @PGInt4@ is created with 'required' and gives rise + to a + + @ + TableProperties (Column (Nullable PGInt4)) (Column (Nullable PGInt4)) + @ + + When you insert or update into this column you must give it a @Column + (Nullable PGInt4)@, which you can create either with @pgInt4@ and + @toNullable :: Column a -> Column (Nullable a)@, or with @null :: + Column (Nullable a)@. + + An optional non-nullable @PGInt4@ is created with optional and gives + rise to a + + @ + TableProperties (Maybe (Column PGInt4)) (Column PGInt4) + @ + + When you insert or update into this column you must give it a @Maybe + (Column PGInt4)@. If you provide @Nothing@ then the column will be + omitted from the query and the default value will be used. Otherwise + you have to provide a @Just@ containing a @Column PGInt4@. + + An optional non-nullable @PGInt4@ is created with optional and gives + rise to a + + @ + TableProperties (Maybe (Column (Nullable PGInt4))) (Column PGInt4) + @ + + When you insert or update into this column you must give it a @Maybe + (Column (Nullable PGInt4))@. If you provide @Nothing@ then the default + value will be used. Otherwise you have to provide a @Just@ containing + a @Column (Nullable PGInt4)@ (which can be null). + +-} + module Opaleye.Table (module Opaleye.Table, -- * Other View, Writer, - Table(Table, TableWithSchema), + T.Table(T.Table, T.TableWithSchema), TableProperties) where import Opaleye.Internal.Column (Column(Column))