New distinct, distinctOn. Deprecate old specializations.

src/Database/Esqueleto.hs

@@ -38,7 +38,8 @@ module Database.Esqueleto
     -- $gettingstarted
 
     -- * @esqueleto@'s Language
-    Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset, having
+    Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
+             , distinct, distinctOn, having
              , sub_select, sub_selectDistinct, (^.), (?.)
              , val, isNothing, just, nothing, joinV, countRows, count, not_
              , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)

src/Database/Esqueleto/Internal/Language.hs

@@ -179,6 +179,61 @@ class (Functor query, Applicative query, Monad query) =>
   -- | @OFFSET@.  Usually used with 'limit'.
   offset :: Int64 -> query ()
 
+  -- | @DISTINCT@.  Change the current @SELECT@ into @SELECT
+  -- DISTINCT@.  For example:
+  --
+  -- @
+  -- select $ distinct $
+  --   'from' \\foo -> do
+  --   ...
+  -- @
+  --
+  -- Note that this also has the same effect:
+  --
+  -- @
+  -- select $
+  --   'from' \\foo -> do
+  --   distinct (return ())
+  --   ...
+  -- @
+  --
+  -- /Since: 2.2.4/
+  distinct :: query a -> query a
+
+  -- | @DISTINCT ON@.  Change the current @SELECT@ into
+  -- @SELECT DISTINCT ON (expressions)@.  For example:
+  --
+  -- @
+  -- select $
+  --   'from' \\foo ->
+  --   distinctOn [foo ^. FooName, foo ^. FooState] $ do
+  --   ...
+  -- @
+  --
+  -- You can also chain different calls to 'distinctOn' whenever
+  -- your fields have different types:
+  --
+  -- @
+  -- select $
+  --   'from' \\foo ->
+  --   distinctOn [foo ^. FooName] $
+  --   distinctOn [foo ^. FooState] $ do
+  --   ...
+  -- @
+  --
+  -- Each call to 'distinctOn' adds more expressions.  Calls to
+  -- 'distinctOn' override any calls to 'distinct'.
+  --
+  -- Note that PostgreSQL requires the expressions on @DISTINCT
+  -- ON@ to be the first ones to appear on a @ORDER BY@.  This is
+  -- not managed automatically by esqueleto, keeping its spirit
+  -- of trying to be close to raw SQL.
+  --
+  -- Supported by PostgreSQL only.
+  --
+  -- /Since: 2.2.4/
+  distinctOn :: [expr (Value b)] -> query a -> query a
+
   -- | @ORDER BY random()@ clause.
   --
   -- /Since: 1.3.10/
@@ -390,6 +445,10 @@ class (Functor query, Applicative query, Monad query) =>
   -- /Since: 2.1.2/
   case_ :: PersistField a => [(expr (Value Bool), expr (Value a))] -> expr (Value a) -> expr (Value a)
 
+{-# DEPRECATED sub_selectDistinct "Since 2.2.4: use 'sub_select' and 'distinct'." #-}
+{-# DEPRECATED subList_selectDistinct "Since 2.2.4: use 'subList_select' and 'distinct'." #-}
+
+
 -- Fixity declarations
 infixl 9 ^.
 infixl 7 *., /.

src/Database/Esqueleto/Internal/Sql.hs

@@ -103,19 +103,34 @@ type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)
 
 
 -- | Side data written by 'SqlQuery'.
-data SideData = SideData { sdFromClause    :: ![FromClause]
+data SideData = SideData { sdDistinctClause :: !DistinctClause
-                         , sdSetClause     :: ![SetClause]
+                         , sdFromClause     :: ![FromClause]
-                         , sdWhereClause   :: !WhereClause
+                         , sdSetClause      :: ![SetClause]
-                         , sdGroupByClause :: !GroupByClause
+                         , sdWhereClause    :: !WhereClause
-                         , sdHavingClause  :: !HavingClause
+                         , sdGroupByClause  :: !GroupByClause
-                         , sdOrderByClause :: ![OrderByClause]
+                         , sdHavingClause   :: !HavingClause
-                         , sdLimitClause   :: !LimitClause
+                         , sdOrderByClause  :: ![OrderByClause]
+                         , sdLimitClause    :: !LimitClause
                          }
 
 instance Monoid SideData where
-  mempty = SideData mempty mempty mempty mempty mempty mempty mempty
+  mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty
-  SideData f s w g h o l `mappend` SideData f' s' w' g' h' o' l' =
+  SideData d f s w g h o l `mappend` SideData d' f' s' w' g' h' o' l' =
-    SideData (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l')
+    SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l')
+
+
+-- | The @DISTINCT@ "clause".
+data DistinctClause =
+    DistinctAll                     -- ^ The default, everything.
+  | DistinctStandard                -- ^ Only @DISTINCT@, SQL standard.
+  | DistinctOn [SqlExpr (Value ())] -- ^ @DISTINCT ON@, PostgreSQL extension.
+
+instance Monoid DistinctClause where
+  mempty = DistinctAll
+  DistinctOn a     `mappend` DistinctOn b = DistinctOn (a <> b)
+  DistinctOn a     `mappend` _            = DistinctOn a
+  DistinctStandard `mappend` _            = DistinctStandard
+  DistinctAll      `mappend` b            = b
 
 
 -- | A part of a @FROM@ clause.
@@ -383,8 +398,12 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
   limit  n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing  }
   offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing  (Just n) }
 
+  distinct         act = Q (W.tell mempty { sdDistinctClause = DistinctStandard  }) >> act
+  distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs' }) >> act
+    where exprs' = map veryUnsafeCoerceSqlExprValue exprs
+
   sub_select         = sub SELECT
-  sub_selectDistinct = sub SELECT_DISTINCT
+  sub_selectDistinct = sub_select . distinct
 
   (^.) :: forall val typ. (PersistEntity val, PersistField typ)
        => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ)
