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

import           Prelude hiding (foldr)
import           Control.Monad (liftM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import qualified Data.Foldable
import           Data.Foldable (foldr)
import           Data.Functor.Compose (Compose(..))
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import           Data.Monoid ((<>))
import qualified Data.Text.Lazy as TL
import           System.Console.GetOpt
                 ( ArgDescr(..)
                 , OptDescr(..)
                 , usageInfo
                 )
import           System.Environment as Env (getProgName)
import           System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO

import           Hcompta.Account (Account)
import           Hcompta.Amount (Amount)
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Amount.Write as Amount.Write
import           Hcompta.Amount.Unit (Unit)
import qualified Hcompta.Balance as Balance
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as Context
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.Filter as Filter
import qualified Hcompta.Filter.Reduce as Filter.Reduce
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 qualified Hcompta.Lib.TreeMap as Lib.TreeMap

data Ctx
 =   Ctx
 { ctx_filter_balance     :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Balance
                             (Account, Amount.Sum Amount)))
 , ctx_filter_posting     :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Posting
                             Ledger.Posting))
 , ctx_filter_transaction :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Transaction
                             Ledger.Transaction))
 , ctx_input              :: [FilePath]
 , ctx_reduce_date        :: Bool
 , ctx_redundant          :: Bool
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_filter_balance     = mempty
	 , ctx_filter_posting     = mempty
	 , ctx_filter_transaction = mempty
	 , ctx_input              = []
	 , ctx_reduce_date        = True
	 , ctx_redundant          = False
	 }

usage :: IO String
usage = do
	bin <- Env.getProgName
	return $ unlines $
		[ "SYNTAX "
		, "  "++bin++" balance"
		, " [-t TRANSACTION_FILTER]"
		, " [-p POSTING_FILTER]"
		, " [-b BALANCE_FILTER]"
		, " JOURNAL_FILE [...]"
		, ""
		, usageInfo "OPTIONS" options
		]

