diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 2.2.3 +version: 2.2.4 synopsis: Type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/prowdsponsor/esqueleto license: BSD3 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -38,7 +38,8 @@ -- $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, don, distinctOnOrderBy, having , sub_select, sub_selectDistinct, (^.), (?.) , val, isNothing, just, nothing, joinV, countRows, count, not_ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) @@ -59,6 +60,7 @@ , unValue , ValueList(..) , OrderBy + , DistinctOn -- ** Joins , InnerJoin(..) , CrossJoin(..) diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -27,6 +27,7 @@ , FullOuterJoin(..) , OnClauseWithoutMatchingJoinException(..) , OrderBy + , DistinctOn , Update , Insertion -- * The guts @@ -179,6 +180,86 @@ -- | @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' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] $ do + -- ... + -- @ + -- + -- You can also chain different calls to 'distinctOn'. The + -- above is equivalent to: + -- + -- @ + -- select $ + -- 'from' \\foo -> + -- 'distinctOn' ['don' (foo ^. FooName)] $ + -- 'distinctOn' ['don' (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 DistinctOn] -> query a -> query a + + -- | Erase an expression's type so that it's suitable to + -- be used by 'distinctOn'. + -- + -- /Since: 2.2.4/ + don :: expr (Value a) -> expr DistinctOn + + -- | A convenience function that calls both 'distinctOn' and + -- 'orderBy'. In other words, + -- + -- @ + -- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] $ do + -- ... + -- @ + -- + -- is the same as: + -- + -- @ + -- 'distinctOn' [don foo, don bar, don quux] $ do + -- 'orderBy' [asc foo, desc bar, desc quux] + -- ... + -- @ + -- + -- /Since: 2.2.4/ + distinctOnOrderBy :: [expr OrderBy] -> query a -> query a + -- | @ORDER BY random()@ clause. -- -- /Since: 1.3.10/ @@ -390,6 +471,10 @@ -- /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 *., /. @@ -600,6 +685,10 @@ -- | Phantom type used by 'orderBy', 'asc' and 'desc'. data OrderBy + + +-- | Phantom type used by 'distinctOn' and 'don'. +data DistinctOn -- | Phantom type for a @SET@ operation on an entity of the given diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -103,21 +103,36 @@ -- | 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 DistinctOn] -- ^ @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. data FromClause = FromStart Ident EntityDef @@ -313,6 +328,9 @@ EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy EOrderRandom :: SqlExpr OrderBy + -- A 'SqlExpr' accepted only by 'distinctOn'. + EDistinctOn :: SqlExpr (Value a) -> SqlExpr DistinctOn + -- A 'SqlExpr' accepted only by 'set'. ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) @@ -383,8 +401,19 @@ 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 + don = EDistinctOn + distinctOnOrderBy exprs act = + distinctOn (toDistinctOn <$> exprs) $ do + orderBy exprs + act + where + toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn + toDistinctOn (EOrderBy _ f) = EDistinctOn f + 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 +480,7 @@ (++.) = 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 +830,8 @@ , 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 +839,8 @@ 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 +949,8 @@ flip S.runState firstIdentState $ W.runWriterT $ unQ query - SideData fromClauses + SideData distinctClause + fromClauses setClauses whereClauses groupByClause @@ -939,7 +964,7 @@ 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 +978,9 @@ -- | (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 +994,27 @@ 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' (processExpr <$> exprs) + where processExpr (EDistinctOn f) = materializeExpr info f + withCols v = v <> (sqlSelectCols info ret) plain v = (v, []) @@ -1176,17 +1205,22 @@ -- | 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 +1715,11 @@ -- | 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 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE ConstraintKinds , EmptyDataDecls , FlexibleContexts @@ -18,12 +19,15 @@ module Main (main) where import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) import Control.Exception (IOException) -import Control.Monad (replicateM, replicateM_) +import Control.Monad (replicateM, replicateM_, void) 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) @@ -448,12 +452,12 @@ it "respects the associativity of joins" $ run $ do - insert' p1 + void $ insert p1 ps <- select . from $ \((p :: SqlExpr (Entity Person)) `LeftOuterJoin` - (( q :: SqlExpr (Entity Person)) - `InnerJoin` (r :: SqlExpr (Entity Person)))) -> do + ((_q :: SqlExpr (Entity Person)) + `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do on (val False) -- Inner join is empty on (val True) return p @@ -560,18 +564,18 @@ p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1 -- lower(name) == 'john' - ret <- select $ - from $ \p-> do - where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) - return p - liftIO $ ret `shouldBe` [ p1e ] + ret1 <- select $ + from $ \p-> do + where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) + return p + liftIO $ ret1 `shouldBe` [ p1e ] -- name == lower('BOB') - ret <- select $ - from $ \p-> do - where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) - return p - liftIO $ ret `shouldBe` [ p2e ] + ret2 <- select $ + from $ \p-> do + where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) + return p + liftIO $ ret2 `shouldBe` [ p2e ] it "works with random_" $ run $ do @@ -779,19 +783,76 @@ 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] + [_, bpB, bpC] <- mapM insert' + [ BlogPost "A" p1k + , BlogPost "B" p1k + , BlogPost "C" p2k ] + ret <- select $ + from $ \bp -> + distinctOn [don (bp ^. BlogPostAuthorId)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] + return bp + liftIO $ ret `shouldBe` sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] + let slightlyLessSimpleTest q = + run $ do + [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 -> + q bp $ return bp + let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal + liftIO $ ret `shouldBe` sortBy (comparing cmp) [bpA, bpB, bpC] + it "works on a slightly less simple example (two distinctOn calls, orderBy)" $ + slightlyLessSimpleTest $ \bp act -> + distinctOn [don (bp ^. BlogPostAuthorId)] $ + distinctOn [don (bp ^. BlogPostTitle)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] + act + it "works on a slightly less simple example (one distinctOn call, orderBy)" $ do + slightlyLessSimpleTest $ \bp act -> + distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] + act + it "works on a slightly less simple example (distinctOnOrderBy)" $ do + slightlyLessSimpleTest $ \bp -> + distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] +#endif + describe "coalesce/coalesceDefault" $ do it "works on a simple example" $ run $ do @@ -878,7 +939,7 @@ #if defined(WITH_POSTGRESQL) it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ run $ do - [p1e, p2e, p3e, p4e, p5e] <- mapM insert' [p1, p2, p3, p4, p5] + [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] let nameContains t expected = do ret <- select $ from $ \p -> do @@ -1098,6 +1159,7 @@ where_ $ exists $ from $ \bp -> do where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ Entity p1k p1 , Entity p3k p3 ] @@ -1274,7 +1336,7 @@ #endif runSqlConn . #if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL) - (runMigration migrateAll >>) $ (cleanDB >> act) + (runMigrationSilent migrateAll >>) $ (cleanDB >> act) #else (runMigrationSilent migrateAll >>) $ act #endif