opaleye 0.6.7000.0 → 0.6.7001.0

raw patch · 16 files changed

+298/−149 lines, 16 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• Test/Test.hs +105/−34
• opaleye.cabal +3/−3
• src/Opaleye/Internal/HaskellDB/Sql/Print.hs +3/−2
• src/Opaleye/Internal/Optimize.hs +1/−1
• src/Opaleye/Internal/Order.hs +25/−16
• src/Opaleye/Internal/PrimQuery.hs +50/−46
• src/Opaleye/Internal/Print.hs +7/−1
• src/Opaleye/Internal/QueryArr.hs +0/−6
• src/Opaleye/Internal/RunQuery.hs +1/−1
• src/Opaleye/Internal/Sql.hs +42/−31
• src/Opaleye/Internal/Table.hs +4/−0
• src/Opaleye/Operators.hs +8/−0
• src/Opaleye/Order.hs +27/−5
• src/Opaleye/QueryArr.hs +2/−2
• src/Opaleye/Select.hs +10/−1

@@ -1,3 +1,13 @@+## 0.6.7001.0++* Fix bug with infinity in range bounds++* Fix incompatibility with GHC 8.4++* Add range accessors, `upperBound` and `lowerBound`++* Add `distinctOn` and `distinctOnBy`+ ## 0.6.7000.0  This is a pre-release of version 0.7.0.0.  GHC >= 8.0 is required.  It

