{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DefaultSignatures #-}
{-# 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.Applicative (Const(..))
import           Control.DeepSeq (NFData(..))
import           Data.Data
import           Data.Eq (Eq(..))
import qualified Data.MonoTraversable as MT
import           Data.Function (($), (.), const, flip, id)
import           Data.Functor ((<$>))
import           Data.Int (Int)
import           Data.Interval (Interval)
import qualified Data.Interval as Interval
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..), maybe)
import           Data.Monoid (Monoid(..))
-- import           Data.Ord (Ord(..))
import           Data.Text (Text)
import           Data.Typeable ()
import           Prelude (Integer, Num(..), seq)
import           Text.Show (Show(..))

import           Hcompta.Account
import           Hcompta.Amount
import           Hcompta.Date (Date)
import           Hcompta.Lib.Consable (Consable(..))
import           Hcompta.Tag
import           Hcompta.Posting
import           Hcompta.Transaction

-- * Class 'Stats_Transaction'

class
 ( Transaction t
 , NFData (Posting_Account (Transaction_Posting t))
 , NFData (Amount_Unit (Posting_Amount (Transaction_Posting t)))
 ) =>  Stats_Transaction    t where
	stats_transaction_postings_count :: t -> Int
	default stats_transaction_postings_count
	 :: MT.MonoFoldable (Transaction_Postings t)
	 => t -> Int
	stats_transaction_postings_count =
		MT.ofoldr (const $ (+) 1) 0 . transaction_postings

-- * Type 'Stats'

data Stats_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 (Amount_Unit (Posting_Amount (Transaction_Posting t))) ()
 }
deriving instance -- Typeable
 Typeable1 Stats
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

deriving instance -- Data
 ( Stats_Transaction t
 , Data t
 ) => Data (Stats t)
deriving instance -- Eq
 ( Stats_Transaction t
 , Eq t
 ) => Eq (Stats t)
deriving instance -- Show
 ( Stats_Transaction t
 , Show t
 ) => Show (Stats t)
instance -- NFData
 ( NFData t
 , Stats_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
instance -- Monoid
 Stats_Transaction t
 => Monoid (Stats t) where
	mempty  = stats_empty
	mappend = stats_union
instance -- Consable
 ( Stats_Transaction t
 , MT.MonoFoldable (Transaction_Postings t)
 , MT.Element (Transaction_Postings t) ~ Transaction_Posting t
 , unit ~ Amount_Unit (Posting_Amount (Transaction_Posting t))
 , quantity ~ Amount_Quantity (Posting_Amount (Transaction_Posting t))
 , Posting_Amounts (Transaction_Posting t) ~ Map unit quantity
 ) => Consable t (Stats t) where
	mcons = stats_cons

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

stats_accounts_depths :: Stats_Transaction t => Stats t -> Interval Integer
stats_accounts_depths s =
	case Map.keys $ stats_accounts s of
	 [] -> Interval.point 0
	 a:as ->
		MT.ofoldr
		 (Interval.span . Interval.point . account_depth)
		 (Interval.point $ account_depth a) as

-- | Return the given 'Stats'
--   updated by the given 'Stats_Transaction'.
--
-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
--       the given 'Stats' is matched strictly.
stats_cons
 :: ( Stats_Transaction t
    , MT.MonoFoldable (Transaction_Postings t)
    , MT.Element (Transaction_Postings t) ~ Transaction_Posting t
    , Posting_Amounts (Transaction_Posting t)
      ~ Map (Amount_Unit     (Posting_Amount (Transaction_Posting t)))
            (Amount_Quantity (Posting_Amount (Transaction_Posting t)))
    )
 => t -> Stats t -> Stats t
stats_cons t !s =
	Stats
	 { stats_accounts =
		MT.ofoldl'
		 (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
		Just $ maybe i (Interval.span i)
		 (stats_transactions_span s)
	 , stats_units =
		MT.ofoldl' (\su ->
			Map.foldlWithKey -- TODO: merge rather than insert
			 (\acc unit _qty -> Map.insert unit () acc)
			 su . posting_amounts)
		 (stats_units s)
		 (transaction_postings t)
	 }

stats_union :: Stats_Transaction t => Stats t -> Stats t -> Stats t
stats_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)
	 }