{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.Relational.Monad.Trans.Aggregating
-- Copyright   : 2013-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines monad transformer which lift
-- from 'MonadQuery' into Aggregated query.
module Database.Relational.Monad.Trans.Aggregating
       ( -- * Transformer into aggregated query
         Aggregatings, aggregatings,

         AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT,

         -- * Result
         extractAggregateTerms,

         -- * Grouping sets support
         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.Internal.ContextType
  (Flat, Aggregated, Set, Power, SetList)
import Database.Relational.SqlSyntax
  (Record, untypeRecord,
   AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet,
   AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets,
   AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey)

import qualified Database.Relational.Record as Record
import Database.Relational.Monad.Class
  (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..))


-- | Type to accumulate aggregating context.
--   Type 'ac' is aggregating-context type like aggregating key set building,
--   aggregating key sets set building and partition key set building.
--   Type 'at' is aggregating term type.
newtype Aggregatings ac at m a =
  Aggregatings (WriterT (DList at) m a)
  deriving (forall ac at (m :: * -> *) a.
Monad m =>
m a -> Aggregatings ac at m a
forall (m :: * -> *) a. Monad m => m a -> Aggregatings ac at m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> Aggregatings ac at m a
$clift :: forall ac at (m :: * -> *) a.
Monad m =>
m a -> Aggregatings ac at m a
MonadTrans, forall a. a -> Aggregatings ac at m a
forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
forall a b.
Aggregatings ac at m a
-> (a -> Aggregatings ac at m b) -> Aggregatings ac at m b
forall {ac} {at} {m :: * -> *}.
Monad m =>
Applicative (Aggregatings ac at m)
forall ac at (m :: * -> *) a.
Monad m =>
a -> Aggregatings ac at m a
forall ac at (m :: * -> *) a b.
Monad m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
forall ac at (m :: * -> *) a b.
Monad m =>
Aggregatings ac at m a
-> (a -> Aggregatings ac at m b) -> Aggregatings ac at m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Aggregatings ac at m a
$creturn :: forall ac at (m :: * -> *) a.
Monad m =>
a -> Aggregatings ac at m a
>> :: forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
$c>> :: forall ac at (m :: * -> *) a b.
Monad m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
>>= :: forall a b.
Aggregatings ac at m a
-> (a -> Aggregatings ac at m b) -> Aggregatings ac at m b
$c>>= :: forall ac at (m :: * -> *) a b.
Monad m =>
Aggregatings ac at m a
-> (a -> Aggregatings ac at m b) -> Aggregatings ac at m b
Monad, forall a b. a -> Aggregatings ac at m b -> Aggregatings ac at m a
forall a b.
(a -> b) -> Aggregatings ac at m a -> Aggregatings ac at m b
forall ac at (m :: * -> *) a b.
Functor m =>
a -> Aggregatings ac at m b -> Aggregatings ac at m a
forall ac at (m :: * -> *) a b.
Functor m =>
(a -> b) -> Aggregatings ac at m a -> Aggregatings ac at m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Aggregatings ac at m b -> Aggregatings ac at m a
$c<$ :: forall ac at (m :: * -> *) a b.
Functor m =>
a -> Aggregatings ac at m b -> Aggregatings ac at m a
fmap :: forall a b.
(a -> b) -> Aggregatings ac at m a -> Aggregatings ac at m b
$cfmap :: forall ac at (m :: * -> *) a b.
Functor m =>
(a -> b) -> Aggregatings ac at m a -> Aggregatings ac at m b
Functor, forall a. a -> Aggregatings ac at m a
forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m a
forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
forall a b.
Aggregatings ac at m (a -> b)
-> Aggregatings ac at m a -> Aggregatings ac at m b
forall a b c.
(a -> b -> c)
-> Aggregatings ac at m a
-> Aggregatings ac at m b
-> Aggregatings ac at m c
forall {ac} {at} {m :: * -> *}.
Applicative m =>
Functor (Aggregatings ac at m)
forall ac at (m :: * -> *) a.
Applicative m =>
a -> Aggregatings ac at m a
forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m a
forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m (a -> b)
-> Aggregatings ac at m a -> Aggregatings ac at m b
forall ac at (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Aggregatings ac at m a
-> Aggregatings ac at m b
-> Aggregatings ac at m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m a
$c<* :: forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m a
*> :: forall a b.
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
$c*> :: forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m a
-> Aggregatings ac at m b -> Aggregatings ac at m b
liftA2 :: forall a b c.
(a -> b -> c)
-> Aggregatings ac at m a
-> Aggregatings ac at m b
-> Aggregatings ac at m c
$cliftA2 :: forall ac at (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Aggregatings ac at m a
-> Aggregatings ac at m b
-> Aggregatings ac at m c
<*> :: forall a b.
Aggregatings ac at m (a -> b)
-> Aggregatings ac at m a -> Aggregatings ac at m b
$c<*> :: forall ac at (m :: * -> *) a b.
Applicative m =>
Aggregatings ac at m (a -> b)
-> Aggregatings ac at m a -> Aggregatings ac at m b
pure :: forall a. a -> Aggregatings ac at m a
$cpure :: forall ac at (m :: * -> *) a.
Applicative m =>
a -> Aggregatings ac at m a
Applicative)

-- | Lift to 'Aggregatings'.
aggregatings :: Monad m => m a -> Aggregatings ac at m a
aggregatings :: forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings =  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Context type building one grouping set.
type AggregatingSetT      = Aggregatings Set       AggregateElem

-- | Context type building grouping sets list.
type AggregatingSetListT  = Aggregatings SetList   AggregateSet

-- | Context type building power group set.
type AggregatingPowerSetT = Aggregatings Power     AggregateBitKey

-- | Context type building partition keys set.
type PartitioningSetT c   = Aggregatings c         AggregateColumnRef

-- | Aggregated 'MonadRestrict'.
instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where
  restrict :: Predicate c -> AggregatingSetT m ()
restrict =  forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (m :: * -> *). MonadRestrict c m => Predicate c -> m ()
restrict

-- | Aggregated 'MonadQualify'.
instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where
  liftQualify :: forall a. q a -> AggregatingSetT m a
liftQualify = forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify

-- | Aggregated 'MonadQuery'.
instance MonadQuery m => MonadQuery (AggregatingSetT m) where
  setDuplication :: Duplication -> AggregatingSetT m ()
setDuplication     = forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadQuery m => Duplication -> m ()
setDuplication
  restrictJoin :: Predicate Flat -> AggregatingSetT m ()
restrictJoin       = forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadQuery m => Predicate Flat -> m ()
restrictJoin
  query' :: forall p r.
Relation p r -> AggregatingSetT m (PlaceHolders p, Record Flat r)
query'             = forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query'
  queryMaybe' :: forall p r.
Relation p r
-> AggregatingSetT m (PlaceHolders p, Record Flat (Maybe r))
queryMaybe'        = forall (m :: * -> *) a ac at.
Monad m =>
m a -> Aggregatings ac at m a
aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat (Maybe r))
queryMaybe'

unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m ()
unsafeAggregateWithTerm :: forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm =  forall ac at (m :: * -> *) a.
WriterT (DList at) m a -> Aggregatings ac at m a
Aggregatings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a
aggregateKey :: forall (m :: * -> *) a ac.
Monad m =>
AggregateKey a -> Aggregatings ac AggregateElem m a
aggregateKey AggregateKey a
k = do
  forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm forall a b. (a -> b) -> a -> b
$ forall a. AggregateKey a -> AggregateElem
aggregateKeyElement AggregateKey a
k
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. AggregateKey a -> a
aggregateKeyRecord AggregateKey a
k

-- | Aggregated query instance.
instance MonadQuery m => MonadAggregate (AggregatingSetT m) where
  groupBy :: forall r. Record Flat r -> AggregatingSetT m (Record Aggregated r)
groupBy Record Flat r
p = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm [ AggregateColumnRef -> AggregateElem
aggregateColumnRef AggregateColumnRef
col | AggregateColumnRef
col <- forall c t. Record c t -> Tuple
untypeRecord Record Flat r
p]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r. Record Flat r -> Record Aggregated r
Record.unsafeToAggregated Record Flat r
p
  groupBy' :: forall r.
AggregateKey (Record Aggregated r)
-> AggregatingSetT m (Record Aggregated r)
groupBy'  = forall (m :: * -> *) a ac.
Monad m =>
AggregateKey a -> Aggregatings ac AggregateElem m a
aggregateKey

-- | Partition clause instance
instance Monad m => MonadPartition c (PartitioningSetT c m) where
  partitionBy :: forall r. Record c r -> PartitioningSetT c m ()
partitionBy =  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c t. Record c t -> Tuple
untypeRecord

-- | Run 'Aggregatings' to get terms list.
extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at])
extractAggregateTerms :: forall (m :: * -> *) ac at a.
(Monad m, Functor m) =>
Aggregatings ac at m a -> m (a, [at])
extractAggregateTerms (Aggregatings WriterT (DList at) m a
ac) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. DList a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (DList at) m a
ac

