Add aggregate implementations.

relational-join/relational-join.cabal

@@ -23,6 +23,7 @@ library
                        Database.Relational.Query.Pi.Unsafe
                        Database.Relational.Query.Constraint
                        Database.Relational.Query.Projection
+                       Database.Relational.Query.Aggregation
                        Database.Relational.Query.Projectable
                        Database.Relational.Query.ProjectableExtended
                        Database.Relational.Query.Expr
@@ -32,6 +33,7 @@ library
                        Database.Relational.Query.Monad.Ordering
                        Database.Relational.Query.Monad.Core
                        Database.Relational.Query.Monad.Simple
+                       Database.Relational.Query.Monad.Aggregate
                        Database.Relational.Query.Relation
                        Database.Relational.Query.Type
                        Database.Relational.Query.Derives
@@ -49,6 +51,7 @@ library
                        Database.Relational.Query.Internal.ShowS
                        Database.Relational.Query.Internal.Product
                        Database.Relational.Query.Internal.Context
+                       Database.Relational.Query.Internal.AggregatingContext
                        Database.Relational.Query.Monad.Unsafe
 
                        Database.Relational.Schema.DB2Syscat.Tabconst

relational-join/src/Database/Relational/Query.hs

@@ -8,12 +8,14 @@ module Database.Relational.Query (
   module Database.Relational.Query.Expr,
   module Database.Relational.Query.Sub,
   module Database.Relational.Query.Projection,
+  module Database.Relational.Query.Aggregation,
   module Database.Relational.Query.Projectable,
   module Database.Relational.Query.ProjectableExtended,
   module Database.Relational.Query.Monad.Class,
   module Database.Relational.Query.Monad.Ordering,
   module Database.Relational.Query.Monad.Core,
   module Database.Relational.Query.Monad.Simple,
+  module Database.Relational.Query.Monad.Aggregate,
   module Database.Relational.Query.Relation,
   module Database.Relational.Query.Type,
   module Database.Relational.Query.Derives
@@ -30,12 +32,14 @@ import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Expr hiding (flattenMaybe, just)
 import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)
 import Database.Relational.Query.Projection (Projection)
+import Database.Relational.Query.Aggregation (Aggregation)
 import Database.Relational.Query.Projectable
 import Database.Relational.Query.ProjectableExtended
-import Database.Relational.Query.Monad.Class (on, wheres)
+import Database.Relational.Query.Monad.Class (on, wheres, groupBy, having)
 import Database.Relational.Query.Monad.Ordering (asc, desc)
 import Database.Relational.Query.Monad.Core (QueryCore, expr)
