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

import           Control.Applicative ((<*), Const(..))
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, replicate)
import qualified Data.Map.Strict as Data.Map
import           Data.Maybe (Maybe(..), maybe)
import           Data.Monoid (Monoid(..), (<>))
import           Data.Ord (Ord(..))
import qualified Data.Strict.Maybe as Strict
import           Data.String (String)
import qualified Data.Text.Lazy as TL
import qualified Data.Time.Clock as Time
import           Prelude (($), (.), Bounded(..), 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 qualified Hcompta.CLI.Args as Args
import           Hcompta.CLI.Context (Context)
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.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

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_heritage            :: Bool
 , ctx_input               :: [FilePath]
 , ctx_reduce_date         :: Bool
 , ctx_redundant           :: Bool
 , ctx_total_by_unit       :: Bool
 , ctx_format_output       :: Format_Output
 , ctx_account_equilibrium :: Account
 } deriving (Show)

data Format_Output
 =   Format_Output_Table
 |   Format_Output_Transaction { negate_transaction :: Bool }
 deriving (Eq, Show)

nil :: Context -> Ctx
nil context =
	Ctx
	 { ctx_filter_balance      = mempty
	 , ctx_filter_posting      = mempty
	 , ctx_filter_transaction  = mempty
	 , ctx_heritage            = True
	 , ctx_input               = []
	 , ctx_reduce_date         = True
	 , ctx_redundant           = False
	 , ctx_total_by_unit       = True
	 , ctx_format_output       = Format_Output_Table
	 , ctx_account_equilibrium = Account.account
		 (TL.toStrict $ W.displayT $ W.renderOneLine False $
			toDoc (Context.lang context) Lang.Message_Equilibrium)
		 []
	 }

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

options :: Args.Options Ctx
options =
	[ Option "b" ["filter-balance"]
	 (ReqArg (\s context 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 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 ((ctx_filter_posting ctx <>) . Filter.simplify) $
			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 ((ctx_filter_transaction ctx <>) . Filter.simplify) $
			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
		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"
	{- NOTE: not used so far.
	, 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"
	, Option "" ["heritage"]
	 (OptArg (\arg context ctx -> do
		ctx_heritage <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			W.text "--heritage option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_heritage})
	  "[yes|no]")
	 "propagate amounts to ascending accounts"
	, Option "" ["total"]
	 (OptArg (\arg context ctx -> do
		ctx_total_by_unit <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			W.text "--total option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_total_by_unit})
	  "[yes|no]")
	 "calculate totals by unit"
	, Option "f" ["format"]
	 (ReqArg (\arg context ctx -> do
		ctx_format_output <- case arg of
		 "table" -> return $ Format_Output_Table
		 "open"  -> return $ Format_Output_Transaction False
		 "close" -> return $ Format_Output_Transaction True
		 _       -> Write.fatal context $
			W.text "--format option expects \"close\", \"open\", or \"table\" as value"
		return $ ctx{ctx_format_output})
	  "[close|open|table]")
	 "select output format"
	, Option "" ["equilibrium"]
	 (ReqArg (\arg context ctx -> do
		ctx_account_equilibrium <-
			case Text.Parsec.runParser
				 (Account.Read.account <* Text.Parsec.eof)
				 () "" arg of
			 Right acct -> return acct
			 _          -> Write.fatal context $
				W.text "--equilibrium option expects a valid account name"
		return $ ctx{ctx_account_equilibrium})
	  "ACCOUNT")
	 "specify account equilibrating a close or open balance"
	]

run :: Context.Context -> [String] -> IO ()
run context args = do
	(ctx, inputs) <- Args.parse context usage options (nil context, args)
	read_journals <-
		liftM Data.Either.partitionEithers $ do
		CLI.Ledger.paths context $ 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 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)
		style_color <- Write.with_color context IO.stdout
		case ctx_format_output ctx of
		 Format_Output_Transaction nt -> do
			let balance_by_account =
				ledger_balance_by_account_filter ctx $
				ledger_balance_by_account ctx journals
			let Balance.Balance_by_Unit balance_by_unit =
				ledger_balance_by_unit ctx $
				ledger_balance_by_account_filter ctx balance_by_account
			let posting_equilibrium =
				(Ledger.posting $ ctx_account_equilibrium ctx)
				 { Ledger.posting_amounts =
					flip Data.Map.map balance_by_unit $
						(if nt then id else negate)
						. Amount.sum_balance
						. Balance.unit_sum_amount
				 , Ledger.posting_comments=
					 [ TL.toStrict $ W.displayT $ W.renderOneLine False $
						toDoc (Context.lang context) $
						Lang.Message_Equilibrium_posting
					 ]
				 }
			now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now
			let transaction =
				Ledger.transaction
				 { Ledger.transaction_description=
					TL.toStrict $ W.displayT $ W.renderOneLine False $
					toDoc (Context.lang context) $
					Lang.Message_Balance_Description nt
				 , Ledger.transaction_dates=(now, [])
				 , Ledger.transaction_postings=
					(if Data.Map.null $ Ledger.posting_amounts posting_equilibrium
					then id
					else
						Data.Map.insertWith (++)
						 (ctx_account_equilibrium ctx)
						 [posting_equilibrium]) $
					TreeMap.flatten_with_Path
					 (\posting_account (Balance.Account_Sum amount_by_unit) ->
						[(Ledger.posting posting_account)
						 { Ledger.posting_amounts =
							flip fmap amount_by_unit $
								(if nt then negate else id)
								. Amount.sum_balance
						 }
						]
					 )
					 balance_by_account
				 }
			let sty = Ledger.Write.Style
				 { Ledger.Write.style_align = True -- ctx_align ctx
				 , Ledger.Write.style_color
				 }
			Ledger.Write.put sty IO.stdout $ do
			Ledger.Write.transaction transaction
		 Format_Output_Table -> do
			let ( table_balance_by_account
				  , Balance.Balance_by_Unit balance_by_unit
				  ) =
				case ledger_balance_by_account ctx journals of
				 b | ctx_heritage ctx ->
					let bb = ledger_balance_by_account_expanded ctx b in
					( table_by_account ctx Balance.inclusive bb
					, ledger_balance_by_unit_expanded ctx bb
					)
				 b ->
					let bb = ledger_balance_by_account_filter ctx b in
					( table_by_account ctx id bb
					, ledger_balance_by_unit ctx bb
					)
			W.displayIO IO.stdout $ do
			W.renderPretty style_color 1.0 maxBound $ do
			toDoc () $ do
			let title =
				TL.toStrict . W.displayT .
				W.renderCompact False .
				toDoc (Context.lang context)
			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
			 ] $ 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)) Ledger.Transaction) ]
 -> Balance.Balance_by_Account (Amount.Sum Amount)