extractTermList :: Aggregatings ac at Identity a -> (a, [at])
extractTermList :: forall ac at a. Aggregatings ac at Identity a -> (a, [at])
extractTermList =  forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) ac at a.
(Monad m, Functor m) =>
Aggregatings ac at m a -> m (a, [at])
extractAggregateTerms

-- | Context monad type to build single grouping set.
type AggregatingSet      = AggregatingSetT      Identity

-- | Context monad type to build grouping power set.
type AggregatingPowerSet = AggregatingPowerSetT Identity

-- | Context monad type to build grouping set list.
type AggregatingSetList  = AggregatingSetListT  Identity

-- | Context monad type to build partition keys set.
type PartitioningSet c   = PartitioningSetT c   Identity

-- | Specify key of single grouping set from Record.
key :: Record Flat r
    -> AggregatingSet (Record Aggregated (Maybe r))
key :: forall r.
Record Flat r -> AggregatingSet (Record Aggregated (Maybe r))
key Record Flat r
p = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm [ AggregateColumnRef -> AggregateElem
aggregateColumnRef AggregateColumnRef
col | AggregateColumnRef
col <- forall c t. Record c t -> Tuple
untypeRecord Record Flat r
p]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c r. Record c r -> Record c (Maybe r)
Record.just forall a b. (a -> b) -> a -> b
$ forall r. Record Flat r -> Record Aggregated r
Record.unsafeToAggregated Record Flat r
p

