{-# language DataKinds #-}
{-# language GADTs #-}
{-# language KindSignatures #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}

module Rel8.Aggregate
  ( Aggregator' (Aggregator)
  , Aggregator
  , Aggregator1
  , toAggregator
  , toAggregator1
  , filterWhereExplicit
  , unsafeMakeAggregator
  )
where

-- base
import Control.Applicative (liftA2)
import Data.Kind (Type)
import Prelude

-- opaleye
import qualified Opaleye.Aggregate as Opaleye
import qualified Opaleye.Internal.MaybeFields as Opaleye
import qualified Opaleye.Internal.Operators as Opaleye

-- product-profunctor
import Data.Profunctor.Product
  ( ProductProfunctor, purePP, (****)
  , SumProfunctor, (+++!)
  )

-- profunctors
import Data.Profunctor (Profunctor, dimap)

-- rel8
import Rel8.Expr (Expr)
import Rel8.Expr.Opaleye (toPrimExpr, toColumn)
import Rel8.Aggregate.Fold (Fallback (Empty, Fallback), Fold (Full, Semi))

-- semigroupoids
import Data.Functor.Apply (Apply, liftF2)


-- | 'Aggregator'' is the most general form of \"aggregator\", of which
-- 'Aggregator' and 'Aggregator1' are special cases. 'Aggregator''s are
-- comprised of aggregation functions and/or @GROUP BY@ clauses.
--
-- Aggregation functions operating on individual 'Rel8.Expr's such as
-- 'Rel8.sum' can be combined into 'Aggregator's operating on larger types
-- using the 'Applicative', 'Profunctor' and 'ProductProfunctor' interfaces.
-- Working with 'Profunctor's can sometimes be awkward so for every 'Rel8.sum'
-- we also provide a 'Rel8.sumOn' which bundles an 'Data.Profunctor.lmap'. For
-- complex aggregations, we recommend using these functions along with
-- @ApplicativeDo@, @BlockArguments@, @OverloadedRecordDot@ and
-- @RecordWildCards@:
--
-- @
--
-- data Input f = Input
--   { orderId :: Column f OrderId
--   , customerId :: Column f CustomerId
--   , productId :: Column f ProductId
--   , quantity :: Column f Int64
--   , price :: Column f Scientific
--   }
--   deriving (Generic, Rel8able)
--
--
-- totalPrice :: Input Expr -> Expr Scientific
-- totalPrice input = fromIntegral input.quantity * input.price
--
--
-- data Result f = Result
--   { customerId :: Column f CustomerId
--   , totalOrders :: Column f Int64
--   , productsOrdered :: Column f Int64
--   , totalPrice :: Column Scientific
--   }
--   deriving (Generic, Rel8able)
--
--
-- allResults :: Query (Result Expr)
-- allResults =
--   aggregate
--     do
--       customerId <- groupByOn (.customerId)
--       totalOrders <- countDistinctOn (.orderId)
--       productsOrdered <- countDistinctOn (.productId)
--       totalPrice <- sumOn totalPrice
--       pure Result {..}
--     do
--       order <- each orderSchema
--       orderLine <- each orderLineSchema
--       where_ $ order.id ==. orderLine.orderId
--       pure
--         Input
--           { orderId = order.id
--           , customerId = order.customerId
--           , productId = orderLine.productId
--           , quantity = orderLine.quantity
--           , price = orderLine.price
--           }
-- @
type Aggregator' :: Fold -> Type -> Type -> Type
data Aggregator' fold i a = Aggregator !(Fallback fold a) !(Opaleye.Aggregator i a)


instance Profunctor (Aggregator' fold) where
  dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> Aggregator' fold b c -> Aggregator' fold a d
dimap a -> b
f c -> d
g (Aggregator Fallback fold c
fallback Aggregator b c
a) =
    Fallback fold d -> Aggregator a d -> Aggregator' fold a d
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator ((c -> d) -> Fallback fold c -> Fallback fold d
forall a b. (a -> b) -> Fallback fold a -> Fallback fold b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Fallback fold c
fallback) ((a -> b) -> (c -> d) -> Aggregator b c -> Aggregator a d
forall a b c d.
(a -> b) -> (c -> d) -> Aggregator b c -> Aggregator a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f c -> d
g Aggregator b c
a)


instance ProductProfunctor (Aggregator' fold) where
  purePP :: forall b a. b -> Aggregator' fold a b
purePP = b -> Aggregator' fold a b
forall a. a -> Aggregator' fold a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  **** :: forall a b c.
Aggregator' fold a (b -> c)
-> Aggregator' fold a b -> Aggregator' fold a c
(****) = Aggregator' fold a (b -> c)
-> Aggregator' fold a b -> Aggregator' fold a c
forall a b.
Aggregator' fold a (a -> b)
-> Aggregator' fold a a -> Aggregator' fold a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)


instance SumProfunctor (Aggregator' fold) where
  Aggregator Fallback fold b
fallback Aggregator a b
a +++! :: forall a b a' b'.
Aggregator' fold a b
-> Aggregator' fold a' b'
-> Aggregator' fold (Either a a') (Either b b')
+++! Aggregator Fallback fold b'
fallback' Aggregator a' b'
b =
    (Fallback fold (Either b b')
 -> Aggregator (Either a a') (Either b b')
 -> Aggregator' fold (Either a a') (Either b b'))
-> Aggregator (Either a a') (Either b b')
-> Fallback fold (Either b b')
-> Aggregator' fold (Either a a') (Either b b')
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fallback fold (Either b b')
-> Aggregator (Either a a') (Either b b')
-> Aggregator' fold (Either a a') (Either b b')
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator (Aggregator a b
a Aggregator a b
-> Aggregator a' b' -> Aggregator (Either a a') (Either b b')
forall a b a' b'.
Aggregator a b
-> Aggregator a' b' -> Aggregator (Either a a') (Either b b')
forall (p :: * -> * -> *) a b a' b'.
SumProfunctor p =>
p a b -> p a' b' -> p (Either a a') (Either b b')
+++! Aggregator a' b'
b) (Fallback fold (Either b b')
 -> Aggregator' fold (Either a a') (Either b b'))
-> Fallback fold (Either b b')
-> Aggregator' fold (Either a a') (Either b b')
forall a b. (a -> b) -> a -> b
$ case Fallback fold b
fallback of
      Fallback fold b
Empty -> case Fallback fold b'
fallback' of
        Fallback fold b'
Empty -> Fallback fold (Either b b')
Fallback 'Semi (Either b b')
forall a. Fallback 'Semi a
Empty
        Fallback b'
x -> Either b b' -> Fallback fold (Either b b')
forall a (fold :: Fold). a -> Fallback fold a
Fallback (b' -> Either b b'
forall a b. b -> Either a b
Right b'
x)
      Fallback b
x -> Either b b' -> Fallback fold (Either b b')
forall a (fold :: Fold). a -> Fallback fold a
Fallback (b -> Either b b'
forall a b. a -> Either a b
Left b
x)


instance Functor (Aggregator' fold i) where
  fmap :: forall a b.
(a -> b) -> Aggregator' fold i a -> Aggregator' fold i b
fmap = (i -> i)
-> (a -> b) -> Aggregator' fold i a -> Aggregator' fold i b
forall a b c d.
(a -> b)
-> (c -> d) -> Aggregator' fold b c -> Aggregator' fold a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap i -> i
forall a. a -> a
id


instance Apply (Aggregator' fold i) where
  liftF2 :: forall a b c.
(a -> b -> c)
-> Aggregator' fold i a
-> Aggregator' fold i b
-> Aggregator' fold i c
liftF2 a -> b -> c
f (Aggregator Fallback fold a
fallback Aggregator i a
a) (Aggregator Fallback fold b
fallback' Aggregator i b
b) =
    Fallback fold c -> Aggregator i c -> Aggregator' fold i c
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator ((a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
forall a b c.
(a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 a -> b -> c
f Fallback fold a
fallback Fallback fold b
fallback') ((a -> b -> c) -> Aggregator i a -> Aggregator i b -> Aggregator i c
forall a b c.
(a -> b -> c) -> Aggregator i a -> Aggregator i b -> Aggregator i c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Aggregator i a
a Aggregator i b
b)


instance Applicative (Aggregator' fold i) where
  pure :: forall a. a -> Aggregator' fold i a
pure a
a = Fallback fold a -> Aggregator i a -> Aggregator' fold i a
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator (a -> Fallback fold a
forall a. a -> Fallback fold a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (a -> Aggregator i a
forall a. a -> Aggregator i a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
  liftA2 :: forall a b c.
(a -> b -> c)
-> Aggregator' fold i a
-> Aggregator' fold i b
-> Aggregator' fold i c
liftA2 = (a -> b -> c)
-> Aggregator' fold i a
-> Aggregator' fold i b
-> Aggregator' fold i c
forall a b c.
(a -> b -> c)
-> Aggregator' fold i a
-> Aggregator' fold i b
-> Aggregator' fold i c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2


-- | An 'Aggregator' takes a 'Rel8.Query' producing a collection of rows of
-- type @a@ and transforms it into a 'Rel8.Query' producing a single row of
-- type @b@. If the given 'Rel8.Query' produces an empty collection of rows,
-- then the single row in the resulting 'Rel8.Query' contains the identity
-- values of the aggregation functions comprising the 'Aggregator' (i.e.,
-- @0@ for 'Rel8.sum', 'Rel8.false' for 'Rel8.or', etc.).
--
-- 'Aggregator' is a special form of 'Aggregator'' parameterised by 'Full'.
type Aggregator :: Type -> Type -> Type
type Aggregator = Aggregator' 'Full


-- | An 'Aggregator1' takes a collection of rows of type @a@, groups them, and
-- transforms each group into a single row of type @b@. This corresponds to
-- aggregators using @GROUP BY@ in SQL. If given an empty collection of rows,
-- 'Aggregator1' will have no groups and will therefore also return an empty
-- collection of rows.
--
-- 'Aggregator1' is a special form of 'Aggregator'' parameterised by 'Semi'.
type Aggregator1 :: Type -> Type -> Type
type Aggregator1 = Aggregator' 'Semi


-- | 'toAggregator1' turns an 'Aggregator' into an 'Aggregator1'.
toAggregator1 :: Aggregator' fold i a -> Aggregator1 i a
toAggregator1 :: forall (fold :: Fold) i a. Aggregator' fold i a -> Aggregator1 i a
toAggregator1 (Aggregator Fallback fold a
_ Aggregator i a
a) = Fallback 'Semi a -> Aggregator i a -> Aggregator' 'Semi i a
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator Fallback 'Semi a
forall a. Fallback 'Semi a
Empty Aggregator i a
a


-- | Given a value to fall back on if given an empty collection of rows,
-- 'toAggregator' turns an 'Aggregator1' into an 'Aggregator'.
toAggregator :: a -> Aggregator' fold i a -> Aggregator' fold' i a
toAggregator :: forall a (fold :: Fold) i (fold' :: Fold).
a -> Aggregator' fold i a -> Aggregator' fold' i a
toAggregator a
fallback (Aggregator Fallback fold a
_ Aggregator i a
a) = Fallback fold' a -> Aggregator i a -> Aggregator' fold' i a
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator (a -> Fallback fold' a
forall a (fold :: Fold). a -> Fallback fold a
Fallback a
fallback) Aggregator i a
a


filterWhereExplicit :: ()
  => Opaleye.IfPP a a
  -> (i -> Expr Bool)
  -> Aggregator i a
  -> Aggregator' fold i a
filterWhereExplicit :: forall a i (fold :: Fold).
IfPP a a
-> (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a
filterWhereExplicit IfPP a a
ifPP i -> Expr Bool
f (Aggregator (Fallback a
fallback) Aggregator i a
aggregator) =
  Fallback fold a -> Aggregator i a -> Aggregator' fold i a
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator (a -> Fallback fold a
forall a (fold :: Fold). a -> Fallback fold a
Fallback a
fallback) Aggregator i a
aggregator'
  where
    aggregator' :: Aggregator i a
aggregator' =
      IfPP a a -> a -> MaybeFields a -> a
forall b. IfPP b b -> b -> MaybeFields b -> b
Opaleye.fromMaybeFieldsExplicit IfPP a a
ifPP a
fallback
        (MaybeFields a -> a)
-> Aggregator i (MaybeFields a) -> Aggregator i a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (i -> Field SqlBool)
-> Aggregator i a -> Aggregator i (MaybeFields a)
forall a b.
(a -> Field SqlBool)
-> Aggregator a b -> Aggregator a (MaybeFields b)
Opaleye.filterWhere (PrimExpr -> Field SqlBool
forall (n :: Nullability) b. PrimExpr -> Field_ n b
toColumn (PrimExpr -> Field SqlBool)
-> (i -> PrimExpr) -> i -> Field SqlBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Bool -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr (Expr Bool -> PrimExpr) -> (i -> Expr Bool) -> i -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Expr Bool
f) Aggregator i a
aggregator


unsafeMakeAggregator :: forall (i :: Type) (o :: Type) (fold :: Fold) i' o'.  ()
  => (i -> i')
  -> (o' -> o)
  -> Fallback fold o
  -> Opaleye.Aggregator i' o'
  -> Aggregator' fold i o
unsafeMakeAggregator :: forall i o (fold :: Fold) i' o'.
(i -> i')
-> (o' -> o)
-> Fallback fold o
-> Aggregator i' o'
-> Aggregator' fold i o
unsafeMakeAggregator i -> i'
input o' -> o
output Fallback fold o
fallback =
  Fallback fold o -> Aggregator i o -> Aggregator' fold i o
forall (fold :: Fold) i a.
Fallback fold a -> Aggregator i a -> Aggregator' fold i a
Aggregator Fallback fold o
fallback (Aggregator i o -> Aggregator' fold i o)
-> (Aggregator i' o' -> Aggregator i o)
-> Aggregator i' o'
-> Aggregator' fold i o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> i') -> (o' -> o) -> Aggregator i' o' -> Aggregator i o
forall a b c d.
(a -> b) -> (c -> d) -> Aggregator b c -> Aggregator a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap i -> i'
input o' -> o
output