@@ -451,7 +470,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
   (++.)   = unsafeSqlBinOp    " || "
 
   subList_select         = EList . sub_select
-  subList_selectDistinct = EList . sub_selectDistinct
+  subList_selectDistinct = subList_select . distinct
 
   valList []   = EEmptyList
   valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)
@@ -801,11 +820,8 @@ selectDistinctSource
      , MonadResource m )
   => SqlQuery a
   -> C.Source (SqlPersistT m) r
-selectDistinctSource query = do
+selectDistinctSource = selectSource . distinct
-    src <- lift $ do
+{-# DEPRECATED selectDistinctSource "Since 2.2.4: use 'selectSource' and 'distinct'." #-}
-        res <- rawSelectSource SELECT_DISTINCT query
-        fmap snd $ allocateAcquire res
-    src
 
 
 -- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside
@@ -813,10 +829,8 @@ selectDistinctSource query = do
 selectDistinct :: ( SqlSelect a r
                   , MonadIO m )
                => SqlQuery a -> SqlPersistT m [r]
-selectDistinct query = do
+selectDistinct = select . distinct
-    res <- rawSelectSource SELECT_DISTINCT query
+{-# DEPRECATED selectDistinct "Since 2.2.4: use 'select' and 'distinct'." #-}
-    conn <- R.ask
-    liftIO $ with res $ flip R.runReaderT conn . runSource
 
 
 -- | (Internal) Run a 'C.Source' of rows.
@@ -925,7 +939,8 @@ toRawSql mode (conn, firstIdentState) query =
         flip S.runState firstIdentState $
         W.runWriterT $
         unQ query
-      SideData fromClauses
+      SideData distinctClause
+               fromClauses
                setClauses
                whereClauses
                groupByClause
@@ -939,7 +954,7 @@ toRawSql mode (conn, firstIdentState) query =
       info = (conn, finalIdentState)
   in mconcat
       [ makeInsertInto info mode ret
-      , makeSelect     info mode ret
+      , makeSelect     info mode distinctClause ret
       , makeFrom       info mode fromClauses
       , makeSet        info setClauses
       , makeWhere      info whereClauses
@@ -953,11 +968,9 @@ toRawSql mode (conn, firstIdentState) query =
 -- | (Internal) Mode of query being converted by 'toRawSql'.
 data Mode =
     SELECT
-  | SELECT_DISTINCT
   | DELETE
   | UPDATE
-  | INSERT_INTO Mode
+  | INSERT_INTO
-    -- ^ 'Mode' should be either 'SELECT' or 'SELECT_DISTINCT'.
 
 
 uncommas :: [TLB.Builder] -> TLB.Builder
@@ -971,21 +984,26 @@ uncommas' = (uncommas *** mconcat) . unzip
 
 
 makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
-makeInsertInto info (INSERT_INTO _) ret = sqlInsertInto info ret
+makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret
-makeInsertInto _    _               _   = mempty
+makeInsertInto _    _           _   = mempty
 
 
-makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])
+makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue])
-makeSelect info mode_ ret = process mode_
+makeSelect info mode_ distinctClause ret = process mode_
   where
     process mode =
       case mode of
-        SELECT            -> withCols "SELECT "
+        SELECT      -> withCols selectKind
-        SELECT_DISTINCT   -> withCols "SELECT DISTINCT "
+        DELETE      -> plain "DELETE "
-        DELETE            -> plain "DELETE "
+        UPDATE      -> plain "UPDATE "
-        UPDATE            -> plain "UPDATE "
+        INSERT_INTO -> process SELECT
-        INSERT_INTO mode' -> process mode'
+    selectKind =
-    withCols v = first (v <>) (sqlSelectCols info ret)
+      case distinctClause of
+        DistinctAll      -> ("SELECT ", [])
+        DistinctStandard -> ("SELECT DISTINCT ", [])
+        DistinctOn exprs -> first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $
+                            uncommas' (materializeExpr info <$> exprs)
+    withCols v = v <> (sqlSelectCols info ret)
     plain    v = (v, [])
 
 