ledger_balance_by_account _ctx =
	Data.Foldable.foldl'
	 (flip $ Ledger.Journal.fold
		 (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
			mappend b))
	 mempty

ledger_balance_by_account_filter
 :: Ctx
 -> Balance.Balance_by_Account (Amount.Sum Amount)
 -> Balance.Balance_by_Account (Amount.Sum Amount)
ledger_balance_by_account_filter ctx =
	case Filter.simplified $ ctx_filter_balance ctx of
	 Right True -> id
	 Right False -> const mempty
	 Left flt ->
		TreeMap.filter_with_Path $ \acct ->
			Data.Foldable.any (Filter.test flt . (acct,)) .
			Balance.get_Account_Sum

ledger_balance_by_account_expanded
 :: Ctx
 -> Balance.Balance_by_Account (Amount.Sum Amount)
 -> Balance.Expanded           (Amount.Sum Amount)
ledger_balance_by_account_expanded ctx =
	case Filter.simplified $ ctx_filter_balance ctx of
	 Right True  -> id
	 Right False -> const mempty
	 Left flt ->
		TreeMap.filter_with_Path_and_Node
		 (\node acct balance ->
			let descendants = TreeMap.nodes
				 (TreeMap.node_descendants node) in
			let is_worth =
				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 balance)))
				-- 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 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
						 ( Strict.maybe False
							 ( Data.Foldable.any
								 (not . Amount.is_zero . Amount.sum_balance)
							 . Balance.get_Account_Sum
							 . Balance.inclusive )
						 . TreeMap.node_value )
						 descendants
					 ) > 1
			in
			(&&) is_worth $
			Data.Foldable.any (Filter.test flt . (acct,)) $
				Balance.get_Account_Sum $
				Balance.inclusive balance
		 )
	. Balance.expanded

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.Name 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
				 }
			]
	 )