{-# 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 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
import           Hcompta.Tag (Tags(..))
import           Hcompta.Transaction (Transaction_Tags(..))

-- * 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 = foldr (const $ (+) 1) 0 . transaction_postings
	transaction_tags          :: t -> Transaction_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 Map.keys $ stats_accounts s of
	 [] -> Interval.point 0
	 a:as ->
		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 =
		foldl'
		 (flip $ (\p -> Map.insert (posting_account p) ()))
		 (stats_accounts s)
		 (transaction_postings t)
	 , stats_tags =
		Map.mergeWithKey
		 (\_k x1 x2 -> Just $
			Map.unionWith (+) x1 $
			Map.fromListWith (+) $ (, 1) <$> x2)
		 id ((Map.fromListWith (+) . ((, 1) <$>)) <$>)
		 (stats_tags s)                    -- Map Text (Map Text Integer)
		 (let Transaction_Tags (Tags tags) = transaction_tags t in tags) -- 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 =
		foldl' (\su ->
			Map.foldlWithKey -- TODO: merge rather than insert
			 (\acc unit _qty -> 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 =
		Map.unionWith
		 (const::()->()->())
		 (stats_accounts s0)
		 (stats_accounts s1)
	 , stats_tags =
		Map.unionWith
		 (Map.unionWith (+))
		 (stats_tags s0)
		 (stats_tags s1)
	 , stats_transactions =
		(+)
		 (stats_transactions s0)
		 (stats_transactions s1)
	 , stats_transactions_span =
		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 =
		Map.unionWith
		 (const::()->()->())
		 (stats_units s0)
		 (stats_units s1)
	 }

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