{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Stats where

import           Control.DeepSeq (NFData(..))
-- import           Control.Applicative (Const(..))
import           Data.Data
import           Data.Eq (Eq(..))
import           Data.Ord (Ord(..))
import           Data.Foldable (Foldable(..))
import           Data.Functor ((<$>))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Data.Map
import           Data.Maybe (Maybe(..), maybe)
import           Data.Monoid (Monoid(..))
import           Data.Text (Text)
import           Data.Typeable ()
import           Prelude (($), (.), Int, Integer, Num(..), Show(..), const, flip, id, seq)

import qualified Hcompta.Account as Account
import           Hcompta.Account (Account(..))
import           Hcompta.Date (Date)
import           Hcompta.Lib.Consable (Consable(..))
import           Hcompta.Lib.Interval (Interval)
import qualified Hcompta.Lib.Interval as Interval
import qualified Hcompta.Tag as Tag

-- * Requirements' interface

-- ** Class 'Posting'

class
 ( Account (Posting_Account p)
 , Data    (Posting_Unit    p)
 , NFData  (Posting_Account p)
 , NFData  (Posting_Unit    p)
 , Ord     (Posting_Unit    p)
 , Show    (Posting_Unit    p)
 ) =>  Posting          p where
	type Posting_Account  p
	type Posting_Unit     p
	type Posting_Quantity p
	posting_account :: p -> Posting_Account p
	posting_amounts :: p -> Map (Posting_Unit     p)
	                            (Posting_Quantity p)

-- ** Class 'Transaction'

class
 ( Posting  (Transaction_Posting  t)
 , Foldable (Transaction_Postings t)
 )
 =>    Transaction          t where
	type Transaction_Posting  t
	type Transaction_Postings t :: * -> *
	transaction_date          :: t -> Date
	transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
	transaction_postings_size :: t -> Int
	transaction_postings_size = Data.Foldable.foldr (const $ (+) 1) 0 . transaction_postings
	transaction_tags          :: t -> Tag.Tags

-- * Type 'Stats'

data Transaction t
 => Stats t
 =  Stats
 { stats_accounts          :: Map (Posting_Account (Transaction_Posting t)) ()
 , stats_tags              :: Map Tag.Path (Map Text Integer)
 , stats_transactions      :: Integer
 , stats_transactions_span :: Maybe (Interval Date)
 , stats_units             :: Map (Posting_Unit (Transaction_Posting t)) ()
 }
deriving instance ( Transaction    transaction
                  , Data           transaction
                  ) => Data (Stats transaction)
deriving instance ( Transaction  transaction
                  , Eq           transaction
                  ) => Eq (Stats transaction)
deriving instance ( Transaction    transaction
                  , Show           transaction
                  ) => Show (Stats transaction)
deriving instance Typeable1 Stats
instance
 ( NFData t
 , Transaction t
 ) => NFData (Stats t) where
	rnf
	 (Stats
	 { stats_accounts
	 , stats_tags
	 , stats_transactions
	 , stats_transactions_span
	 , stats_units
	 }) =
		rnf stats_accounts `seq`
		rnf stats_tags `seq`
		rnf stats_transactions `seq`
		rnf stats_transactions_span `seq`
		rnf stats_units

empty :: Transaction t => Stats t
empty =
	Stats
	 { stats_accounts = mempty
	 , stats_tags = mempty
	 , stats_transactions = 0
	 , stats_transactions_span = Nothing
	 , stats_units = mempty
	 }

stats_accounts_depths :: Transaction t => Stats t -> Interval Integer
stats_accounts_depths s =
	case Data.Map.keys $ stats_accounts s of
	 [] -> Interval.point 0
	 a:as ->
		Data.Foldable.foldr
		 (Interval.span . Interval.point . Account.depth)
		 (Interval.point $ Account.depth a) as

-- | Return the given 'Stats'
--   updated by the given 'Transaction'.
--
-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
--       the given 'Stats' is matched strictly.
cons :: Transaction t => t -> Stats t -> Stats t
cons t !s =
	Stats
	 { stats_accounts =
		Data.Foldable.foldl'
		 (flip $ (\p -> Data.Map.insert (posting_account p) ()))
		 (stats_accounts s)
		 (transaction_postings t)
	 , stats_tags =
		Data.Map.mergeWithKey
		 (\_k x1 x2 -> Just $
			Data.Map.unionWith (+) x1 $
			Data.Map.fromListWith (+) $ (, 1) <$> x2)
		 id ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
		 (stats_tags s)                    -- Map Text (Map Text Integer)
		 (Tag.unTags $ transaction_tags t) -- Map Text [Text]
	 , stats_transactions = 1 + (stats_transactions s)
	 , stats_transactions_span =
		let i = Interval.point $ transaction_date t in
		maybe (Just i) (Just . Interval.span i)
		 (stats_transactions_span s)
	 , stats_units =
		Data.Foldable.foldl'
		 (\su ->
			Data.Map.foldlWithKey -- TODO: merge rather than insert
			 (\acc unit _qty -> Data.Map.insert unit () acc)
			 su . posting_amounts)
		 (stats_units s)
		 (transaction_postings t)
	 }

union :: Transaction t => Stats t -> Stats t -> Stats t
union s0 s1 =
	Stats
	 { stats_accounts =
		Data.Map.unionWith
		 (const::()->()->())
		 (stats_accounts s0)
		 (stats_accounts s1)
	 , stats_tags =
		Data.Map.unionWith
		 (Data.Map.unionWith (+))
		 (stats_tags s0)
		 (stats_tags s1)
	 , stats_transactions =
		(+)
		 (stats_transactions s0)
		 (stats_transactions s1)
	 , stats_transactions_span = do
		case
		 ( stats_transactions_span s0
		 , stats_transactions_span s1
		 ) of
		 (Nothing, Nothing) -> Nothing
		 (Just i0, Nothing) -> Just i0
		 (Nothing, Just i1) -> Just i1
		 (Just i0, Just i1) -> Just $ Interval.span i0 i1
	 , stats_units =
		Data.Map.unionWith
		 (const::()->()->())
		 (stats_units s0)
		 (stats_units s1)
	 }

instance Transaction t => Monoid (Stats t) where
	mempty  = empty
	mappend = union

instance Transaction t => Consable () (Stats) t where
	mcons () t !s = cons t s