{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.Relational.Monad.Aggregate (
QueryAggregate,
AggregatedQuery,
toSQL,
toSubQuery,
Window, over
) where
import Data.Functor.Identity (Identity (runIdentity))
import Data.Monoid ((<>))
import Language.SQL.Keyword (Keyword(..))
import qualified Language.SQL.Keyword as SQL
import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow)
import Database.Relational.SqlSyntax
(Duplication, Record, SubQuery, Predicate, JoinProduct,
OrderingTerm, composeOrderBy, aggregatedSubQuery,
AggregateColumnRef, AggregateElem, composePartitionBy, )
import qualified Database.Relational.SqlSyntax as Syntax
import qualified Database.Relational.Record as Record
import Database.Relational.Projectable (PlaceHolders, SqlContext)
import Database.Relational.Monad.Class (MonadRestrict(..))
import Database.Relational.Monad.Trans.Restricting
(Restrictings, restrictings, extractRestrict)
import Database.Relational.Monad.Trans.Aggregating
(extractAggregateTerms, AggregatingSetT, PartitioningSet)
import Database.Relational.Monad.Trans.Ordering
(Orderings, extractOrderingTerms)
import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig)
import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery)
type QueryAggregate = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore))
type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r
type Window c = Orderings c (PartitioningSet c)
instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where
restrict = restrictings . restrict
extract :: AggregatedQuery p r
-> ConfigureQuery (((((((PlaceHolders p, Record Aggregated r), [OrderingTerm]),
[Predicate Aggregated]),
[AggregateElem]),
[Predicate Flat]),
JoinProduct), Duplication)
extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms
toSQL :: AggregatedQuery p r
-> ConfigureQuery String
toSQL = fmap Syntax.toSQL . toSubQuery
toSubQuery :: AggregatedQuery p r
-> ConfigureQuery SubQuery
toSubQuery q = do
(((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q
c <- askConfig
return $ aggregatedSubQuery c (Record.untype pj) da pd rs ag grs ot
extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef])
extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms
over :: SqlContext c
=> Record OverWindow a
-> Window c ()
-> Record c a
wp `over` win =
Record.unsafeFromSqlTerms
[ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot)
| c <- Record.columns wp
] where (((), ot), pt) = extractWindow win
infix 8 `over`