@@ -1,42 +1,37 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Arrows              #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}  module Main where -import qualified QuickCheck-import qualified TypeFamilies ()--import           Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>))-import qualified Opaleye as O-import qualified Opaleye.Internal.Aggregate as IA--import qualified Database.PostgreSQL.Simple as PGS+import qualified Configuration.Dotenv             as Dotenv+import           Control.Applicative              ((<$>), (<*>), (<|>))+import qualified Control.Applicative              as A+import           Control.Arrow                    ((&&&), (***), (<<<), (>>>))+import qualified Control.Arrow                    as Arr+import qualified Data.Aeson                       as Json+import qualified Data.Function                    as F+import qualified Data.List                        as L+import           Data.Monoid                      ((<>))+import qualified Data.Ord                         as Ord+import qualified Data.Profunctor                  as P+import qualified Data.Profunctor.Product          as PP+import qualified Data.Profunctor.Product.Default  as D+import qualified Data.String                      as String+import qualified Data.Text                        as T+import qualified Data.Time                        as Time+import qualified Database.PostgreSQL.Simple       as PGS import qualified Database.PostgreSQL.Simple.Range as R-import qualified Data.Profunctor.Product.Default as D-import qualified Data.Profunctor.Product as PP-import qualified Data.Profunctor as P-import qualified Data.Ord as Ord-import qualified Data.List as L-import           Data.Monoid ((<>))-import qualified Data.String as String-import qualified Data.Time   as Time-import qualified Data.Aeson as Json-import qualified Data.Text as T--import           System.Environment (lookupEnv)--import           Control.Applicative ((<$>), (<*>), (<|>))-import qualified Control.Applicative as A-import qualified Control.Arrow as Arr-import           Control.Arrow ((&&&), (***), (<<<), (>>>))--import           GHC.Int (Int64)--import Test.Hspec--import qualified Configuration.Dotenv as Dotenv+import           GHC.Int                          (Int64)+import           Opaleye                          (Column, Nullable, Query,+                                                   QueryArr, (.==), (.>))+import qualified Opaleye                          as O+import qualified Opaleye.Internal.Aggregate       as IA+import qualified QuickCheck+import           System.Environment               (lookupEnv)+import           Test.Hspec+import qualified TypeFamilies                     ()  {- @@ -424,6 +419,60 @@ testDistinct :: Test testDistinct = it "" $ O.distinct table1Q `queryShouldReturnSorted` (L.nub table1data) ++testDistinctOn :: Test+testDistinctOn = do+    it "distinct on (col1)" $ \conn -> do+        let p = fst+            q = O.distinctOn p table1Q+            expected = L.nubBy (F.on (==) p) $ L.sortOn p table1data+        testH q (\r -> L.sort r `shouldBe` L.sort expected) conn+    it "distinct on (col1, col2)" $ \conn -> do+        let p = fst &&& snd+            q = O.distinctOn p table1Q+            expected = L.nubBy (F.on (==) p) $ L.sortOn p table1data+        testH q (\r -> L.sort r `shouldBe` L.sort expected) conn++    let f1 (x,_,_) = x+        f2 (_,y,_) = y+        f3 (_,_,z) = z++    it "distinct on (col1) order by col2" $ \conn -> do+        let proj = f1+            ord  = f2+            q = O.distinctOnBy proj (O.asc ord) $ O.values pgTriples+            expected = L.nubBy ((==) `F.on` proj) $ L.sortOn (proj &&& ord) triples+        testH q (\r -> L.sort r `shouldBe` L.sort expected) conn+    it "distinct on (col1, col2) order by col3" $ \conn -> do+        let proj = f1 &&& f2+            ord  = f3+            q = O.distinctOnBy proj (O.asc ord) $ O.values pgTriples+            expected = L.nubBy ((==) `F.on` proj) $ L.sortOn (proj &&& ord) triples+        testH q (\r -> L.sort r `shouldBe` L.sort expected) conn+    it "distinct on (col3) order by col2 desc" $ \conn -> do+        let proj = f3+            ord  = f2+            q = O.distinctOnBy proj (O.desc ord) $ O.values pgTriples+            expected = L.nubBy ((==) `F.on` proj) . L.reverse $+                L.sortOn (proj &&& ord) triples+        testH q (\r -> L.sort r `shouldBe` L.sort expected) conn+    where++        pgTriples :: [(O.Column O.PGInt8, O.Column O.PGInt8, O.Column O.PGText)]+        pgTriples = (\(x,y,z) -> (O.pgInt8 x, O.pgInt8 y, O.pgStrictText z)) <$> triples++        triples :: [(Int64, Int64, T.Text)]+        triples =+            [ (1, 900, "a")+            , (1, 800, "a")+            , (2, 400, "a")+            , (2, 500, "b")+            , (2, 500, "b")+            , (4, 400, "b")+            , (4, 600, "b")+            , (4, 100, "b")+            ]+ -- FIXME: the unsafeCoerceColumn is currently needed because the type -- changes required for aggregation are not currently dealt with by -- Opaleye.@@ -976,6 +1025,22 @@         range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b)         q = A.pure $ (range 1 2) O..-|- (range 2 3) +testRangeBoundsEnum :: forall a b.+    ( Show a, Eq a, Enum a, O.IsRangeType b+    , O.QueryRunnerColumnDefault (Nullable b) (Maybe a))+        => String -> (a -> Column b) -> a -> a -> Test+testRangeBoundsEnum msg mkCol x y = it msg $ \conn -> do+    -- bound functions for discrete range types return fields as from the form [x,y)+    let ranges = [ O.pgRange mkCol (R.Inclusive x) R.PosInfinity+                 , O.pgRange mkCol R.NegInfinity   (R.Inclusive y)+                 , O.pgRange mkCol (R.Exclusive x) (R.Exclusive y)+                 ]+    [r1,r2,r3] <- mapM (O.runQuery conn . pure . (O.lowerBound &&& O.upperBound)) ranges+    r1 `shouldBe` [(Just x, Nothing)]+    r2 `shouldBe` [(Nothing, Just $ succ y)]+    r3 `shouldBe` [(Just $ succ x, Just y)]++ -- Note: these tests are left out of allTests until Travis supports -- Postgresql >= 9.4 jsonbTests :: [Test]@@ -1054,6 +1119,8 @@         testDoubleAggregate       describe "distinct" $ do         testDistinct+      describe "distinct on"+        testDistinctOn       describe "order" $ do         testOrderBy         testOrderBy2@@ -1111,3 +1178,7 @@         testRangeRightExtension         testRangeLeftExtension         testRangeAdjacency+        testRangeBoundsEnum "can access bounds from an Int8 range"+            O.pgInt8 10 26+        testRangeBoundsEnum "can access bounds from a date range"+            O.pgDay (read "2018-01-01") (read "2018-01-12")

