Merge pull request #7 from db81/groupby

GROUP BY support.

src/Database/Esqueleto.hs

@@ -18,7 +18,7 @@ module Database.Esqueleto
     -- $gettingstarted
 
     -- * @esqueleto@'s Language
-    Esqueleto( where_, on, orderBy, asc, desc, limit, offset
+    Esqueleto( where_, on, groupBy, orderBy, asc, desc, limit, offset
              , sub_select, sub_selectDistinct, (^.), (?.)
              , val, isNothing, just, nothing, countRows, not_
              , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)

src/Database/Esqueleto/Internal/Language.hs

@@ -6,6 +6,7 @@
            , MultiParamTypeClasses
            , TypeFamilies
            , UndecidableInstances
+           , GADTs
  #-}
 -- | This is an internal module, anything exported by this module
 -- may change without a major version bump.  Please use only
@@ -15,6 +16,8 @@ module Database.Esqueleto.Internal.Language
     Esqueleto(..)
   , from
   , Value(..)
+  , SomeValue(..)
+  , ToSomeValues(..)
   , InnerJoin(..)
   , CrossJoin(..)
   , LeftOuterJoin(..)
@@ -128,6 +131,33 @@ class (Functor query, Applicative query, Monad query) =>
   -- 'LeftOuterJoin'.
   on :: expr (Value Bool) -> query ()
 
+  -- | @GROUP BY@ clause. You can enclose multiple columns
+  -- in a tuple.
+  --
+  -- @
+  -- select $ from \\(foo ``InnerJoin`` bar) -> do
+  --   on (foo ^. FooBarId ==. bar ^. BarId)
+  --   groupBy (bar ^. BarId, bar ^. BarName)
+  --   return (bar ^. BarId, bar ^. BarName, countRows)
+  -- @
+  --
+  -- With groupBy you can sort by aggregate functions, like so (we
+  -- used @let@ to restrict the more general `countRows` to
+  -- @SqlExpr (Value Int)@ to avoid ambiguity):
+  --
+  -- @
+  -- r \<- select $ from \\(foo ``InnerJoin`` bar) -> do
+  --   on (foo ^. FooBarId ==. bar ^. BarId)
+  --   groupBy $ bar ^. BarName
+  --   let countRows' = countRows
+  --   orderBy [asc countRows']
+  --   return (bar ^. BarName, countRows')
+  -- forM_ r $ \\((Value name), (Value count)) -> do
+  --   print name
+  --   print (count :: Int)
+  -- @
+  groupBy :: (ToSomeValues expr a) => a -> query ()
+
   -- | @ORDER BY@ clause. See also 'asc' and 'desc'.
   orderBy :: [expr OrderBy] -> query ()
 
@@ -238,6 +268,80 @@ data Value a = Value a deriving (Eq, Ord, Show, Typeable)
 -- Note: because of GHC bug #6124 we use @data@ instead of @newtype@.
 
 
+-- | A wrapper type for for any @expr (Value a)@ for all a.
+data SomeValue expr where
+  SomeValue :: Esqueleto query expr backend => expr (Value a) -> SomeValue expr
+
+-- | A class of things that can be converted into a list of SomeValue. It has
+-- instances for tuples and is the reason why groupBy can take tuples, like
+-- @groupBy (foo ^. FooId, foo ^. FooName, foo ^. FooType)@.
+class ToSomeValues expr a where
+  toSomeValues :: a -> [SomeValue expr]
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         ) => ToSomeValues expr (a, b) where
+  toSomeValues (a,b) = toSomeValues a ++ toSomeValues b
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         ) => ToSomeValues expr (a, b, c) where
+  toSomeValues (a,b,c) = toSomeValues a ++ toSomeValues b ++ toSomeValues c
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         , ToSomeValues expr d
+         ) => ToSomeValues expr (a, b, c, d) where
+  toSomeValues (a,b,c,d) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++
+    toSomeValues d
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         , ToSomeValues expr d
+         , ToSomeValues expr e
+         ) => ToSomeValues expr (a, b, c, d, e) where
+  toSomeValues (a,b,c,d,e) = toSomeValues a ++ toSomeValues b ++
+    toSomeValues c ++ toSomeValues d ++ toSomeValues e
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         , ToSomeValues expr d
+         , ToSomeValues expr e
+         , ToSomeValues expr f
+         ) => ToSomeValues expr (a, b, c, d, e, f) where
+  toSomeValues (a,b,c,d,e,f) = toSomeValues a ++ toSomeValues b ++
+    toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         , ToSomeValues expr d
+         , ToSomeValues expr e
+         , ToSomeValues expr f
+         , ToSomeValues expr g
+         ) => ToSomeValues expr (a, b, c, d, e, f, g) where
+  toSomeValues (a,b,c,d,e,f,g) = toSomeValues a ++ toSomeValues b ++
+    toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++
+    toSomeValues g
+
+instance ( ToSomeValues expr a
+         , ToSomeValues expr b
+         , ToSomeValues expr c
+         , ToSomeValues expr d
+         , ToSomeValues expr e
+         , ToSomeValues expr f
+         , ToSomeValues expr g
+         , ToSomeValues expr h
+         ) => ToSomeValues expr (a, b, c, d, e, f, g, h) where
+  toSomeValues (a,b,c,d,e,f,g,h) = toSomeValues a ++ toSomeValues b ++
+    toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++
+    toSomeValues g ++ toSomeValues h
+
+
 -- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example).
 data InnerJoin a b = a `InnerJoin` b
 

