module Database.Relational.Query.Monad.Trans.Aggregating (
Aggregatings, aggregatings,
AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT,
extractAggregateTerms,
AggregateKey,
groupBy',
AggregatingSet, AggregatingPowerSet, AggregatingSetList, PartitioningSet,
key, key', set,
bkey, rollup, cube, groupingSets
) where
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Control.Applicative (Applicative, pure, (<$>))
import Control.Arrow (second)
import Data.DList (DList, toList)
import Data.Functor.Identity (Identity (runIdentity))
import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList)
import Database.Relational.Query.Component
(AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet,
AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets)
import Database.Relational.Query.Projection (Projection)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Monad.Class
(MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..))
newtype Aggregatings ac at m a =
Aggregatings (WriterT (DList at) m a)
deriving (MonadTrans, Monad, Functor, Applicative)
aggregatings :: Monad m => m a -> Aggregatings ac at m a
aggregatings = lift
type AggregatingSetT = Aggregatings Set AggregateElem
type AggregatingSetListT = Aggregatings SetList AggregateSet
type AggregatingPowerSetT = Aggregatings Power AggregateBitKey
type PartitioningSetT c = Aggregatings c AggregateColumnRef
instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where
restrictContext = aggregatings . restrictContext
instance MonadQuery m => MonadQuery (AggregatingSetT m) where
setDuplication = aggregatings . setDuplication
restrictJoin = aggregatings . restrictJoin
unsafeSubQuery na = aggregatings . unsafeSubQuery na
unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m ()
unsafeAggregateWithTerm = Aggregatings . tell . pure
instance MonadQuery m => MonadAggregate (AggregatingSetT m) where
unsafeAddAggregateElement = unsafeAggregateWithTerm
instance Monad m => MonadPartition (PartitioningSetT c m) where
unsafeAddPartitionKey = unsafeAggregateWithTerm
extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at])
extractAggregateTerms (Aggregatings ac) = second toList <$> runWriterT ac
newtype AggregateKey a = AggregateKey (a, AggregateElem)
groupBy' :: MonadAggregate m
=> AggregateKey a
-> m a
groupBy' (AggregateKey (p, c)) = do
unsafeAddAggregateElement c
return p
extractTermList :: Aggregatings ac at Identity a -> (a, [at])
extractTermList = runIdentity . extractAggregateTerms
type AggregatingSet = AggregatingSetT Identity
type AggregatingPowerSet = AggregatingPowerSetT Identity
type AggregatingSetList = AggregatingSetListT Identity
type PartitioningSet c = PartitioningSetT c Identity
key :: Projection Flat r
-> AggregatingSet (Projection Aggregated (Maybe r))
key p = do
mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p]
return . Projection.just $ Projection.unsafeToAggregated p
key' :: AggregateKey a
-> AggregatingSet a
key' (AggregateKey (p, c)) = do
unsafeAggregateWithTerm c
return p
set :: AggregatingSet a
-> AggregatingSetList a
set s = do
let (p, c) = second aggregateGroupingSet . extractTermList $ s
unsafeAggregateWithTerm c
return p
bkey :: Projection Flat r
-> AggregatingPowerSet (Projection Aggregated (Maybe r))
bkey p = do
unsafeAggregateWithTerm . aggregatePowerKey $ Projection.columns p
return . Projection.just $ Projection.unsafeToAggregated p
finalizePower :: ([AggregateBitKey] -> AggregateElem)
-> AggregatingPowerSet a -> AggregateKey a
finalizePower finalize pow = AggregateKey . second finalize . extractTermList $ pow
rollup :: AggregatingPowerSet a -> AggregateKey a
rollup = finalizePower aggregateRollup
cube :: AggregatingPowerSet a -> AggregateKey a
cube = finalizePower aggregateCube
groupingSets :: AggregatingSetList a -> AggregateKey a
groupingSets = AggregateKey . second aggregateSets . extractTermList