opaleye 0.5.3.0 → 0.5.3.1

raw patch · 29 files changed

+601/−335 lines, 29 filesdep +dotenvdep +hspecdep +hspec-discoverdep ~timedep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dotenv, hspec, hspec-discover

Dependency ranges changed: time, transformers

API changes (from Hackage documentation)

Files

• Doc/Tutorial/TutorialBasic.lhs +6/−6
• Doc/Tutorial/TutorialBasicMonomorphic.lhs +1/−1
• Doc/Tutorial/TutorialManipulation.lhs +1/−1
• README.md +10/−1
• Test/QuickCheck.hs +8/−8
• Test/Test.hs +262/−207
• opaleye.cabal +13/−7
• src/Opaleye/Aggregate.hs +8/−0
• src/Opaleye/Column.hs +4/−0
• src/Opaleye/FunctionalJoin.hs +4/−4
• src/Opaleye/Internal/Aggregate.hs +6/−6
• src/Opaleye/Internal/Column.hs +3/−0
• src/Opaleye/Internal/HaskellDB/PrimQuery.hs +5/−1
• src/Opaleye/Internal/HaskellDB/Sql.hs +5/−1
• src/Opaleye/Internal/HaskellDB/Sql/Default.hs +15/−11
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +27/−22
• src/Opaleye/Internal/Optimize.hs +1/−0
• src/Opaleye/Internal/Order.hs +32/−0
• src/Opaleye/Internal/PrimQuery.hs +18/−8
• src/Opaleye/Internal/Print.hs +15/−2
• src/Opaleye/Internal/QueryArr.hs +3/−0
• src/Opaleye/Internal/RunQuery.hs +8/−8
• src/Opaleye/Internal/Sql.hs +18/−7
• src/Opaleye/Internal/Tag.hs +1/−0
• src/Opaleye/Manipulation.hs +11/−1
• src/Opaleye/Operators.hs +29/−9
• src/Opaleye/Order.hs +2/−0
• src/Opaleye/PGTypes.hs +30/−23
• src/Opaleye/Table.hs +55/−1

@@ -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

@@ -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)

@@ -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

@@ -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 

@@ -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)) 

@@ -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

@@ -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 

@@ -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)

@@ -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

@@ -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')

@@ -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

@@ -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@.

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 $

@@ -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

@@ -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

@@ -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) 

@@ -11,6 +11,8 @@                      -- * Limit and offset                      , limit                      , offset+                     -- * Exact ordering+                     , O.exact                      -- * Other                      , PGOrd                      ) where

@@ -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

@@ -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))