src/Database/Esqueleto/Internal/Sql.hs

@@ -93,14 +93,15 @@ type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlPersist)
 data SideData = SideData { sdFromClause    :: ![FromClause]
                          , sdSetClause     :: ![SetClause]
                          , sdWhereClause   :: !WhereClause
+                         , sdGroupByClause :: !GroupByClause
                          , sdOrderByClause :: ![OrderByClause]
                          , sdLimitClause   :: !LimitClause
                          }
 
 instance Monoid SideData where
-  mempty = SideData mempty mempty mempty mempty mempty
+  mempty = SideData mempty mempty mempty mempty mempty mempty
-  SideData f s w o l `mappend` SideData f' s' w' o' l' =
+  SideData f s w o l g `mappend` SideData f' s' w' o' l' g' =
-    SideData (f <> f') (s <> s') (w <> w') (o <> o') (l <> l')
+    SideData (f <> f') (s <> s') (w <> w') (o <> o') (l <> l') (g <> g')
 
 
 -- | A part of a @FROM@ clause.
@@ -153,6 +154,14 @@ instance Monoid WhereClause where
   Where e1 `mappend` Where e2 = Where (e1 &&. e2)
 
 
+-- | A @GROUP BY@ clause.
+newtype GroupByClause = GroupBy [SomeValue SqlExpr]
+
+instance Monoid GroupByClause where
+  mempty = GroupBy []
+  GroupBy fs `mappend` GroupBy fs' = GroupBy (fs <> fs')
+
+
 -- | A @ORDER BY@ clause.
 type OrderByClause = SqlExpr OrderBy
 
@@ -267,6 +276,8 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
 
   on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }
 
+  groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr }
+
   orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }
   asc  = EOrderBy ASC
   desc = EOrderBy DESC
@@ -324,6 +335,10 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where
   field /=. expr = setAux field (\ent -> ent ^. field /. expr)
 
 
+instance ToSomeValues SqlExpr (SqlExpr (Value a)) where
+  toSomeValues a = [SomeValue a]
+
+
 fieldName :: (PersistEntity val, PersistField typ)
           => Connection -> EntityField val typ -> TLB.Builder
 fieldName conn = fromDBName conn . fieldDB . persistFieldDef
@@ -616,7 +631,7 @@ builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize
 -- @persistent@.
 toRawSql :: SqlSelect a r => Mode -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue])
 toRawSql mode conn query =
-  let (ret, SideData fromClauses setClauses whereClauses orderByClauses limitClause) =
+  let (ret, SideData fromClauses setClauses whereClauses groupByClause orderByClauses limitClause) =
         flip S.evalState initialIdentState $
         W.runWriterT $
         unQ query
@@ -625,6 +640,7 @@ toRawSql mode conn query =
       , makeFrom    conn mode fromClauses
       , makeSet     conn setClauses
       , makeWhere   conn whereClauses
+      , makeGroupBy conn groupByClause
       , makeOrderBy conn orderByClauses
       , makeLimit   conn limitClause
       ]
@@ -703,6 +719,13 @@ makeWhere _    NoWhere            = mempty
 makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn)
 
 
+makeGroupBy :: Connection -> GroupByClause -> (TLB.Builder, [PersistValue])
+makeGroupBy _ (GroupBy []) = (mempty, [])
+makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build
+  where
+    build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f conn) fields
+
+
 makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue])
 makeOrderBy _    [] = mempty
 makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os)