khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2024-12-15 06:43:04 +03:00
Code Issues Projects Releases Wiki Activity

Use shared Append type to append GROUP BY.

Browse Source
This commit is contained in:
Kei Hibino 2013-08-14 01:10:34 +09:00
parent 18e144ebab
commit f8486a3434
2 changed files with 22 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -34,12 +34,15 @@ import Database.Relational.Query.Monad.Qualify (Qualify)
import Database.Relational.Query.Monad.Class (MonadQualify(..))
import Database.Relational.Query.Monad.Trans.Join (join')
import qualified Database.Relational.Query.Monad.Trans.Join as Join
import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, OrderedQuery, OrderByAppend, appendOrderBy)
import Database.Relational.Query.Monad.Trans.Ordering
(Orderings, orderings, OrderedQuery, OrderByAppend, appendOrderBy)
import qualified Database.Relational.Query.Monad.Trans.Ordering as Ordering
import Database.Relational.Query.Monad.Trans.Restrict (restrict, WhereAppend, appendWhere)
import Database.Relational.Query.Monad.Trans.Restrict
(restrict, WhereAppend, appendWhere)
import qualified Database.Relational.Query.Monad.Trans.Restrict as Restrict
import Database.Relational.Query.Monad.Core (QueryCore)
import Database.Relational.Query.Monad.Trans.Aggregate (Aggregatings, aggregate, appendGroupBys)
import Database.Relational.Query.Monad.Trans.Aggregate
(Aggregatings, aggregate, GroupBysAppend, appendGroupBys, extractGroupBys)
-- | Aggregated query monad type.
@ -57,8 +60,8 @@ instance MonadQualify Qualify (Orderings Aggregation (Aggregatings QueryCore)) w
liftQualify = aggregatedQuery
-- | Run 'AggregatedQuery' to get SQL string.
expandSQL :: AggregatedQuery r -> Qualify ((String, Projection r), ((OrderByAppend, String -> String), WhereAppend))
expandSQL q = Join.expandSQL $ assoc <$> Restrict.extractWheres (appendGroupBys (Ordering.extractOrderBys q)) where
expandSQL :: AggregatedQuery r -> Qualify ((String, Projection r), ((OrderByAppend, GroupBysAppend), WhereAppend))
expandSQL q = Join.expandSQL $ assoc <$> Restrict.extractWheres (extractGroupBys (Ordering.extractOrderBys q)) where
assoc (((a, b), c), d) = (Aggregation.unsafeProjection a, ((b, c), d))
-- | Run 'AggregatedQuery' to get SQL with 'Qualify' computation.
@ -66,11 +69,11 @@ toSQL :: AggregatedQuery r -- ^ 'AggregatedQuery' to run
-> Qualify String -- ^ Result SQL string with 'Qualify' computation
toSQL q = do
((sql, _pj), ((appOrd, appGrp), appWhere)) <- expandSQL q
return . appendOrderBy appOrd . appGrp . appendWhere appWhere $ sql
return . appendOrderBy appOrd . appendGroupBys appGrp . appendWhere appWhere $ sql
-- | Run 'AggregatedQuery' to get 'SubQuery' with 'Qualify' computation.
toSubQuery :: AggregatedQuery r -- ^ 'AggregatedQuery' to run
-> Qualify SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation
toSubQuery q = do
((sql, pj), ((appOrd, appGrp), appWhere)) <- expandSQL q
return $ subQuery (appendOrderBy appOrd . appGrp . appendWhere appWhere $ sql) (Projection.width pj)
return $ subQuery (appendOrderBy appOrd . appendGroupBys appGrp . appendWhere appWhere $ sql) (Projection.width pj)

23
relational-join/src/Database/Relational/Query/Monad/Trans/Aggregate.hs
View File

@ -16,7 +16,7 @@ module Database.Relational.Query.Monad.Trans.Aggregate (
Aggregatings, aggregate,
-- * Result group by SQLs
appendGroupBys
GroupBysAppend, extractGroupBys, appendGroupBys
) where
import Control.Monad.Trans.Class (MonadTrans (lift))
@ -30,6 +30,8 @@ import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Aggregation (Aggregation)
import qualified Database.Relational.Query.Aggregation as Aggregation
import Database.Relational.Query.Monad.Trans.StateAppend (Append, append)
import qualified Database.Relational.Query.Monad.Trans.StateAppend as Append
import Database.Relational.Query.Monad.Trans.AggregateState
(AggregatingContext, primeAggregatingContext, addGroupBy, composeGroupBys)
import qualified Database.Relational.Query.Monad.Trans.AggregateState as State
@ -95,14 +97,13 @@ instance MonadQuery m => MonadAggregate (Aggregatings m) where
restrictAggregatedQuery = addRestriction
-- | Get group-by appending function from 'AggregatingContext'.
appendGroupBys' :: AggregatingContext -> String -> String
appendGroupBys' c = (++ d (composeGroupBys c)) where
d "" = ""
d s = ' ' : s
type GroupBysAppend = Append AggregatingContext
-- | Run 'Aggregatings' to get query result and group-by appending function.
appendGroupBys :: MonadQuery m
=> Aggregatings m a -- ^ 'Aggregatings' to run
-> m (a, String -> String) -- ^ Query result and group-by appending function.
appendGroupBys q = second appendGroupBys' <$> runAggregatingPrime q
-- | Run 'Aggregatings' to get GROUP BY terms appending function.
extractGroupBys :: MonadQuery m
=> Aggregatings m a -- ^ 'Aggregatings' to run
-> m (a, GroupBysAppend) -- ^ GROUP BY terms appending function.
extractGroupBys q = second (Append.liftToString composeGroupBys) <$> runAggregatingPrime q
appendGroupBys :: GroupBysAppend -> String -> String
appendGroupBys = append