From 31b4b0669f77775ef8f0bd04dbd15899675a97fd Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 4 Sep 2012 18:12:40 -0300 Subject: [PATCH] orderBy, asc, desc. --- src/Database/Esqueleto.hs | 5 +- src/Database/Esqueleto/Internal/Language.hs | 16 +++++- src/Database/Esqueleto/Internal/Sql.hs | 60 ++++++++++++++------- test/Test.hs | 49 ++++++++++++++++- 4 files changed, 105 insertions(+), 25 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index e16bdd9..545ae48 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -16,11 +16,12 @@ -- @ module Database.Esqueleto ( -- * Esqueleto's Language - Esqueleto( where_, sub, (^.), val, isNothing, just, nothing - , not_, (==.), (>=.) + Esqueleto( where_, orderBy, asc, desc, sub, (^.), val + , isNothing, just, nothing, not_, (==.), (>=.) , (>.), (<=.), (<.), (!=.), (&&.), (||.) , (+.), (-.), (/.), (*.) ) , from + , OrderBy -- * SQL backend , SqlQuery diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index 2911036..4b9762c 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, EmptyDataDecls #-} module Database.Esqueleto.Internal.Language ( Esqueleto(..) , from + , OrderBy ) where import Control.Applicative (Applicative(..), (<$>)) @@ -20,6 +21,15 @@ class (Functor query, Applicative query, Monad query) => -- | @WHERE@ clause: restrict the query's result. where_ :: expr (Single Bool) -> query () + -- | @ORDER BY@ clause. See also 'asc' and 'desc'. + orderBy :: [expr OrderBy] -> query () + + -- | Ascending order of this field or expression. + asc :: PersistField a => expr (Single a) -> expr OrderBy + + -- | Descending order of this field or expression. + desc :: PersistField a => expr (Single a) -> expr OrderBy + -- | Execute a subquery in an expression. sub :: PersistField a => query (expr (Single a)) -> expr (Single a) @@ -67,6 +77,10 @@ infixr 3 &&. infixr 2 ||. +-- | Phantom type used by 'orderBy', 'asc' and 'desc'. +data OrderBy + + -- | @FROM@ clause: bring an entity into scope. -- -- The following types implement 'from': diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 8b19b25..e10a7c5 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -52,12 +52,13 @@ instance Applicative SqlQuery where -- | Side data written by 'SqlQuery'. data SideData = SideData { sdFromClause :: ![FromClause] , sdWhereClause :: !WhereClause + , sdOrderByClause :: ![OrderByClause] } instance Monoid SideData where - mempty = SideData mempty mempty - SideData f w `mappend` SideData f' w' = - SideData (f <> f') (w <> w') + mempty = SideData mempty mempty mempty + SideData f w o `mappend` SideData f' w' o' = + SideData (f <> f') (w <> w') (o <> o') -- | A part of a @FROM@ clause. @@ -75,6 +76,10 @@ instance Monoid WhereClause where Where e1 `mappend` Where e2 = Where (e1 &&. e2) +-- | A @ORDER BY@ clause. +type OrderByClause = SqlExpr OrderBy + + -- | Identifier used for tables. newtype Ident = I TLB.Builder @@ -92,8 +97,11 @@ idents _ = -- | An expression on the SQL backend. data SqlExpr a where - EEntity :: Ident -> SqlExpr (Entity val) - ERaw :: (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Single a) + EEntity :: Ident -> SqlExpr (Entity val) + ERaw :: (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Single a) + EOrderBy :: OrderByType -> SqlExpr (Single a) -> SqlExpr OrderBy + +data OrderByType = ASC | DESC type Escape = DBName -> TLB.Builder @@ -109,6 +117,10 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } + orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } + asc = EOrderBy ASC + desc = EOrderBy DESC + sub query = ERaw $ \esc -> first parens (toRawSelectSql esc query) EEntity (I ident) ^. field = ERaw $ \esc -> (ident <> ("." <> name esc field), []) @@ -200,22 +212,16 @@ getConnection = SqlPersist R.ask -- | Pretty prints a 'SqlQuery' into a SQL query. toRawSelectSql :: SqlSelect a r => Escape -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSelectSql esc query = - let (ret, SideData fromClauses whereClauses) = + let (ret, SideData fromClauses whereClauses orderByClauses) = flip S.evalSupply (idents ()) $ W.runWriterT $ unQ query - - (selectText, selectVars) = sqlSelectCols esc ret - (whereText, whereVars) = makeWhere esc whereClauses - - text = mconcat - [ "SELECT " - , selectText - , makeFrom esc fromClauses - , whereText - ] - - in (text, selectVars <> whereVars) + in mconcat + [ makeSelect esc ret + , makeFrom esc fromClauses + , makeWhere esc whereClauses + , makeOrderBy esc orderByClauses + ] uncommas :: [TLB.Builder] -> TLB.Builder @@ -225,9 +231,13 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) uncommas' = (uncommas *** mconcat) . unzip -makeFrom :: Escape -> [FromClause] -> TLB.Builder +makeSelect :: SqlSelect a r => Escape -> a -> (TLB.Builder, [PersistValue]) +makeSelect esc ret = first ("SELECT " <>) (sqlSelectCols esc ret) + + +makeFrom :: Escape -> [FromClause] -> (TLB.Builder, [PersistValue]) makeFrom _ [] = mempty -makeFrom esc fs = "\nFROM " <> uncommas (map mk fs) +makeFrom esc fs = ("\nFROM " <> uncommas (map mk fs), mempty) where mk (From (I i) def) = esc (entityDB def) <> (" AS " <> i) @@ -238,6 +248,16 @@ makeWhere esc (Where (ERaw f)) = first ("\nWHERE " <>) (f esc) makeWhere _ _ = error "Esqueleto/Sql/makeWhere: never here (see GHC #6124)" +makeOrderBy :: Escape -> [OrderByClause] -> (TLB.Builder, [PersistValue]) +makeOrderBy _ [] = mempty +makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os) + where + mk (EOrderBy t (ERaw f)) = first (<> orderByType t) (f esc) + mk _ = error "Esqueleto/Sql/makeOrderBy: never here (see GHC #6124)" + orderByType ASC = " ASC" + orderByType DESC = " DESC" + + parens :: TLB.Builder -> TLB.Builder parens b = "(" <> (b <> ")") diff --git a/test/Test.hs b/test/Test.hs index 1dd8351..c0eb6bb 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -40,9 +40,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| main :: IO () main = do - let p1 = Person "John" (Just 36) + let p1 = Person "John" (Just 36) p2 = Person "Rachel" Nothing - p3 = Person "Mike" (Just 17) + p3 = Person "Mike" (Just 17) + p4 = Person "Livia" (Just 17) hspec $ do describe "select" $ do it "works for a single value" $ @@ -162,6 +163,50 @@ main = do return p liftIO $ ret `shouldBe` [ Entity p2k p2 ] + describe "select/orderBy" $ do + it "works with a single ASC field" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + ret <- select $ + from $ \p -> do + orderBy [asc $ p ^. PersonName] + return p + liftIO $ ret `shouldBe` [ Entity p1k p1 + , Entity p3k p3 + , Entity p2k p2 ] + + it "works with two ASC fields" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + p4k <- insert p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` [ Entity p2k p2 + , Entity p4k p4 + , Entity p3k p3 + , Entity p1k p1 ] + + it "works with one ASC and one DESC field" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + p4k <- insert p4 + ret <- select $ + from $ \p -> do + orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` [ Entity p1k p1 + , Entity p4k p4 + , Entity p3k p3 + , Entity p2k p2 ] + ----------------------------------------------------------------------