-import Database.Relational.Query.Monad.Simple (QuerySimple)
+import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
+import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery)
 import Database.Relational.Query.Relation
 import Database.Relational.Query.Type
   (Query, untypeQuery, fromRelation,

relational-join/src/Database/Relational/Query/Internal/AggregatingContext.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.Relational.Query.Internal.AggregatingContext (
+  AggregatingContext,
+
+  primeAggregatingContext,
+
+  addGroupBy, addRestriction,
+
+  composeGroupBys
+  ) where
+
+import Data.DList (DList)
+import qualified Data.DList as DList
+import Data.Monoid ((<>))
+import Control.Applicative (pure)
+
+import Database.Relational.Query.Expr (Expr, showExpr)
+import qualified Database.Relational.Query.Projectable as Projectable
+
+import Language.SQL.Keyword (Keyword(..), unwordsSQL)
+import qualified Language.SQL.Keyword as SQL
+import qualified Language.SQL.Keyword.ConcatString as SQLs
+
+type GroupByTerm = String
+type GroupBys = DList GroupByTerm
+
+data AggregatingContext =
+  AggregatingContext
+  { groupByTerms :: GroupBys
+  , restriction  :: Maybe (Expr Bool)
+  }
+
+primeAggregatingContext :: AggregatingContext
+primeAggregatingContext =  AggregatingContext DList.empty Nothing
+
+addGroupBy :: String -> AggregatingContext -> AggregatingContext
+addGroupBy t c =  c { groupByTerms = groupByTerms c <> pure t }
+
+addRestriction :: Expr Bool -> AggregatingContext -> AggregatingContext
+addRestriction e1 ctx =
+  ctx { restriction = Just . uf . restriction $ ctx }
+  where uf  Nothing = e1
+        uf (Just e0) = e0 `Projectable.and` e1
+
+composeGroupBys :: AggregatingContext -> String
+composeGroupBys ac = unwords [unwordsSQL groupBys, unwordsSQL havings]
+  where groupBys
+          | null gs   = []
+          | otherwise = [GROUP, BY, SQL.word . concat $ gs `SQLs.sepBy` ", "]
+        gs = DList.toList (groupByTerms ac)
+        havings = maybe [] (\e -> [HAVING, SQL.word . showExpr $ e]) $ restriction ac

relational-join/src/Database/Relational/Query/Monad/Aggregate.hs

@@ -0,0 +1,116 @@
+module Database.Relational.Query.Monad.Aggregate (
+  aggregate,
+
+  appendGroupBys,
+
+  QueryAggregate,
+  AggregatedQuery,
+
+  toSQL,
+
+  toSubQuery
+  ) where
+
+import Control.Monad (liftM, ap)
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (StateT, runStateT, modify)
+import Control.Applicative (Applicative (pure, (<*>)), (<$>))
+import Control.Arrow (second)
+
+import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable (projectAggregation)
+import Database.Relational.Query.Aggregation (Aggregation)
+import qualified Database.Relational.Query.Aggregation as Aggregation
+import Database.Relational.Query.Sub (SubQuery, subQuery)
+
+import Database.Relational.Query.Internal.AggregatingContext (AggregatingContext, primeAggregatingContext)
+import qualified Database.Relational.Query.Internal.AggregatingContext as Context
+
+import Database.Relational.Query.Monad.Unsafe (UnsafeMonadQuery(unsafeSubQuery))
+import Database.Relational.Query.Monad.Class (MonadQuery, MonadAggregate)
+import qualified Database.Relational.Query.Monad.Class as MonadQuery
+import Database.Relational.Query.Monad.Ordering (Orderings, OrderedQuery)
+import qualified Database.Relational.Query.Monad.Ordering as Ordering
+import Database.Relational.Query.Monad.Core (QueryCore)
+import qualified Database.Relational.Query.Monad.Core as Core
+
+newtype Aggregatings m a =
+  Aggregatings { aggregatingState :: StateT AggregatingContext m a }
+
+runAggregating :: Aggregatings m a -> AggregatingContext -> m (a, AggregatingContext)
+runAggregating =  runStateT . aggregatingState
+
+runAggregatingPrime :: Aggregatings m a -> m (a, AggregatingContext)
+runAggregatingPrime =  (`runAggregating` primeAggregatingContext)
+
+instance MonadTrans Aggregatings where
+  lift = Aggregatings . lift
+
+aggregate :: Monad m => m a -> Aggregatings m a
+aggregate =  lift
+
+instance Monad m => Monad (Aggregatings m) where
+  return     = Aggregatings . return
+  q0 >>= f   = Aggregatings $ aggregatingState q0 >>= aggregatingState . f
+
+instance Monad m => Functor (Aggregatings m) where
+  fmap = liftM
+
+instance Monad m => Applicative (Aggregatings m) where
+  pure  = return
+  (<*>) = ap
+
+instance UnsafeMonadQuery m => UnsafeMonadQuery (Aggregatings m) where
+  unsafeSubQuery na = aggregate . unsafeSubQuery na
+
+instance MonadQuery m => MonadQuery (Aggregatings m) where
+  on     =  aggregate . MonadQuery.on
+  wheres =  aggregate . MonadQuery.wheres
+
+updateAggregatingContext :: Monad m => (AggregatingContext -> AggregatingContext) -> Aggregatings m ()
+updateAggregatingContext =  Aggregatings . modify
+
+addGroupBys' :: Monad m => [String] -> Aggregatings m ()
+addGroupBys' gbs = updateAggregatingContext (\c -> foldl (flip Context.addGroupBy) c gbs)
+
+addRestriction' :: Monad m => Expr Bool -> Aggregatings m ()
+addRestriction' =  updateAggregatingContext . Context.addRestriction
+
+addGroupBys :: MonadQuery m => Projection r -> Aggregatings m (Aggregation r)
+addGroupBys p = do
+  addGroupBys' . Projection.columns $ p
+  return $ Aggregation.unsafeFromProjection p
+
+addRestriction :: MonadQuery m => Aggregation Bool -> Aggregatings m ()
+addRestriction =  addRestriction' . projectAggregation
+
+instance MonadQuery m => MonadAggregate (Aggregatings m) where
+  groupBy = addGroupBys
+  having  = addRestriction
+
+
+appendGroupBys' :: AggregatingContext -> String -> String
+appendGroupBys' c = (++ d (Context.composeGroupBys c))  where
+  d "" = ""
+  d s  = ' ' : s
+
+appendGroupBys :: MonadQuery m => Aggregatings m a -> m (a, String -> String)
+appendGroupBys q = second appendGroupBys' `liftM` runAggregatingPrime q
+
+
+type QueryAggregate    = Orderings Aggregation (Aggregatings QueryCore)
+type AggregatedQuery r = OrderedQuery Aggregation (Aggregatings QueryCore) r
+
+expandSQL :: AggregatedQuery r -> ((String, Projection r), (String -> String, String -> String))
+expandSQL q = Core.expandSQL $ assoc <$> appendGroupBys (Ordering.appendOrderBys q)  where
+  assoc ((a, b), c) = (Aggregation.projection a, (b, c))
+
+toSQL :: AggregatedQuery r -> String
+toSQL q =  appOrd $ appGrp sql  where
+  ((sql, _pj), (appOrd, appGrp)) = expandSQL q
+
+toSubQuery :: AggregatedQuery r -> SubQuery
+toSubQuery q = subQuery (appOrd $ appGrp sql) (Projection.width pj)  where
+  ((sql, pj), (appOrd, appGrp))  = expandSQL q