{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
 -- FIXME: to be removed when dropping GHC-7.6 support

-- | Balance
module Hcompta.Balance where

-- import           Control.Applicative (Const(..))
-- import           Control.Arrow (second)
import           Control.DeepSeq (NFData(..))
import           Control.Exception (assert)
import           Data.Bool
import           Data.Data
import           Data.Either (Either(..))
import           Data.Eq (Eq(..))
import           Data.Foldable (Foldable(..))
import qualified Data.Foldable as Foldable
import           Data.Function (($), (.), const, flip)
-- import           Data.Functor.Identity (Identity(..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
-- import qualified Data.MonoTraversable as MT
import           Data.Monoid (Monoid(..))
import           Data.Ord (Ord(..))
import qualified Data.Strict.Maybe as Strict
import           Data.TreeMap.Strict (TreeMap(..))
import qualified Data.TreeMap.Strict as TreeMap
import           Data.Tuple (curry, fst, snd)
import           Data.Typeable ()
import           Prelude (undefined)
import           Text.Show (Show(..))

import           Hcompta.Account
import           Hcompta.Amount
import qualified Hcompta.Lib.Foldable as Foldable
import qualified Hcompta.Lib.Strict as Strict
import           Hcompta.Posting
import           Hcompta.Quantity

-- * Class 'Balance_Posting'

-- | A 'posting' used to produce a 'Balance'
--   must be an instance of this class.
class Posting p => Balance_Posting p where
	-- | 'Balance_Posting_Quantity'
	-- enables to build a 'Balance' with some quantity
	-- other than: 'Amount_Quantity' ('Posting_Amount' @p@);
	-- it's useful to 'polarize' it.
	type Balance_Posting_Quantity p
	balance_posting_amounts
	 :: p -> Balance_Posting_Amounts p
	balance_posting_amounts_set
	 :: Balance_Posting_Amounts p
	 -> p -> p

-- ** Type 'Balance_Posting_Amounts'

-- | 'Balance' operations works on this type of 'Amount's.
type Balance_Posting_Amounts p
 = Map (Amount_Unit (Posting_Amount p))
       (Balance_Posting_Quantity p)

instance -- (account, Map unit quantity)
 ( Account account
 , Amount (unit, quantity)
 -- , Amount (MT.Element amounts)
 -- , MT.MonoFoldable amounts
 ) => Balance_Posting (account, Map unit quantity) where
	type Balance_Posting_Quantity (account, Map unit quantity) = quantity
	balance_posting_amounts          (_, amts) = amts
	balance_posting_amounts_set amts (acct, _) = (acct, amts)

-- * Type 'Balance'

-- | 'Balance_Account' and 'Balance_by_Unit' of some 'Balance_Posting's.
--
-- NOTE: to reduce memory consumption
--       when applying 'balance_cons' incrementally,
--       the fields are explicitely stricts.
data Balance account_section unit quantity
 =   Balance
 {   balance_by_account :: !(Balance_by_Account account_section unit quantity)
 ,   balance_by_unit    :: !(Balance_by_Unit    account_section unit quantity)
 }
 --deriving (Data, Eq, Show, Typeable)
deriving instance -- Data
 ( Data    account_section
 , Data     unit
 , Data     quantity
 , Ord      unit
 , Ord account_section
 , Typeable unit
 , Typeable quantity
 ) => Data (Balance account_section unit quantity)
deriving instance -- Eq
 ( Eq      account_section
 , Eq      unit
 , Eq      quantity
 ) => Eq (Balance account_section unit quantity)
deriving instance -- Show
 ( Show    account_section
 , Show    unit
 , Show    quantity
 ) => Show (Balance account_section unit quantity)
deriving instance -- Typeable
 Typeable3 Balance
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

instance -- Monoid
 ( Addable quantity
 , Ord     unit
 , Ord     account_section
 ) => Monoid (Balance account_section unit quantity) where
	mempty  = balance_empty
	mappend = balance_union

-- ** Type 'Balance_by_Account'
type Balance_by_Account account_section unit quantity
 = TreeMap account_section
           (Balance_by_Account_Sum unit quantity)

-- *** Type 'Balance_by_Account_Sum'
-- | A sum of 'quantity's, concerning a single 'account'.
newtype Balance_by_Account_Sum unit quantity
 =      Balance_by_Account_Sum (Map unit quantity)
 deriving (Data, Eq, Foldable, Show, Typeable)
unBalance_by_Account_Sum
 :: Balance_by_Account_Sum unit quantity
 -> Map unit quantity
unBalance_by_Account_Sum (Balance_by_Account_Sum m) = m
instance -- Monoid
 ( Addable quantity
 , Ord unit
 ) => Monoid (Balance_by_Account_Sum unit quantity) where
	mempty = Balance_by_Account_Sum mempty
	mappend (Balance_by_Account_Sum x) (Balance_by_Account_Sum y) =
		Balance_by_Account_Sum $ Map.unionWith quantity_add x y
instance -- NFData
 ( NFData unit
 , NFData quantity
 ) => NFData (Balance_by_Account_Sum unit quantity) where
	rnf (Balance_by_Account_Sum m) = rnf m
instance -- Posting
 ( Account account
 , Amount (unit, quantity)
 ) => Posting          (account, Balance_by_Account_Sum unit quantity) where
	type Posting_Account (account, Balance_by_Account_Sum unit quantity) = account
	type Posting_Amount  (account, Balance_by_Account_Sum unit quantity) = (unit, quantity)
	type Posting_Amounts (account, Balance_by_Account_Sum unit quantity) = Map unit quantity
	posting_account = fst
	posting_amounts = unBalance_by_Account_Sum . snd
instance -- Balance_Posting
 ( Account account
 , Amount (unit, quantity)
 ) => Balance_Posting (account, Balance_by_Account_Sum unit quantity) where
	type Balance_Posting_Quantity (account, Balance_by_Account_Sum unit quantity) = quantity
	balance_posting_amounts (_, Balance_by_Account_Sum x) = x
	balance_posting_amounts_set amounts (acct, _) = (acct, Balance_by_Account_Sum amounts)

-- ** Type 'Balance_by_Unit'
newtype Balance_by_Unit account_section unit quantity
 =      Balance_by_Unit (Map unit (Balance_by_Unit_Sum account_section quantity))
deriving instance -- Data
 ( Data     account_section
 , Data     unit
 , Data     quantity
 , Ord      unit
 , Ord      account_section
 , Typeable unit
 , Typeable quantity
 ) => Data (Balance_by_Unit account_section unit quantity)
deriving instance -- Eq
 ( Eq account_section
 , Eq unit
 , Eq quantity
 ) => Eq (Balance_by_Unit account_section unit quantity)
instance -- Monoid
 ( Addable quantity
 , Ord     unit
 , Ord     account_section
 ) => Monoid (Balance_by_Unit account_section unit quantity) where
	mempty  = Balance_by_Unit mempty
	mappend = balance_by_unit_union
deriving instance -- Show
 ( Show account_section
 , Show unit
 , Show quantity
 ) => Show (Balance_by_Unit account_section unit quantity)
deriving instance -- Typeable
 Typeable3 Balance_by_Unit
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- *** Type 'Balance_by_Unit_Sum'

-- | A sum of 'quantity's with their 'Account's involved,
-- concerning a single 'unit'.
data Balance_by_Unit_Sum account_section quantity
 =   Balance_by_Unit_Sum
 {   balance_by_unit_sum_quantity :: !quantity
     -- ^ The sum of 'quantity's for a single 'unit'.
 ,   balance_by_unit_sum_accounts :: !(Map (Account_Path account_section) ())
     -- ^ The 'account's involved to build 'balance_by_unit_sum_quantity'.
 }
deriving instance -- Data
 ( Data account_section
 , Data quantity
 , Ord  account_section
 ) => Data (Balance_by_Unit_Sum account_section quantity)
deriving instance -- Eq
 ( Eq account_section
 , Eq quantity
 ) => Eq (Balance_by_Unit_Sum account_section quantity)
deriving instance -- Show
 ( Show account_section
 , Show quantity
 ) => Show (Balance_by_Unit_Sum account_section quantity)
deriving instance -- Typeable
 Typeable2 Balance_by_Unit_Sum
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- ** Constructors

balance_empty
 :: ( Addable quantity
    , Ord     unit
    , Ord     account_section
    )
 => Balance account_section unit quantity
balance_empty =
	Balance
	 { balance_by_account = mempty
	 , balance_by_unit    = mempty
	 }

-- | Return the given 'Balance'
--   updated by the given 'Balance_Posting'.
balance_cons
 :: ( Balance_Posting posting
    , balance ~ Balance (Account_Section (Posting_Account posting))
                        (Amount_Unit     (Posting_Amount  posting))
                        (Balance_Posting_Quantity posting)
    , Addable (Balance_Posting_Quantity posting)
    , Ord     (Amount_Unit (Posting_Amount posting))
    )
 => posting -> balance -> balance
balance_cons post bal =
	bal
	 { balance_by_account = balance_by_account_cons post (balance_by_account bal)
	 , balance_by_unit    = balance_by_unit_cons    post (balance_by_unit    bal)
	 }

-- | Return the given 'Balance'
--   updated by the given 'Balance_Posting's.
balance_postings
 :: ( Balance_Posting posting
    , balance ~ Balance (Account_Section (Posting_Account posting))
                        (Amount_Unit     (Posting_Amount  posting))
                        (Balance_Posting_Quantity posting)
    , Foldable foldable
    , Addable (Balance_Posting_Quantity posting)
    , Ord     (Amount_Unit (Posting_Amount posting))
    , Posting posting
    )
 => foldable posting -> balance -> balance
balance_postings = flip (Foldable.foldr balance_cons)

-- | Return the first given 'Balance'
--   updated by the second given 'Balance'.
balance_union
 :: ( Addable quantity
    , Ord unit
    , Ord account_section
    , balance ~ Balance account_section unit quantity
    )
 => balance -> balance -> balance
balance_union
 (Balance b0a b0u)
 (Balance b1a b1u) =
	Balance
	 { balance_by_account = balance_by_account_union b0a b1a
	 , balance_by_unit    = balance_by_unit_union    b0u b1u
	 }

-- | Return the given 'Balance_by_Account'
--   updated by the given 'Balance_Posting'.
balance_by_account_cons
 :: ( Posting posting
    , Balance_Posting posting
    , account  ~ Posting_Account  posting
    , quantity ~ Balance_Posting_Quantity posting
    , unit     ~ Amount_Unit     (Posting_Amount posting)
    , Addable quantity
    , Ord unit
    )
 => posting
 -> Balance_by_Account (Account_Section account) unit quantity
 -> Balance_by_Account (Account_Section account) unit quantity
balance_by_account_cons post =
	TreeMap.insert mappend
	 (account_path $ posting_account post)
	 (Balance_by_Account_Sum $ balance_posting_amounts post)

-- | Return the given 'Balance_by_Unit'
--   updated by the given 'Balance_Posting'.
balance_by_unit_cons
 :: ( Balance_Posting posting
    , account_section ~ Account_Section (Posting_Account posting)
    , quantity ~ Balance_Posting_Quantity posting
    , unit ~ Amount_Unit (Posting_Amount  posting)
    , Addable quantity
    , Ord unit
    )
 => posting
 -> Balance_by_Unit account_section unit quantity
 -> Balance_by_Unit account_section unit quantity
balance_by_unit_cons post =
	balance_by_unit_union $
	Balance_by_Unit $
	(`Map.map` balance_posting_amounts post) $
	 \quantity -> Balance_by_Unit_Sum
		 { balance_by_unit_sum_quantity = quantity
		 , balance_by_unit_sum_accounts = Map.singleton (account_path $ posting_account post) ()
		 }

-- | Return a 'Balance_by_Unit'
--   derived from the given 'Balance_by_Account'.
balance_by_unit_of_by_account ::
 ( Amount (unit, quantity)
 , Addable quantity
 , Data    account_section
 , NFData  account_section
 , Ord     account_section
 , Ord     unit
 , Show    account_section
 )
 => Balance_by_Account account_section unit quantity
 -> Balance_by_Unit account_section unit quantity
 -> Balance_by_Unit account_section unit quantity
balance_by_unit_of_by_account =
	flip $ TreeMap.foldr_with_Path $ curry balance_by_unit_cons

-- | Return the first given 'Balance_by_Account'
--   updated by the second given 'Balance_by_Account'.
balance_by_account_union
 :: ( Addable quantity
    , Ord account_section
    , Ord unit
    )
 => Balance_by_Account account_section unit quantity
 -> Balance_by_Account account_section unit quantity
 -> Balance_by_Account account_section unit quantity
balance_by_account_union = TreeMap.union mappend

-- | Return the first given 'Balance_by_Unit'
--   updated by the second given 'Balance_by_Unit'.
balance_by_unit_union
 :: ( Addable quantity
    , Ord unit
    , Ord account_section
    )
 => Balance_by_Unit account_section unit quantity
 -> Balance_by_Unit account_section unit quantity
 -> Balance_by_Unit account_section unit quantity
balance_by_unit_union
 (Balance_by_Unit a0)
 (Balance_by_Unit a1) =
	Balance_by_Unit $
	Map.unionWith
	 (\new old -> Balance_by_Unit_Sum
		 { balance_by_unit_sum_quantity = quantity_add
			 (balance_by_unit_sum_quantity old)
			 (balance_by_unit_sum_quantity new)
		 , balance_by_unit_sum_accounts = Map.unionWith
			 (const::()->()->())
			 (balance_by_unit_sum_accounts old)
			 (balance_by_unit_sum_accounts new)
		 })
	 a0 a1

-- * Type 'Balance_Deviation'

-- | The 'Balance_by_Unit' whose 'balance_by_unit_sum_quantity'
--   is not zero and possible 'account' to 'balance_infer_equilibrium'.
newtype Balance_Deviation                  account_section unit quantity
 =      Balance_Deviation (Balance_by_Unit account_section unit quantity)
deriving instance -- Data
 ( Data     account_section
 , Data     unit
 , Data     quantity
 , Ord      unit
 , Ord      account_section
 , Typeable unit
 , Typeable quantity
 ) => Data (Balance_Deviation account_section unit quantity)
deriving instance -- Eq
 ( Eq      account_section
 , Eq      unit
 , Eq      quantity
 ) => Eq (Balance_Deviation account_section unit quantity)
deriving instance -- Show
 ( Show    account_section
 , Show    unit
 , Show    quantity
 ) => Show (Balance_Deviation account_section unit quantity)
deriving instance -- Typeable
 Typeable3 Balance_Deviation
 -- FIXME: use 'Typeable' when dropping GHC-7.6 support

-- | Return the 'balance_by_unit' of the given 'Balance' with:
--
-- * 'unit's whose 'balance_by_unit_sum_quantity' is verifying 'quantity_null' removed,
--
-- * and remaining 'unit's having their 'balance_by_unit_sum_accounts'
--   complemented with the 'balance_by_account' of the given 'Balance'
--   (i.e. now mapping to 'account's __not__ involved to build the 'Balance_by_Unit_Sum').
balance_deviation
 :: ( Zero    quantity
    , Addable quantity
    , Ord     account_section
    , Ord     unit
    )
 => Balance           account_section unit quantity
 -> Balance_Deviation account_section unit quantity
balance_deviation Balance
 { balance_by_account
 , balance_by_unit=Balance_by_Unit balance_by_unit
 } =
	let all_accounts = TreeMap.flatten (const ()) balance_by_account in
	let max_accounts = Map.size all_accounts in
	Balance_Deviation $
		Map.foldlWithKey
		 (\(Balance_by_Unit m) unit Balance_by_Unit_Sum{..} ->
			Balance_by_Unit $
			if quantity_null balance_by_unit_sum_quantity
			then m
			else
				case Map.size balance_by_unit_sum_accounts of
				 n | n == max_accounts ->
					Map.insert unit Balance_by_Unit_Sum
					 { balance_by_unit_sum_quantity
					 , balance_by_unit_sum_accounts = Map.empty
					 } m
				 _ ->
					let diff = Map.difference all_accounts balance_by_unit_sum_accounts in
					Map.insert unit Balance_by_Unit_Sum
					 { balance_by_unit_sum_quantity
					 , balance_by_unit_sum_accounts = diff
					 } m
		 )
		 mempty
		 balance_by_unit

-- ** Balance equilibrium

-- | Return the 'Balance' (adjusted by inferred 'quantity's)
--   of the given 'Balance_Posting's and either:
--
--   * 'Left': the 'Balance_Posting's that cannot be inferred.
--   * 'Right': the given 'Balance_Posting's with inferred 'quantity's inserted.
balance_infer_equilibrium
 :: ( Balance_Posting posting
    , account  ~ Posting_Account  posting
    , unit     ~ Amount_Unit     (Posting_Amount posting)
    , quantity ~ Balance_Posting_Quantity posting
    , account  ~ Account_Path (Account_Section account)
    , account_section ~ Account_Section account
    , Addable quantity
    , Eq      quantity
    , Negable quantity
    , Zero    quantity
    , Ord     account_section
    , Ord     unit
    )
 => Map account [posting]
 -> ( Balance account_section unit quantity
    , Either [(unit, Balance_by_Unit_Sum account_section quantity)]
             (Map account [posting])
    )
balance_infer_equilibrium posts =
	let bal_initial = Foldable.foldr balance_postings balance_empty posts in
	let Balance_Deviation (Balance_by_Unit dev) = balance_deviation bal_initial in
	let (bal_adjusted, eithers) =
		Map.foldrWithKey
		 (\unit unit_sum@Balance_by_Unit_Sum{..} (bal, lr) ->
			case Map.size balance_by_unit_sum_accounts of
			 1 ->
				let acct = fst $ Map.elemAt 0 balance_by_unit_sum_accounts in
				let qty  = quantity_neg balance_by_unit_sum_quantity in
				let amts = Map.singleton unit qty in
				( balance_cons (acct, Balance_by_Account_Sum amts) bal
				, Right (acct, unit, qty) : lr
				)
			 _ -> (bal, Left [(unit, unit_sum)] : lr))
		 (bal_initial, [])
		 dev in
	let (l, r) = Foldable.accumLeftsAndFoldrRights
		 (\(acct, unit, qty) ->
			Map.insertWith
			 (\_new_ps -> insert_amount (unit, qty))
			 acct (assert False []))
		 posts eithers in
	case l of
	 [] -> (bal_adjusted, Right r)
	 _  -> (bal_adjusted, Left  l)
	where
		insert_amount
		 :: Balance_Posting posting
		 => ( Amount_Unit     (Posting_Amount posting)
		    , Balance_Posting_Quantity posting
		    )
		 -> [posting]
		 -> [posting]
		insert_amount p@(unit, qty) ps =
			case ps of
			 [] -> assert False []
			 (x:xs) | Map.null (balance_posting_amounts x) ->
				balance_posting_amounts_set (Map.singleton unit qty) x:xs
			        | Map.notMember unit (balance_posting_amounts x) ->
				let amts = Map.insertWith
					 (assert False undefined)
					 unit qty (balance_posting_amounts x) in
				balance_posting_amounts_set amts x:xs
			 (x:xs) -> x:insert_amount p xs

-- | Return 'True' if and only if the given 'Balance_Deviation' maps no 'unit'.
is_balance_at_equilibrium
 :: Balance_Deviation account_section unit quantity
 -> Bool
is_balance_at_equilibrium (Balance_Deviation (Balance_by_Unit dev)) = Map.null dev

-- | Return 'True' if and only if the given 'Balance_Deviation'
-- maps only to 'Balance_by_Unit_Sum's whose 'balance_by_unit_sum_accounts'
-- maps exactly one 'account'.
is_balance_equilibrium_inferrable
 :: Balance_Deviation account_section unit quantity
 -> Bool
is_balance_equilibrium_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
	Foldable.all
	 (\s -> Map.size (balance_by_unit_sum_accounts s) == 1)
	 dev

-- | Return 'True' if and only if the given 'Balance_Deviation'
-- maps to at least one 'Balance_by_Unit_Sum' whose 'balance_by_unit_sum_accounts'
-- maps more than one 'Account'.
is_balance_equilibrium_non_inferrable
 :: Balance_Deviation account_section unit quantity
 -> Bool
is_balance_equilibrium_non_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
	Foldable.any
	 (\s -> Map.size (balance_by_unit_sum_accounts s) > 1)
	 dev

-- * Type 'Balance_Expanded'

-- | Descending propagation of 'quantity's accross 'Account's.
type Balance_Expanded account_section unit quantity
 = TreeMap account_section (Balance_by_Account_Sum_Expanded unit quantity)

-- ** Type 'Balance_by_Account_Sum_Expanded'

-- |
-- * 'Strict.exclusive': contains the original 'Balance_by_Account_Sum'.
-- * 'Strict.inclusive': contains 'quantity_add' folded
--   over 'Strict.exclusive' and 'Strict.inclusive'
--   of 'TreeMap.node_descendants'
type Balance_by_Account_Sum_Expanded unit quantity
 = Strict.Clusive (Balance_by_Account_Sum unit quantity)

-- | Return the given 'Balance_by_Account' with:
--
-- * all missing 'Account.parent' 'Account's inserted;
-- * and every mapped 'quantity' added with any 'quantity'
--   of the 'Account's for which it is 'Account.parent'.
balance_expanded ::
 ( Addable quantity
 , Ord account_section
 , Ord unit
 ) => Balance_by_Account account_section unit quantity
 -> Balance_Expanded account_section unit quantity
balance_expanded =
	TreeMap.map_by_depth_first
	 (\descendants value ->
		let exclusive = Strict.fromMaybe mempty value in
		Strict.Clusive
		 { Strict.exclusive
		 , Strict.inclusive =
			Map.foldl'
			 ( flip $ mappend . Strict.inclusive
			 . Strict.fromMaybe (assert False undefined)
			 . TreeMap.node_value )
			 exclusive $
			TreeMap.nodes descendants
		 })

-- | Return a 'Balance_by_Unit'
--   derived from the given 'Balance_Expanded' balance.
--
--   NOTE: also correct if the 'Balance_Expanded' has been filtered.
balance_by_unit_of_expanded
 :: ( Amount (unit, quantity)
    , Addable quantity
    , Data    account_section
    , NFData  account_section
    , Ord     account_section
    , Ord     unit
    , Show    account_section
    )
 => Balance_Expanded account_section unit quantity
 -> Balance_by_Unit  account_section unit quantity
 -> Balance_by_Unit  account_section unit quantity
balance_by_unit_of_expanded =
	go []
	where
		go p (TreeMap nodes) bal =
			Map.foldrWithKey
			 (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
				case node_value of
				 Strict.Nothing -> go (k:p) node_descendants acc
				 Strict.Just a  ->
					let acct = TreeMap.reverse $ TreeMap.path k p in
					balance_by_unit_cons (acct, Strict.inclusive a) acc)
			 bal nodes