@@ -1176,17 +1194,22 @@ instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entit
 -- | You may return any single value (i.e. a single column) from
 -- a 'select' query.
 instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
-  sqlSelectCols info (ERaw p f) =
+  sqlSelectCols = materializeExpr
-    let (b, vals) = f info
-    in (parensM p b, vals)
-  sqlSelectCols info (ECompositeKey f) =
-    let bs = f info
-    in (uncommas $ map (parensM Parens) bs, [])
   sqlSelectColCount = const 1
   sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
   sqlSelectProcessRow pvs  = Value <$> fromPersistValue (PersistList pvs)
 
 
+-- | Materialize a @SqlExpr (Value a)@.
+materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
+materializeExpr info (ERaw p f) =
+  let (b, vals) = f info
+  in (parensM p b, vals)
+materializeExpr info (ECompositeKey f) =
+  let bs = f info
+  in (uncommas $ map (parensM Parens) bs, [])
+
+
 -- | You may return tuples (up to 16-tuples) and tuples of tuples
 -- from a 'select' query.
 instance ( SqlSelect a ra
@@ -1681,16 +1704,11 @@ to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,
 -- | Insert a 'PersistField' for every selected value.
 insertSelect :: (MonadIO m, PersistEntity a) =>
   SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
-insertSelect = insertGeneralSelect SELECT
+insertSelect = liftM (const ()) . rawEsqueleto INSERT_INTO . fmap EInsertFinal
 
 
 -- | Insert a 'PersistField' for every unique selected value.
 insertSelectDistinct :: (MonadIO m, PersistEntity a) =>
   SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
-insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT
+insertSelectDistinct = insertSelect . distinct
-
+{-# DEPRECATED insertSelectDistinct "Since 2.2.4: use 'insertSelect' and 'distinct'." #-}
-
-insertGeneralSelect :: (MonadIO m, PersistEntity a) =>
-  Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m ()
-insertGeneralSelect mode =
-  liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal

test/Test.hs

@@ -24,6 +24,8 @@ import Control.Monad.IO.Class (MonadIO(liftIO))
 import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT)
 import Control.Monad.Trans.Control (MonadBaseControl(..))
 import Control.Monad.Trans.Reader (ReaderT)
+import Data.List (sortBy)
+import Data.Ord (comparing)
 import Database.Esqueleto
 #if   defined (WITH_POSTGRESQL)
 import Database.Persist.Postgresql (withPostgresqlConn)
@@ -51,6 +53,12 @@ import Data.Char (toLower, toUpper)
 
 -- Test schema
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+  Foo
+    name Int
+    Primary name
+  Bar
+    quux FooId
+
   Person
     name String
     age Int Maybe
@@ -773,18 +781,48 @@ main = do
           liftIO $ map entityVal eps `shouldBe` reverse ps
 
 
-    describe "selectDistinct" $
+    describe "SELECT DISTINCT" $ do
-      it "works on a simple example" $
+      let selDistTest
+            :: (   forall m. RunDbMonad m
+                => SqlQuery (SqlExpr (Value String))
+                -> SqlPersistT (R.ResourceT m) [Value String])
+            -> IO ()
+          selDistTest q =
+            run $ do
+              p1k <- insert p1
+              let (t1, t2, t3) = ("a", "b", "c")
+              mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]
+              ret <- q $
+                     from $ \b -> do
+                     let title = b ^. BlogPostTitle
+                     orderBy [asc title]
+                     return title
+              liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
+      it "works on a simple example (selectDistinct)" $
+        selDistTest selectDistinct
+
+      it "works on a simple example (select . distinct)" $
+        selDistTest (select . distinct)
+
+      it "works on a simple example (distinct (return ()))" $
+        selDistTest (\act -> select $ distinct (return ()) >> act)
+
+#if defined(WITH_POSTGRESQL)
+    describe "SELECT DISTINCT ON" $ do
+      it "works on a simple example" $ do
         run $ do
-          p1k <- insert p1
+          [p1k, p2k, _] <- mapM insert [p1, p2, p3]
-          let (t1, t2, t3) = ("a", "b", "c")
+          [bpA, bpB, bpC] <- mapM insert'
-          mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]
+            [ BlogPost "A" p1k
-          ret <- selectDistinct $
+            , BlogPost "B" p1k
-                 from $ \b -> do
+            , BlogPost "C" p2k ]
-                 let title = b ^. BlogPostTitle
+          ret <- select $
-                 orderBy [asc title]
+                 from $ \bp ->
-                 return title
+                 distinctOn [bp ^. BlogPostAuthorId] $ do
-          liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
+                 orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]
+                 return bp
+          liftIO $ ret `shouldBe` sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]
+#endif
 
     describe "coalesce/coalesceDefault" $ do
       it "works on a simple example" $