options :: Args.Options Ctx
options =
	[ Option "b" ["filter-balance"]
	 (ReqArg (\s context ctx -> do
		ctx_filter_balance <-
			liftM (\t -> (<>) (ctx_filter_balance ctx)
			 (Filter.simplify t (Nothing::Maybe (Account, Amount.Sum Amount)))) $
				liftIO $ Filter.Read.read Filter.Read.filter_balance s
				>>= \f -> case f of
				 Left  ko -> Write.fatal context $ ko
				 Right ok -> return ok
		return $ ctx{ctx_filter_balance}) "FILTER")
	 "filter at balance level, multiple uses are merged with a logical AND"
	, Option "p" ["filter-posting"]
	 (ReqArg (\s context ctx -> do
		ctx_filter_posting <-
			liftM (\t -> (<>) (ctx_filter_posting ctx)
			 (Filter.simplify t (Nothing::Maybe Ledger.Posting))) $
			liftIO $ Filter.Read.read Filter.Read.filter_posting s
			>>= \f -> case f of
			 Left  ko -> Write.fatal context $ ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_posting}) "FILTER")
	 "filter at posting level, multiple uses are merged with a logical AND"
	, Option "t" ["filter-transaction"]
	 (ReqArg (\s context ctx -> do
		ctx_filter_transaction <-
			liftM (\t -> (<>) (ctx_filter_transaction ctx)
			 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
			liftIO $ Filter.Read.read Filter.Read.filter_transaction s
			>>= \f -> case f of
			 Left  ko -> Write.fatal context $ ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_transaction}) "FILTER")
	 "filter at transaction level, multiple uses are merged with a logical AND"
	, Option "h" ["help"]
	 (NoArg (\_context _ctx -> do
		usage >>= IO.hPutStr IO.stderr
		exitWith ExitSuccess))
	 "show this help"
	, Option "i" ["input"]
	 (ReqArg (\s _context ctx -> do
		return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
	 "read data from given file, multiple uses merge the data as would a concatenation do"
	, Option "" ["reduce-date"]
	 (OptArg (\arg context ctx -> do
		ctx_reduce_date <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			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 context ctx -> do
		ctx_redundant <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			W.text "--redundant option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_redundant})
	  "[yes|no]")
	 "also print accounts with zero amount or the same amounts than its ascending account"
	]

run :: Context.Context -> [String] -> IO ()
run context args = do
	(ctx, inputs) <- Args.parse context usage options (nil, args)
	read_journals <- do
		CLI.Ledger.paths context $ ctx_input ctx ++ inputs
		>>= do
			mapM $ \path -> do
				liftIO $ runExceptT $ Ledger.Read.file path
				>>= \x -> case x of
				 Left  ko -> return $ Left (path, ko)
				 Right ok -> return $ Right ok
		>>= return . Data.Either.partitionEithers
	case read_journals of
	 (errs@(_:_), _journals) ->
		(flip mapM_) errs $ \(_path, err) -> do
			Write.fatal context $ err
	 ([], journals) -> do
		Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
		Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
		Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
		let (balance_by_account, balance_by_unit) =
			ledger_balances ctx journals
		style_color <- Write.with_color context IO.stdout
		W.displayIO IO.stdout $
		 W.renderPretty style_color 1.0 maxBound $ do
			toDoc () $
				let title =
					TL.toStrict . W.displayT .
					W.renderCompact False .
					toDoc (Context.lang context) in
				zipWith id
				[ Table.column (title Lang.Message_Debit)   Table.Align_Right
				, Table.column (title Lang.Message_Credit)  Table.Align_Right
				, Table.column (title Lang.Message_Balance) Table.Align_Right
				, Table.column (title Lang.Message_Account) Table.Align_Left
				] $
				write_by_accounts ctx balance_by_account $
				zipWith (:)
					[ Table.Cell_Line '=' 0
					, Table.Cell_Line '=' 0
					, Table.Cell_Line '=' 0
					, Table.Cell_Line ' ' 0
					] $
				flip write_by_amounts (repeat []) $
					Data.Map.map
					 Balance.unit_sum_amount
					 balance_by_unit

ledger_balances
 :: Ctx
 -> [Ledger.Journal]
 -> ( Balance.Expanded (Amount.Sum Amount)
    , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
ledger_balances ctx journals =
	let reducer_date =
		if ctx_reduce_date ctx
		then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
		else mempty in
	let balance_by_account =
		foldr
		 (Ledger.Journal.fold
			 (\Ledger.Journal{Ledger.journal_transactions=ts} ->
				flip (foldr
				 (\tr ->
					case Filter.test
					 (Filter.simplify (ctx_filter_transaction ctx)
					 (Nothing::Maybe Ledger.Transaction)) tr of
					 False -> id
					 True ->
						let filter_postings =
							Data.Foldable.concatMap $
							Data.List.filter $
							(Filter.test $ ctx_filter_posting ctx) in
						let balance =
							flip (foldr Balance.by_account) .
							map (\p ->
								( Ledger.posting_account p
								, Data.Map.map Amount.sum (Ledger.posting_amounts p)
								)) .
							filter_postings in
						balance (Ledger.transaction_postings tr) .
						balance (Ledger.transaction_virtual_postings tr) .
						balance (Ledger.transaction_balanced_virtual_postings tr)
				 )) $ Compose $ Compose $
				case Filter.simplified reducer_date of
				 Left reducer -> do
					let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
					ts_reduced
				 Right True  -> ts:[]
				 Right False -> []
			 )
		 )
		 (Balance.balance_by_account Balance.nil)
		 journals in
	let balance_expanded =
		Lib.TreeMap.filter_with_Path_and_Node
		 (\node acct balance ->
			let descendants = Lib.TreeMap.nodes
				 (Lib.TreeMap.node_descendants node) in
			let is_worth =
				ctx_redundant ctx
				-- NOTE: worth if no descendant
				-- but account inclusive
				-- has at least a non-zero amount
				|| (Data.Map.null descendants && not
					 (Data.Map.null
					 (Data.Map.filter
						 (not . Amount.is_zero . Amount.sum_balance)
						 (Balance.inclusive balance))))
				-- NOTE: worth if account exclusive
				-- has at least a non-zero amount
				|| not (Data.Map.null
					 (Data.Map.filter
						 (not . Amount.is_zero . Amount.sum_balance)
						 (Balance.exclusive balance)))
				-- 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
						 ( maybe False
							 ( not . Data.Foldable.all
								 ( Amount.is_zero
								 . Amount.sum_balance )
							 . Balance.inclusive )
						 . Lib.TreeMap.node_value )
						 descendants) > 1
			in
			if is_worth
			then
				Data.Foldable.any
				 (Filter.test (ctx_filter_balance ctx) . (acct,)) $
				Balance.inclusive balance
			else False
		 ) $
		Balance.expanded balance_by_account in
	let balance_by_unit =
		Balance.by_unit_of_expanded
		 balance_expanded
		 (Balance.balance_by_unit Balance.nil) in
	( balance_expanded
	, balance_by_unit
	)

write_by_accounts
 :: Ctx
 -> Balance.Expanded (Amount.Sum Amount)
 -> [[Table.Cell]]
 -> [[Table.Cell]]
write_by_accounts _ctx =
	let posting_type = Ledger.Posting_Type_Regular in
	flip $ Lib.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.inclusive 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
	 )

write_by_amounts
 :: Data.Map.Map Unit (Amount.Sum Amount)
 -> [[Table.Cell]]
 -> [[Table.Cell]]
write_by_amounts =
	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
				 }
			]
	 )