-- | Specify key of single grouping set.
key' :: AggregateKey a
     -> AggregatingSet a
key' :: forall a. AggregateKey a -> AggregatingSet a
key' = forall (m :: * -> *) a ac.
Monad m =>
AggregateKey a -> Aggregatings ac AggregateElem m a
aggregateKey

-- | Finalize and specify single grouping set.
set :: AggregatingSet a
    -> AggregatingSetList a
set :: forall a. AggregatingSet a -> AggregatingSetList a
set AggregatingSet a
s = do
  let (a
p, AggregateSet
c) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [AggregateElem] -> AggregateSet
aggregateGroupingSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ac at a. Aggregatings ac at Identity a -> (a, [at])
extractTermList forall a b. (a -> b) -> a -> b
$ AggregatingSet a
s
  forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm AggregateSet
c
  forall (m :: * -> *) a. Monad m => a -> m a
return a
p

-- | Specify key of rollup and cube power set.
bkey :: Record Flat r
     -> AggregatingPowerSet (Record Aggregated (Maybe r))
bkey :: forall r.
Record Flat r -> AggregatingPowerSet (Record Aggregated (Maybe r))
bkey Record Flat r
p = do
  forall (m :: * -> *) at ac.
Monad m =>
at -> Aggregatings ac at m ()
unsafeAggregateWithTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tuple -> AggregateBitKey
aggregatePowerKey forall a b. (a -> b) -> a -> b
$ forall c t. Record c t -> Tuple
untypeRecord Record Flat r
p
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c r. Record c r -> Record c (Maybe r)
Record.just forall a b. (a -> b) -> a -> b
$ forall r. Record Flat r -> Record Aggregated r
Record.unsafeToAggregated Record Flat r
p

finalizePower :: ([AggregateBitKey] -> AggregateElem)
              -> AggregatingPowerSet a -> AggregateKey a
finalizePower :: forall a.
([AggregateBitKey] -> AggregateElem)
-> AggregatingPowerSet a -> AggregateKey a
finalizePower [AggregateBitKey] -> AggregateElem
finalize AggregatingPowerSet a
pow = forall a. (a, AggregateElem) -> AggregateKey a
unsafeAggregateKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [AggregateBitKey] -> AggregateElem
finalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ac at a. Aggregatings ac at Identity a -> (a, [at])
extractTermList forall a b. (a -> b) -> a -> b
$ AggregatingPowerSet a
pow

-- | Finalize grouping power set as rollup power set.
rollup :: AggregatingPowerSet a -> AggregateKey a
rollup :: forall a. AggregatingPowerSet a -> AggregateKey a
rollup =  forall a.
([AggregateBitKey] -> AggregateElem)
-> AggregatingPowerSet a -> AggregateKey a
finalizePower [AggregateBitKey] -> AggregateElem
aggregateRollup

-- | Finalize grouping power set as cube power set.
cube   :: AggregatingPowerSet a -> AggregateKey a
cube :: forall a. AggregatingPowerSet a -> AggregateKey a
cube   =  forall a.
([AggregateBitKey] -> AggregateElem)
-> AggregatingPowerSet a -> AggregateKey a
finalizePower [AggregateBitKey] -> AggregateElem
aggregateCube

-- | Finalize grouping set list.
groupingSets :: AggregatingSetList a -> AggregateKey a
groupingSets :: forall a. AggregatingSetList a -> AggregateKey a
groupingSets =  forall a. (a, AggregateElem) -> AggregateKey a
unsafeAggregateKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [AggregateSet] -> AggregateElem
aggregateSets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ac at a. Aggregatings ac at Identity a -> (a, [at])
extractTermList