orderBy, asc, desc.

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

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':

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 <> ")")
 

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 ]
+
 
 ----------------------------------------------------------------------