From a1a09e736f9827628b4751f4aad88babef41f220 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Fri, 19 Jun 2015 15:45:15 -0300 Subject: [PATCH] New distinct, distinctOn. Deprecate old specializations. --- src/Database/Esqueleto.hs | 3 +- src/Database/Esqueleto/Internal/Language.hs | 59 ++++++++++ src/Database/Esqueleto/Internal/Sql.hs | 118 +++++++++++--------- test/Test.hs | 60 ++++++++-- 4 files changed, 178 insertions(+), 62 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index adbcb5d..cc1a7b4 100644 --- a/src/Database/Esqueleto.hs +++ b/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_ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index fa4f9d8..e3d9d94 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/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 *., /. diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index e33d2df..7338687 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/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] - , sdSetClause :: ![SetClause] - , sdWhereClause :: !WhereClause - , sdGroupByClause :: !GroupByClause - , sdHavingClause :: !HavingClause - , sdOrderByClause :: ![OrderByClause] - , sdLimitClause :: !LimitClause +data SideData = SideData { sdDistinctClause :: !DistinctClause + , sdFromClause :: ![FromClause] + , sdSetClause :: ![SetClause] + , sdWhereClause :: !WhereClause + , sdGroupByClause :: !GroupByClause + , sdHavingClause :: !HavingClause + , sdOrderByClause :: ![OrderByClause] + , sdLimitClause :: !LimitClause } instance Monoid SideData where - mempty = SideData 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 (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') + mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty + SideData d f s w g h o l `mappend` SideData d' f' s' w' g' h' o' 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 - src <- lift $ do - res <- rawSelectSource SELECT_DISTINCT query - fmap snd $ allocateAcquire res - src +selectDistinctSource = selectSource . distinct +{-# DEPRECATED selectDistinctSource "Since 2.2.4: use 'selectSource' and 'distinct'." #-} -- | 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 - res <- rawSelectSource SELECT_DISTINCT query - conn <- R.ask - liftIO $ with res $ flip R.runReaderT conn . runSource +selectDistinct = select . distinct +{-# DEPRECATED selectDistinct "Since 2.2.4: use 'select' and 'distinct'." #-} -- | (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 - -- ^ 'Mode' should be either 'SELECT' or 'SELECT_DISTINCT'. + | INSERT_INTO 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 _ _ _ = mempty +makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret +makeInsertInto _ _ _ = mempty -makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) -makeSelect info mode_ ret = process mode_ +makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue]) +makeSelect info mode_ distinctClause ret = process mode_ where process mode = case mode of - SELECT -> withCols "SELECT " - SELECT_DISTINCT -> withCols "SELECT DISTINCT " - DELETE -> plain "DELETE " - UPDATE -> plain "UPDATE " - INSERT_INTO mode' -> process mode' - withCols v = first (v <>) (sqlSelectCols info ret) + SELECT -> withCols selectKind + DELETE -> plain "DELETE " + UPDATE -> plain "UPDATE " + INSERT_INTO -> process SELECT + selectKind = + 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) = - let (b, vals) = f info - in (parensM p b, vals) - sqlSelectCols info (ECompositeKey f) = - let bs = f info - in (uncommas $ map (parensM Parens) bs, []) + sqlSelectCols = materializeExpr 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 - - -insertGeneralSelect :: (MonadIO m, PersistEntity a) => - Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () -insertGeneralSelect mode = - liftM (const ()) . rawEsqueleto (INSERT_INTO mode) . fmap EInsertFinal +insertSelectDistinct = insertSelect . distinct +{-# DEPRECATED insertSelectDistinct "Since 2.2.4: use 'insertSelect' and 'distinct'." #-} diff --git a/test/Test.hs b/test/Test.hs index 350b582..d1c5c9b 100644 --- a/test/Test.hs +++ b/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" $ - it "works on a simple example" $ + describe "SELECT DISTINCT" $ do + 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 - let (t1, t2, t3) = ("a", "b", "c") - mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1] - ret <- selectDistinct $ - from $ \b -> do - let title = b ^. BlogPostTitle - orderBy [asc title] - return title - liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] + [p1k, p2k, _] <- mapM insert [p1, p2, p3] + [bpA, bpB, bpC] <- mapM insert' + [ BlogPost "A" p1k + , BlogPost "B" p1k + , BlogPost "C" p2k ] + ret <- select $ + from $ \bp -> + distinctOn [bp ^. BlogPostAuthorId] $ do + 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" $