{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Command.Balance where

import           Control.Applicative ((<*), Const(..))
import           Control.Arrow (first)
import           Control.Monad (Monad(..), forM_, liftM, mapM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import           Data.Bool
import           Data.Either (Either(..), partitionEithers)
import           Data.Eq (Eq(..))
import           Data.Foldable (Foldable(..), any)
import           Data.Functor (Functor(..), (<$>))
import           Data.List ((++), repeat)
import qualified Data.Map.Strict as Data.Map
import           Data.Maybe (Maybe(..), maybe)
import           Data.Monoid (Monoid(..), (<>))
import           Data.Ord (Ord(..), Ordering(..))
import qualified Data.Strict.Maybe as Strict
import           Data.String (String)
import           Data.Tuple (fst, snd)
import qualified Data.Time.Clock as Time
import           Prelude (($), (.), FilePath, IO, Num(..), const, id, flip, unlines, zipWith)
import qualified Text.Parsec
import           Text.Show (Show(..))
import           System.Console.GetOpt
                 ( ArgDescr(..)
                 , OptDescr(..)
                 , usageInfo
                 )
import           System.Environment as Env (getProgName)
import           System.Exit (exitSuccess)
import qualified System.IO as IO

import           Hcompta.Account (Account)
import qualified Hcompta.Account as Account
import qualified Hcompta.Account.Read as Account.Read
import           Hcompta.Amount (Amount)
import qualified Hcompta.Amount as Amount
import           Hcompta.Amount.Unit (Unit)
import qualified Hcompta.Amount.Write as Amount.Write
import qualified Hcompta.Balance as Balance
import           Hcompta.Chart (Chart)
import qualified Hcompta.Chart as Chart
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Lib.Leijen.Table as Table
import qualified Hcompta.CLI.Write as Write
import qualified Hcompta.Date as Date
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.TreeMap (TreeMap)
import qualified Hcompta.Lib.TreeMap as TreeMap
import qualified Hcompta.Posting as Posting
import qualified Hcompta.Tag as Tag

data Ctx
 =   Ctx
 { ctx_filter_balance      :: Filter.Simplified
                              (Filter.Filter_Bool
                              (Filter.Filter_Balance
                              ((Account, Tag.Tags), Amount.Sum Amount)))
 , ctx_filter_posting      :: Filter.Simplified
                              (Filter.Filter_Bool
                              (Filter.Filter_Posting
                              (Chart, Ledger.Posting)))
 , ctx_filter_transaction  :: Filter.Simplified
                              (Filter.Filter_Bool
                              (Filter.Filter_Transaction
                              (Chart, Ledger.Transaction)))
 , ctx_heritage            :: Bool
 , ctx_input               :: [FilePath]
 , ctx_output              :: [(Write.Mode, FilePath)]
 , ctx_reduce_date         :: Bool
 , ctx_redundant           :: Bool
 , ctx_total_by_unit       :: Bool
 , ctx_format_output       :: Format_Output
 , ctx_account_equilibrium :: (Account, Account)
 } deriving (Show)

data Format_Output
 =   Format_Output_Table
 |   Format_Output_Transaction Lang.Exercise_OC
 deriving (Eq, Show)

nil :: C.Context -> Ctx
nil c =
	Ctx
	 { ctx_filter_balance      = mempty
	 , ctx_filter_posting      = mempty
	 , ctx_filter_transaction  = mempty
	 , ctx_heritage            = True
	 , ctx_input               = []
	 , ctx_output              = []
	 , ctx_reduce_date         = True
	 , ctx_redundant           = False
	 , ctx_total_by_unit       = True
	 , ctx_format_output       = Format_Output_Table
	 , ctx_account_equilibrium =
		let e = C.translate c Lang.Account_Equilibrium
		in (e, e)
	 }

usage :: C.Context -> IO String
usage c = do
	bin <- Env.getProgName
	return $ unlines $
		[ C.translate c Lang.Section_Description
		, "  "++C.translate c Lang.Help_Command_Balance
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++
		                     " ["++C.translate c Lang.Type_File_Journal++"] [...]"
		, ""
		, usageInfo (C.translate c Lang.Section_Options) (options c)
		]

options :: C.Context -> Args.Options Ctx
options c =
	[ Option "b" ["filter-balance"]
	 (ReqArg (\s ctx -> do
		ctx_filter_balance <-
			liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
				liftIO $ Filter.Read.read Filter.Read.filter_balance s
				>>= \f -> case f of
				 Left  ko -> Write.fatal c ko
				 Right ok -> return ok
		return $ ctx{ctx_filter_balance}) $
		C.translate c Lang.Type_Filter_Balance) $
		C.translate c Lang.Help_Option_Filter_Balance
	, Option "p" ["filter-posting"]
	 (ReqArg (\s ctx -> do
		ctx_filter_posting <-
			liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
			liftIO $ Filter.Read.read Filter.Read.filter_posting s
			>>= \f -> case f of
			 Left  ko -> Write.fatal c ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_posting}) $
		C.translate c Lang.Type_Filter_Posting) $
		C.translate c Lang.Help_Option_Filter_Posting
	, Option "t" ["filter-transaction"]
	 (ReqArg (\s ctx -> do
		ctx_filter_transaction <-
			liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
			liftIO $ Filter.Read.read Filter.Read.filter_transaction s
			>>= \f -> case f of
			 Left  ko -> Write.fatal c ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_transaction}) $
		C.translate c Lang.Type_Filter_Transaction) $
		C.translate c Lang.Help_Option_Filter_Transaction
	, Option "h" ["help"]
	 (NoArg (\_ctx -> do
		usage c >>= IO.hPutStr IO.stderr
		exitSuccess)) $
		C.translate c Lang.Help_Option_Help
	, Option "i" ["input"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_input=s:ctx_input ctx}) $
		C.translate c Lang.Type_File_Journal) $
		C.translate c Lang.Help_Option_Input
	, Option "o" ["output"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
		C.translate c Lang.Type_File) $
		C.translate c Lang.Help_Option_Output
	, Option "O" ["overwrite"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
		C.translate c Lang.Type_File) $
		C.translate c Lang.Help_Option_Overwrite
	{- NOTE: not used so far.
	, Option "" ["reduce-date"]
	 (OptArg (\arg ctx -> do
		ctx_reduce_date <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c $
			W.text "--reduce-date option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_reduce_date})
	  "[yes|no]")
	 "use advanced date reducer to speed up filtering"
	-}
	, Option "" ["redundant"]
	 (OptArg (\arg ctx -> do
		ctx_redundant <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c Lang.Error_Option_Balance_Redundant
		return $ ctx{ctx_redundant})
	  "[no|yes]") $
		C.translate c Lang.Help_Option_Balance_Redundant
	, Option "" ["heritage"]
	 (OptArg (\arg ctx -> do
		ctx_heritage <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c Lang.Error_Option_Balance_Heritage
		return $ ctx{ctx_heritage})
	  "[yes|no]") $
		C.translate c Lang.Help_Option_Balance_Heritage
	, Option "" ["total"]
	 (OptArg (\arg ctx -> do
		ctx_total_by_unit <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c Lang.Error_Option_Balance_Total
		return $ ctx{ctx_total_by_unit})
	  "[yes|no]") $
		C.translate c Lang.Help_Option_Balance_Total
	, Option "f" ["format"]
	 (ReqArg (\arg ctx -> do
		ctx_format_output <- case arg of
		 "table" -> return $ Format_Output_Table
		 "open"  -> return $ Format_Output_Transaction Lang.Exercise_Opening
		 "close" -> return $ Format_Output_Transaction Lang.Exercise_Closing
		 _       -> Write.fatal c Lang.Error_Option_Balance_Format
		return $ ctx{ctx_format_output})
	  "[table|close|open]") $
		C.translate c Lang.Help_Option_Balance_Format
	, Option "" ["eq"]
	 (ReqArg (\arg ctx -> do
		ctx_account_equilibrium <-
			fmap (\e -> (e, e)) $
			case Text.Parsec.runParser
				 (Account.Read.account <* Text.Parsec.eof)
				 () "" arg of
			 Right acct -> return acct
			 _          -> Write.fatal c Lang.Error_Option_Equilibrium
		return $ ctx{ctx_account_equilibrium}) $
		C.translate c Lang.Type_Account) $
		C.translate c Lang.Help_Option_Equilibrium
	, Option "" ["eq-credit"]
	 (ReqArg (\arg ctx -> do
		ctx_account_equilibrium <-
			fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
			case Text.Parsec.runParser
				 (Account.Read.account <* Text.Parsec.eof)
				 () "" arg of
			 Right acct -> return acct
			 _          -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
		return $ ctx{ctx_account_equilibrium}) $
		C.translate c Lang.Type_Account) $
		C.translate c Lang.Help_Option_Equilibrium_Credit
	, Option "" ["eq-debit"]
	 (ReqArg (\arg ctx -> do
		ctx_account_equilibrium <-
			fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
			case Text.Parsec.runParser
				 (Account.Read.account <* Text.Parsec.eof)
				 () "" arg of
			 Right acct -> return acct
			 _          -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
		return $ ctx{ctx_account_equilibrium}) $
		C.translate c Lang.Type_Account) $
		C.translate c Lang.Help_Option_Equilibrium_Debit
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <-
		first (\x ->
			case ctx_output x of
			 [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
			 _  -> x) <$>
		Args.parse c usage options (nil c, args)
	read_journals <-
		liftM Data.Either.partitionEithers $ do
		CLI.Ledger.paths c $ ctx_input ctx ++ inputs
		>>= do
			mapM $ \path -> do
				liftIO $ runExceptT $ Ledger.Read.file
				 (Ledger.Read.context ( ctx_filter_transaction ctx
				                      , ctx_filter_posting     ctx )
				                      Ledger.journal)
				 path
				>>= \x -> case x of
				 Left  ko -> return $ Left (path, ko)
				 Right ok -> return $ Right ok
	case read_journals of
	 (errs@(_:_), _journals) ->
		forM_ errs $ \(_path, err) -> do
			Write.fatal c $ err
	 ([], journals) -> do
		Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
		Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
		Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
		let lang = C.lang c
		case ctx_format_output ctx of
		 Format_Output_Transaction oc -> do
			now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now
			let sty = Write.style
				 { Write.style_pretty = True -- ctx_align ctx
				 }
			Write.write c sty (ctx_output ctx) $ do
			Ledger.Write.transactions $ do
				let (chart, bal) = ledger_balance_by_account ctx journals
				let balance_by_account = ledger_balance_by_account_filter ctx (chart, bal)
				let Balance.Balance_by_Unit balance_by_unit =
					ledger_balance_by_unit ctx balance_by_account
				let equilibrium_postings =
					Data.Map.foldlWithKey
					 (\acc unit bu ->
						let amt =
							(case oc of
							 Lang.Exercise_Closing -> id
							 Lang.Exercise_Opening -> negate) $
							Amount.sum_balance $
							Balance.unit_sum_amount bu in
						case Amount.sign amt of
						 LT ->
							(Ledger.posting $ snd $ ctx_account_equilibrium ctx)
							 { Ledger.posting_amounts  = Data.Map.singleton unit amt
							 , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]
							 }:acc
						 EQ -> acc
						 GT ->
							(Ledger.posting $ fst $ ctx_account_equilibrium ctx)
							 { Ledger.posting_amounts  = Data.Map.singleton unit amt
							 , Ledger.posting_comments = [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]
							 }:acc
					 )
					 mempty
					 balance_by_unit
				[Ledger.transaction
				 { Ledger.transaction_description=
					Lang.translate lang (Lang.Description_Exercise oc)
				 , Ledger.transaction_dates=(now, [])
				 , Ledger.transaction_postings=
					Data.Map.unionWith mappend
					 (Ledger.posting_by_Account equilibrium_postings)
					 (TreeMap.flatten_with_Path
						 (\posting_account (Balance.Account_Sum amount_by_unit) ->
							[(Ledger.posting posting_account)
							 { Ledger.posting_amounts =
								flip fmap amount_by_unit $
									(case oc of
									 Lang.Exercise_Closing -> negate
									 Lang.Exercise_Opening -> id)
									. Amount.sum_balance
							 }
							]
						 )
						 balance_by_account
					 )
				 }]
		 Format_Output_Table -> do
			let ( table_balance_by_account
				  , Balance.Balance_by_Unit balance_by_unit
				  ) =
				let (ch, bal) = ledger_balance_by_account ctx journals in
				if ctx_heritage ctx
				then
					let balance_filtered = ledger_balance_by_account_expanded ctx ch bal in
					( table_by_account ctx Balance.inclusive balance_filtered
					, ledger_balance_by_unit_expanded ctx    balance_filtered
					)
				else
					let balance_filtered = ledger_balance_by_account_filter ctx (ch, bal) in
					( table_by_account       ctx id balance_filtered
					, ledger_balance_by_unit ctx    balance_filtered
					)
			let sty = Write.style { Write.style_pretty = True }
			Write.write c sty (ctx_output ctx) $ do
			toDoc () $ do
			zipWith id
			 [ Table.column (Lang.translate lang Lang.Title_Debit)   Table.Align_Right
			 , Table.column (Lang.translate lang Lang.Title_Credit)  Table.Align_Right
			 , Table.column (Lang.translate lang Lang.Title_Balance) Table.Align_Right
			 , Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left
			 ] $ do
				table_balance_by_account $ do
				case ctx_total_by_unit ctx of
				 False -> repeat []
				 True -> do
					zipWith (:)
					 [ Table.Cell_Line '=' 0
					 , Table.Cell_Line '=' 0
					 , Table.Cell_Line '=' 0
					 , Table.Cell_Line ' ' 0
					 ] $ do
					flip table_by_unit (repeat []) $
						Data.Map.map
						 Balance.unit_sum_amount
						 balance_by_unit

ledger_balance_by_account
 :: Ctx
 -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount))
                            (Chart, Ledger.Transaction)) ]
 -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount))
