{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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.Applicative (Const(..))
import           Data.Data
import qualified Data.Foldable
import qualified Data.Map.Strict as Data.Map
import           Data.Map.Strict (Map)
import           Data.Text (Text)
import           Data.Typeable ()

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

-- * Requirements' interface

-- ** Class 'Unit'

class Unit a where
	unit_text :: a -> Text

instance Unit Amount.Unit where
	unit_text = Amount.Unit.text

-- ** Class 'Amount'

class
 ( Data (Amount_Unit a)
 , Ord  (Amount_Unit a)
 , Show (Amount_Unit a)
 , Unit (Amount_Unit a)
 )
 =>    Amount      a where
	type Amount_Unit a
	amount_unit :: a -> Amount_Unit a

instance Amount    Amount.Amount where
	type Amount_Unit Amount.Amount = Amount.Unit
	amount_unit = Amount.unit

-- ** Class 'Posting'

class Amount (Posting_Amount p)
 =>    Posting        p where
	type Posting_Amount p
	posting_account :: p -> Account
	posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount 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 -> Map Tag.Path [Tag.Value]

-- * Type 'Stats'

data Transaction t => Stats t
 = Stats
 { stats_accounts          :: !(Map Account ())
 , stats_tags              :: !(Map Tag.Path (Map Text Integer))
 , stats_transactions      :: !Integer
 , stats_transactions_span :: !(Maybe (Interval Date))
 , stats_units             :: !(Map (Amount_Unit (Posting_Amount (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

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)
		 (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.Foldable.foldl'
			 (flip $ (\a -> Data.Map.insert (amount_unit a) ()))
			 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