@@ -1,6 +1,6 @@ name:            opaleye copyright:       Copyright (c) 2014-2018 Purely Agile Limited-version:         0.6.7000.0+version:         0.6.7001.0 synopsis:        An SQL-generating DSL targeting PostgreSQL description:     An SQL-generating DSL targeting PostgreSQL.  Allows                  Postgres queries to be written within Haskell in a@@ -18,7 +18,7 @@                  CHANGELOG.md                  *.md                  Doc/*.md-tested-with:     GHC==8.2.2, GHC==8.0.2+tested-with:     GHC==8.4.3, GHC==8.2.2, GHC==8.0.2  source-repository head   type:     git@@ -29,7 +29,7 @@   hs-source-dirs: src   build-depends:       aeson               >= 0.6     && < 1.4-    , base                >= 4.6     && < 5+    , base                >= 4.9     && < 5     , base16-bytestring   >= 0.1.1.6 && < 0.2     , case-insensitive    >= 1.2     && < 1.3     , bytestring          >= 0.10    && < 0.11

@@ -19,6 +19,7 @@                                      commaH                                     ) where +import Prelude hiding ((<>)) import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),                                SqlExpr(..), SqlOrder(..), SqlInsert(..),                                SqlUpdate(..), SqlTable(..), SqlRangeBound(..),@@ -137,8 +138,8 @@   where value_boundTypeT = \case           Inclusive a -> (Inclusive', a)           Exclusive a -> (Exclusive', a)-          PosInfinity -> (Exclusive', ConstSqlExpr "'infinity'")-          NegInfinity -> (Exclusive', ConstSqlExpr "'-infinity'")+          PosInfinity -> (Exclusive', ConstSqlExpr "NULL")+          NegInfinity -> (Exclusive', ConstSqlExpr "NULL")          (startType, startValue) = value_boundTypeT start         (endType,   endValue)   = value_boundTypeT end

@@ -41,7 +41,7 @@                                                =<< T.sequence x)                                       <*> pure y   , PQ.aggregate = fmap . PQ.Aggregate-  , PQ.order     = fmap . PQ.Order+  , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns   , 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

@@ -1,21 +1,19 @@ 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-import qualified Opaleye.Internal.PrimQuery as PQ--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ-import qualified Data.Functor.Contravariant as C+import           Data.Function                        (on)+import qualified Data.Functor.Contravariant           as C import qualified Data.Functor.Contravariant.Divisible as Divisible-import qualified Data.Profunctor as P-import qualified Data.Monoid as M-import qualified Data.Semigroup as S-import qualified Data.Void as Void+import qualified Data.List.NonEmpty                   as NL+import qualified Data.Monoid                          as M+import qualified Data.Profunctor                      as P+import qualified Data.Semigroup                       as S+import qualified Data.Void                            as Void+import qualified Opaleye.Column                       as C+import qualified Opaleye.Internal.Column              as IC+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.PrimQuery           as PQ+import qualified Opaleye.Internal.Tag                 as T+import qualified Opaleye.Internal.Unpackspec          as U  {-| An `Order` @a@ represents a sort order and direction for the elements@@ -55,7 +53,7 @@  orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag) orderByU os (columns, primQ, t) = (columns, primQ', t)-  where primQ' = PQ.Order oExprs primQ+  where primQ' = PQ.DistinctOnOrderBy Nothing oExprs primQ         oExprs = orderExprs columns os  orderExprs :: a -> Order a -> [HPQ.OrderExpr]@@ -66,6 +64,17 @@  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)++distinctOn :: U.Unpackspec b b -> (a -> b)+           -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+distinctOn ups proj = distinctOnBy ups proj (Order $ const [])++distinctOnBy :: U.Unpackspec b b -> (a -> b) -> Order a+             -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+distinctOnBy ups proj ord (cols, pq, t) = (cols, pqOut, t)+    where pqOut = case U.collectPEs ups (proj cols) of+            x:xs -> PQ.DistinctOnOrderBy (Just $ x NL.:| xs) (orderExprs cols ord) pq+            []   -> pq  -- | 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

@@ -45,7 +45,11 @@                   | Product   (NEL.NonEmpty (PrimQuery' a)) [HPQ.PrimExpr]                   | Aggregate (Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr))                               (PrimQuery' a)-                  | Order     [HPQ.OrderExpr] (PrimQuery' a)+                  -- | Represents both @DISTINCT ON@ and @ORDER BY@ clauses. In order to represent valid+                  --   SQL only, @DISTINCT ON@ expressions are always interpreted as the first @ORDER BY@s+                  --   when present, preceding any in the provided list.+                  --   See 'Opaleye.Internal.Sql.distinctOnOrderBy'.+                  | DistinctOnOrderBy (Maybe (NEL.NonEmpty HPQ.PrimExpr)) [HPQ.OrderExpr] (PrimQuery' a)                   | Limit     LimitOp (PrimQuery' a)                   | Join      JoinType                               HPQ.PrimExpr@@ -66,62 +70,62 @@ type PrimQueryFold = PrimQueryFold' ()  data PrimQueryFold' a p = PrimQueryFold-  { unit      :: p-  , empty     :: a -> p-  , baseTable :: TableIdentifier -> Bindings HPQ.PrimExpr -> p-  , product   :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p-  , aggregate :: Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> p -> p-  , order     :: [HPQ.OrderExpr] -> p -> p-  , limit     :: LimitOp -> p -> p-  , join      :: JoinType-              -> HPQ.PrimExpr-              -> Bindings HPQ.PrimExpr-              -> Bindings 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+  { unit              :: p+  , empty             :: a -> p+  , baseTable         :: TableIdentifier -> Bindings HPQ.PrimExpr -> p+  , product           :: NEL.NonEmpty p -> [HPQ.PrimExpr] -> p+  , aggregate         :: Bindings (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr) -> p -> p+  , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> p -> p+  , limit             :: LimitOp -> p -> p+  , join              :: JoinType+                      -> HPQ.PrimExpr+                      -> Bindings HPQ.PrimExpr+                      -> Bindings 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     -- ^ A relation-valued expression   }   primQueryFoldDefault :: PrimQueryFold' a (PrimQuery' a) primQueryFoldDefault = PrimQueryFold-  { unit      = Unit-  , empty     = Empty-  , baseTable = BaseTable-  , product   = Product-  , aggregate = Aggregate-  , order     = Order-  , limit     = Limit-  , join      = Join-  , values    = Values-  , binary    = Binary-  , label     = Label-  , relExpr   = RelExpr-  , existsf   = Exists+  { unit              = Unit+  , empty             = Empty+  , baseTable         = BaseTable+  , product           = Product+  , aggregate         = Aggregate+  , distinctOnOrderBy = DistinctOnOrderBy+  , limit             = Limit+  , join              = Join+  , values            = Values+  , binary            = Binary+  , label             = Label+  , relExpr           = RelExpr+  , existsf           = Exists   }  foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p foldPrimQuery f = fix fold   where fold self primQ = case primQ of-          Unit                      -> unit      f-          Empty a                   -> empty     f a-          BaseTable ti syms         -> baseTable f ti syms-          Product qs pes            -> product   f (fmap self qs) pes-          Aggregate aggrs q         -> aggregate f aggrs (self q)-          Order pes q               -> order     f pes (self q)-          Limit op q                -> limit     f op (self q)-          Join j cond pe1 pe2 q1 q2 -> join      f j cond pe1 pe2 (self q1) (self q2)-          Values ss pes             -> values    f ss pes-          Binary binop pes (q1, q2) -> binary    f binop pes (self q1, self q2)-          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)+          Unit                        -> unit              f+          Empty a                     -> empty             f a+          BaseTable ti syms           -> baseTable         f ti syms+          Product qs pes              -> product           f (fmap self qs) pes+          Aggregate aggrs q           -> aggregate         f aggrs (self q)+          DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs (self q)+          Limit op q                  -> limit             f op (self q)+          Join j cond pe1 pe2 q1 q2   -> join              f j cond pe1 pe2 (self q1) (self q2)+          Values ss pes               -> values            f ss pes+          Binary binop pes (q1, q2)   -> binary            f binop pes (self q1, self q2)+          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

@@ -33,9 +33,15 @@ ppSql (SelectLabel v)  = ppSelectLabel v ppSql (SelectExists v) = ppSelectExists v +ppDistinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc+ppDistinctOn = maybe mempty $ \nel ->+    text "DISTINCT ON" <+>+        text "(" $$ HPrint.commaV HPrint.ppSqlExpr (NEL.toList nel) $$ text ")"+ ppSelectFrom :: From -> Doc ppSelectFrom s = text "SELECT"-                 <+> ppAttrs (Sql.attrs s)+                 <+> ppDistinctOn (Sql.distinctOn s)+                 $$  ppAttrs (Sql.attrs s)                  $$  ppTables (Sql.tables s)                  $$  HPrint.ppWhere (Sql.criteria s)                  $$  ppGroupBy (Sql.groupBy s)

@@ -17,16 +17,10 @@ import qualified Data.Profunctor as P 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--- and produce a collection of rows.------ @Query a@ is analogous to a Haskell value @[a]@. type Query = QueryArr ()  simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b

@@ -89,7 +89,7 @@               -- We never actually look at the columns except to see               -- its "type" in the case of a sum profunctor               (columns -> Bool)-              -- ^ Have we actually requested any columns?  If we+              -- Have we actually requested any columns?  If we               -- asked for zero columns then the SQL generator will               -- have to put a dummy 0 into the SELECT statement,               -- since we can't select zero columns.  In that case we

@@ -36,13 +36,14 @@   deriving Show  data From = From {-  attrs     :: SelectAttrs,-  tables    :: [Select],-  criteria  :: [HSql.SqlExpr],-  groupBy   :: Maybe (NEL.NonEmpty HSql.SqlExpr),-  orderBy   :: [(HSql.SqlExpr, HSql.SqlOrder)],-  limit     :: Maybe Int,-  offset    :: Maybe Int+  attrs      :: SelectAttrs,+  tables     :: [Select],+  criteria   :: [HSql.SqlExpr],+  groupBy    :: Maybe (NEL.NonEmpty HSql.SqlExpr),+  orderBy    :: [(HSql.SqlExpr, HSql.SqlOrder)],+  distinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr),+  limit      :: Maybe Int,+  offset     :: Maybe Int   }           deriving Show @@ -82,19 +83,19 @@  sqlQueryGenerator :: PQ.PrimQueryFold' V.Void Select sqlQueryGenerator = PQ.PrimQueryFold-  { PQ.unit      = unit-  , PQ.empty     = empty-  , PQ.baseTable = baseTable-  , PQ.product   = product-  , PQ.aggregate = aggregate-  , PQ.order     = order-  , PQ.limit     = limit_-  , PQ.join      = join-  , PQ.values    = values-  , PQ.binary    = binary-  , PQ.label     = label-  , PQ.relExpr   = relExpr-  , PQ.existsf   = exists+  { PQ.unit              = unit+  , PQ.empty             = empty+  , PQ.baseTable         = baseTable+  , PQ.product           = product+  , PQ.aggregate         = aggregate+  , PQ.distinctOnOrderBy = distinctOnOrderBy+  , PQ.limit             = limit_+  , PQ.join              = join+  , PQ.values            = values+  , PQ.binary            = binary+  , PQ.label             = label+  , PQ.relExpr           = relExpr+  , PQ.existsf           = exists   }  exists :: Bool -> Select -> Select -> Select@@ -153,10 +154,19 @@ 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 $-    newSelect { tables = [s]-              , orderBy = map (SD.toSqlOrder SD.defaultSqlGenerator) oes }+distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select+distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect+    { tables     = [s]+    , distinctOn = fmap (SG.sqlExpr SD.defaultSqlGenerator) <$> distinctExprs+    , orderBy    = map (SD.toSqlOrder SD.defaultSqlGenerator) $+        -- Postgres requires all 'DISTINCT ON' expressions to appear before any other+        -- 'ORDER BY' expressions if there are any.+        maybe [] (map (HPQ.OrderExpr ascOp) . NEL.toList) distinctExprs ++ orderExprs+    }+    where+        ascOp = HPQ.OrderOp+            { HPQ.orderDirection = HPQ.OpAsc+            , HPQ.orderNulls     = HPQ.NullsLast }  limit_ :: PQ.LimitOp -> Select -> Select limit_ lo s = SelectFrom $ newSelect { tables = [s]@@ -221,13 +231,14 @@  newSelect :: From newSelect = From {-  attrs     = Star,-  tables    = [],-  criteria  = [],-  groupBy   = Nothing,-  orderBy   = [],-  limit     = Nothing,-  offset    = Nothing+  attrs      = Star,+  tables     = [],+  criteria   = [],+  groupBy    = Nothing,+  orderBy    = [],+  distinctOn = Nothing,+  limit      = Nothing,+  offset     = Nothing   }  sqlExpr :: HPQ.PrimExpr -> HSql.SqlExpr

@@ -19,6 +19,7 @@ import qualified Data.Profunctor.Product as PP import qualified Data.List.NonEmpty as NEL import           Data.Monoid (Monoid, mempty, mappend)+import           Data.Semigroup (Semigroup, (<>)) import           Control.Applicative (Applicative, pure, (<*>), liftA2) import qualified Control.Arrow as Arr @@ -177,6 +178,9 @@         extract (pes, s) = ((Zip (fmap return pes), [s]), ())  data Zip a = Zip { unZip :: NEL.NonEmpty [a] }++instance Semigroup (Zip a) where+  (<>) = mappend  instance Monoid (Zip a) where   mempty = Zip mempty'

@@ -349,6 +349,14 @@ liesWithin :: T.IsRangeType a => Column a -> Column (T.SqlRange a) -> F.Field T.SqlBool liesWithin = C.binOp (HPQ.:<@) +-- | Access the upper bound of a range. For discrete range types it is the exclusive bound.+upperBound :: T.IsRangeType a => Column (T.SqlRange a) -> Column (C.Nullable a)+upperBound (Column range) = Column $ HPQ.FunExpr "upper" [range]++-- | Access the lower bound of a range. For discrete range types it is the inclusive bound.+lowerBound :: T.IsRangeType a => Column (T.SqlRange a) -> Column (C.Nullable a)+lowerBound (Column range) = Column $ HPQ.FunExpr "lower" [range]+ infix 4 .<< (.<<) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.<<) = C.binOp (HPQ.:<<)

@@ -1,7 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-} --- | Ordering, @LIMIT@ and @OFFSET@+-- | Ordering, @LIMIT@, @OFFSET@ and @DISTINCT ON@  module Opaleye.Order ( -- * Order by                        orderBy@@ -14,6 +15,9 @@                      -- * Limit and offset                      , limit                      , offset+                     -- * Distinct on+                     , distinctOn+                     , distinctOnBy                      -- * Exact ordering                      , O.exact                      -- * Other@@ -21,15 +25,15 @@                      , SqlOrd                      ) where +import qualified Data.Profunctor.Product.Default as D import qualified Opaleye.Column as C-import           Opaleye.QueryArr (Query)-import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.Order as O+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Select         as S import qualified Opaleye.SqlTypes as T -import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ- -- We can probably disable ConstraintKinds and TypeSynonymInstances -- when we move to Sql... instead of PG.. @@ -116,6 +120,24 @@ -} offset :: Int -> S.Select a -> S.Select a offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a)++-- * Distinct on++-- | Keep a row from each set where the given function returns the same result. No+--   ordering is guaranteed. Mutliple fields may be distinguished by projecting out+--   tuples of 'Column's. Use 'distinctOnBy' to control how the rows are chosen.+distinctOn :: D.Default U.Unpackspec b b => (a -> b) -> S.Select a -> S.Select a+distinctOn proj q = Q.simpleQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)+++-- | Keep the row from each set where the given function returns the same result. The+--   row is chosen according to which comes first by the supplied ordering. However, no+--   output ordering is guaranteed. Mutliple fields may be distinguished by projecting+--   out tuples of 'Column's.+distinctOnBy :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a+             -> S.Select a -> S.Select a+distinctOnBy proj ord q = Q.simpleQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)+  -- * Other 

@@ -1,5 +1,5 @@--- | 'Query' and 'QueryArr' are the composable units of database--- querying that are used in Opaleye.+-- | Use "Opaleye.Select" instead.  This module will be deprecated in+-- 0.7.  module Opaleye.QueryArr (Query, QueryArr) where 

@@ -1,6 +1,15 @@+-- | 'Select' and 'SelectArr' are the composable units of database+-- querying that are used in Opaleye.+ module Opaleye.Select where  import qualified Opaleye.QueryArr as Q -type SelectArr = Q.QueryArr+-- | A Postgres @SELECT@, i.e. some functionality that can run via SQL+-- and produce a collection of rows.+--+-- @Select a@ is analogous to a Haskell value @[a]@. type Select = SelectArr ()++-- | @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.+type SelectArr = Q.QueryArr