ledger_balance_by_account _ctx =
	Data.Foldable.foldl'
	 (flip (\j ->
		flip mappend $
		(Ledger.journal_chart j,) $
		Ledger.Journal.fold
		 (\Ledger.Journal
			 { Ledger.journal_sections=Const b
			 } -> mappend b
		 ) j mempty
	 ))
	 mempty

ledger_balance_by_account_filter
 :: Ctx
 -> (Chart, Balance.Balance_by_Account (Amount.Sum Amount))
 -> Balance.Balance_by_Account (Amount.Sum Amount)
ledger_balance_by_account_filter ctx (chart, balance) =
	case Filter.simplified $ ctx_filter_balance ctx of
	 Right True ->
		if ctx_redundant ctx
		then balance
		else TreeMap.filter_with_Path_and_Node (const . is_worth) balance
	 Right False -> mempty
	 Left flt ->
		TreeMap.filter_with_Path_and_Node
		 (\node acct bal ->
			(is_worth node bal &&) $
			Data.Foldable.any
			 (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $
			Balance.get_Account_Sum bal)
		 balance
	where
		is_worth node bal =
			let _descendants = TreeMap.nodes
				 (TreeMap.node_descendants node) in
			ctx_redundant ctx
			-- NOTE: worth if no descendant
			-- but Account's exclusive
			-- has at least a non-zero Amount
			|| Data.Foldable.any
				 (not . Amount.is_zero . Amount.sum_balance)
				 (Balance.get_Account_Sum bal)

ledger_balance_by_account_expanded
 :: Ctx
 -> Chart
 -> Balance.Balance_by_Account (Amount.Sum Amount)
 -> Balance.Expanded           (Amount.Sum Amount)
ledger_balance_by_account_expanded ctx chart =
	case Filter.simplified $ ctx_filter_balance ctx of
	 Right True  ->
		if ctx_redundant ctx
		then id
		else TreeMap.filter_with_Path_and_Node (const . is_worth)
	 Right False -> const mempty
	 Left flt ->
		TreeMap.filter_with_Path_and_Node
		 (\node acct bal ->
			(is_worth node bal &&) $
			Data.Foldable.any
			 (Filter.test flt . ((acct, Chart.account_tags acct chart),)) $
				Balance.get_Account_Sum $
				Balance.inclusive bal)
	. Balance.expanded
	where
		is_worth node bal =
			let descendants = TreeMap.nodes
				 (TreeMap.node_descendants node) in
			ctx_redundant ctx
			-- NOTE: worth if no descendant
			-- but Account's inclusive
			-- has at least a non-zero Amount
			|| (Data.Map.null descendants
				 && Data.Foldable.any
					 (not . Amount.is_zero . Amount.sum_balance)
					 (Balance.get_Account_Sum $ Balance.inclusive bal))
			-- NOTE: worth if Account's exclusive
			-- has at least a non-zero Amount
			|| (Data.Foldable.any
				 (not . Amount.is_zero . Amount.sum_balance)
				 (Balance.get_Account_Sum $ Balance.exclusive bal))
			-- NOTE: worth if Account has at least more than
			-- one descendant Account whose inclusive
			-- has at least a non-zero Amount
			|| Data.Map.size
				 ( Data.Map.filter
					 ( Strict.maybe False
						 ( Data.Foldable.any
							 (not . Amount.is_zero . Amount.sum_balance)
						 . Balance.get_Account_Sum
						 . Balance.inclusive )
					 . TreeMap.node_value )
					 descendants
				 ) > 1

ledger_balance_by_unit
 :: Ctx
 -> Balance.Balance_by_Account (Amount.Sum Amount)
 -> Balance.Balance_by_Unit    (Amount.Sum Amount)
ledger_balance_by_unit _ctx =
	flip Balance.by_unit_of_by_account mempty

ledger_balance_by_unit_expanded
 :: Ctx
 -> Balance.Expanded        (Amount.Sum Amount)
 -> Balance.Balance_by_Unit (Amount.Sum Amount)
ledger_balance_by_unit_expanded _ctx =
	flip Balance.by_unit_of_expanded mempty

table_by_account
 :: Ctx
 -> (amount -> Balance.Account_Sum (Amount.Sum Amount))
 -> TreeMap Account.Account_Section amount
 -> [[Table.Cell]]
 -> [[Table.Cell]]
table_by_account _ctx get_Account_Sum =
	let posting_type = Posting.Posting_Type_Regular in
	flip $ TreeMap.foldr_with_Path
	 (\account balance rows ->
		foldr
		 (\(amount_positive, amount_negative, amount) ->
			zipWith (:)
				[ Table.cell
				 { Table.cell_content = maybe W.empty Amount.Write.amount  amount_positive
				 , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_positive
				 }
				, Table.cell
				 { Table.cell_content = maybe W.empty Amount.Write.amount  amount_negative
				 , Table.cell_width   = maybe 0 Amount.Write.amount_length amount_negative
				 }
				, Table.cell
				 { Table.cell_content = Amount.Write.amount        $ amount
				 , Table.cell_width   = Amount.Write.amount_length $ amount
				 }
				, Table.cell
				 { Table.cell_content = Ledger.Write.account        posting_type account
				 , Table.cell_width   = Ledger.Write.account_length posting_type account
				 }
				]
		 )
		 rows $
		let bal = Balance.get_Account_Sum $ get_Account_Sum balance in
		Data.Map.foldrWithKey
		 (\unit amount acc ->
			( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
			, maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
			, Amount.sum_balance amount
			) : acc
		 ) [] $ bal
	 )

table_by_unit
 :: Data.Map.Map Unit (Amount.Sum Amount)
 -> [[Table.Cell]]
 -> [[Table.Cell]]
table_by_unit =
	flip $ foldr
	 (\amount_sum ->
		zipWith (:)
			[ let amt = Amount.sum_positive amount_sum in
				Table.cell
				 { Table.cell_content = maybe W.empty Amount.Write.amount  amt
				 , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
				 }
			, let amt = Amount.sum_negative amount_sum in
				Table.cell
				 { Table.cell_content = maybe W.empty Amount.Write.amount  amt
				 , Table.cell_width   = maybe 0 Amount.Write.amount_length amt
				 }
			, let amt = Amount.sum_balance amount_sum in
				Table.cell
				 { Table.cell_content = Amount.Write.amount        amt
				 , Table.cell_width   = Amount.Write.amount_length amt
				 }
			, Table.cell
				 { Table.cell_content = W.empty
				 , Table.cell_width   = 0
				 }
			]
	 )