From b8814fb09ab390b3529110e5f2964c8715cc5066 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Fri, 19 Jun 2015 22:47:41 -0300 Subject: [PATCH] Make distinctOn work like orderBy via 'don'. --- src/Database/Esqueleto.hs | 3 ++- src/Database/Esqueleto/Internal/Language.hs | 23 +++++++++++++++------ src/Database/Esqueleto/Internal/Sql.hs | 14 ++++++++----- test/Test.hs | 6 +++--- 4 files changed, 31 insertions(+), 15 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index cc1a7b4..3055c5c 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -39,7 +39,7 @@ module Database.Esqueleto -- * @esqueleto@'s Language Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset - , distinct, distinctOn, having + , distinct, distinctOn, don, having , sub_select, sub_selectDistinct, (^.), (?.) , val, isNothing, just, nothing, joinV, countRows, count, not_ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) @@ -60,6 +60,7 @@ module Database.Esqueleto , unValue , ValueList(..) , OrderBy + , DistinctOn -- ** Joins , InnerJoin(..) , CrossJoin(..) diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index e3d9d94..311b771 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -27,6 +27,7 @@ module Database.Esqueleto.Internal.Language , FullOuterJoin(..) , OnClauseWithoutMatchingJoinException(..) , OrderBy + , DistinctOn , Update , Insertion -- * The guts @@ -206,18 +207,18 @@ class (Functor query, Applicative query, Monad query) => -- @ -- select $ -- 'from' \\foo -> - -- distinctOn [foo ^. FooName, foo ^. FooState] $ do + -- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] $ do -- ... -- @ -- - -- You can also chain different calls to 'distinctOn' whenever - -- your fields have different types: + -- You can also chain different calls to 'distinctOn'. The + -- above is equivalent to: -- -- @ -- select $ -- 'from' \\foo -> - -- distinctOn [foo ^. FooName] $ - -- distinctOn [foo ^. FooState] $ do + -- 'distinctOn' ['don' (foo ^. FooName)] $ + -- 'distinctOn' ['don' (foo ^. FooState)] $ do -- ... -- @ -- @@ -232,7 +233,13 @@ class (Functor query, Applicative query, Monad query) => -- Supported by PostgreSQL only. -- -- /Since: 2.2.4/ - distinctOn :: [expr (Value b)] -> query a -> query a + 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 -- | @ORDER BY random()@ clause. -- @@ -661,6 +668,10 @@ data PreprocessedFrom a data OrderBy +-- | Phantom type used by 'distinctOn' and 'don'. +data DistinctOn + + -- | Phantom type for a @SET@ operation on an entity of the given -- type (see 'set' and '(=.)'). data Update typ diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 7338687..5e8353e 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -123,7 +123,7 @@ instance Monoid SideData where data DistinctClause = DistinctAll -- ^ The default, everything. | DistinctStandard -- ^ Only @DISTINCT@, SQL standard. - | DistinctOn [SqlExpr (Value ())] -- ^ @DISTINCT ON@, PostgreSQL extension. + | DistinctOn [SqlExpr DistinctOn] -- ^ @DISTINCT ON@, PostgreSQL extension. instance Monoid DistinctClause where mempty = DistinctAll @@ -328,6 +328,9 @@ data SqlExpr a where 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) @@ -398,9 +401,9 @@ 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 + distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act + distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act + don = EDistinctOn sub_select = sub SELECT sub_selectDistinct = sub_select . distinct @@ -1002,7 +1005,8 @@ makeSelect info mode_ distinctClause ret = process mode_ DistinctAll -> ("SELECT ", []) DistinctStandard -> ("SELECT DISTINCT ", []) DistinctOn exprs -> first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ - uncommas' (materializeExpr info <$> exprs) + uncommas' (processExpr <$> exprs) + where processExpr (EDistinctOn f) = materializeExpr info f withCols v = v <> (sqlSelectCols info ret) plain v = (v, []) diff --git a/test/Test.hs b/test/Test.hs index c3c9335..943f32a 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -820,7 +820,7 @@ main = do , BlogPost "C" p2k ] ret <- select $ from $ \bp -> - distinctOn [bp ^. BlogPostAuthorId] $ do + distinctOn [don (bp ^. BlogPostAuthorId)] $ do orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] return bp liftIO $ ret `shouldBe` sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] @@ -834,8 +834,8 @@ main = do , BlogPost "C" p2k ] ret <- select $ from $ \bp -> - distinctOn [bp ^. BlogPostAuthorId] $ - distinctOn [bp ^. BlogPostTitle] $ do + distinctOn [don (bp ^. BlogPostAuthorId)] $ + distinctOn [don (bp ^. BlogPostTitle)] $ do orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] return bp let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal