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

import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import qualified Data.Foldable
import qualified Data.List
import qualified Data.Map
import qualified Data.Text.Lazy as TL
import qualified Data.Text as Text
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           Text.Show.Pretty (ppShow) -- TODO: may be not necessary

import qualified Hcompta.Calc.Balance as Balance
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as Context
import           Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
import qualified Hcompta.CLI.Lib.Shakespeare.Leijen as I18N
import qualified Hcompta.CLI.Lib.Leijen.Table as Table
import qualified Hcompta.CLI.Write as Write
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 qualified Hcompta.Lib.TreeMap as Lib.TreeMap
import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
import qualified Hcompta.Model.Amount as Amount
import           Hcompta.Model.Amount (Amount, Unit)

data Ctx
 =   Ctx
 { ctx_input     :: [FilePath]
 , ctx_redundant :: Bool
 } deriving (Eq, Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_input     = []
	 , ctx_redundant = False
	 }

usage :: IO String
usage = do
	bin <- Env.getProgName
	return $ unlines $
		[ "SYNTAX "
		, "  "++bin++" balance [option..]"
		, ""
		, usageInfo "OPTIONS" options
		]

options :: Args.Options Ctx
options =
	[ 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, can be use multiple times"
	, Option "" ["redundant"]
	 (OptArg (\arg context ctx -> do
		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=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, _) <- Args.parse context usage options (nil, args)
	koks <- do
		CLI.Ledger.paths context $ ctx_input ctx
		>>= 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 koks of
	 (kos@(_:_), _oks) ->
		(flip mapM_) kos $ \(_path, ko) -> do
			Write.debug context $ ppShow $ ko
			Write.fatal context $ toDoc context ko
	 ([], journals) -> do
		let balance =
			Data.List.foldr
			 (Ledger.Journal.fold
				 (flip (Data.Foldable.foldr
					 (flip (Data.Foldable.foldr
						 ( flip Balance.union
						 . Ledger.transaction_postings_balance))))
				 . Ledger.journal_transactions))
			 Balance.balance
			 journals
		let expanded = Balance.expanded $ Balance.balance_by_account balance
		let by_accounts_columns = write_by_accounts context ctx expanded
		style_color <- Write.with_color context IO.stdout
		Ledger.Write.put Ledger.Write.Style
		 { Ledger.Write.style_align = True
		 , Ledger.Write.style_color
		 } IO.stdout $ do
			toDoc () by_accounts_columns <> do
			case by_accounts_columns of
			 [col_balance, _col_account] ->
				(W.bold $ W.dullblack $ do
					W.text (TL.pack $ replicate
					 (foldr ((+) . (2 +) . Table.column_width)
						 (length by_accounts_columns - 1)
						 by_accounts_columns) '=') <> W.line) <> do
				toDoc () $ write_by_amounts (Table.column_width col_balance) $
					Data.Map.map
					 Balance.unit_sum_amount
					 (Balance.balance_by_unit balance)
			 _ -> error "Oops, should not happen: Hcompta.CLI.Command.Balance"

write_by_accounts
 :: Context -> Ctx
 -> Balance.Expanded Amount Unit
 -> [Table.Column]
write_by_accounts context ctx =
	let posting_type = Ledger.Posting_Type_Regular in
	let title = TL.toStrict . W.displayT . W.renderCompact False .
		I18N.renderMessage Context.App (Context.langs context) in
	zipWith id
	[ Table.column (title Write.I18N_Balance) Table.Align_Right
	, Table.column (title Write.I18N_Account) Table.Align_Left
	] .
	Lib.TreeMap.foldr_with_Path_and_Node
	 (\account node amounts rows -> do
		let descendants = Lib.TreeMap.nodes
			 (Lib.TreeMap.node_descendants node)
		let is_worth =
			ctx_redundant ctx
			|| Data.Map.size
				 (Data.Map.filter
					 (not . Amount.is_zero)
					 (Balance.exclusive amounts)) > 0
			|| Data.Map.size
				 (Data.Map.filter
					 ( maybe False (not . Amount.are_zero . Balance.inclusive)
					 . Lib.TreeMap.node_value )
					 descendants) > 1
		case is_worth of
		 False -> rows
		 True ->
			Data.Map.foldr
			 (\amount ->
				zipWith id
					[ (:) Table.cell
					 { Table.cell_content = Ledger.Write.amount amount
					 , Table.cell_width   = Ledger.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
			 (Balance.inclusive amounts)
	 )
	 (repeat [])

write_by_amounts
 :: Int
 -> Amount.By_Unit
 -> [Table.Column]
write_by_amounts min_col_width =
	zipWith id
	[ (\col_content ->
		let col = Table.column Text.empty Table.Align_Right col_content in
		col{Table.column_width = max min_col_width $ Table.column_width col})
	] .
	Data.Map.foldr
	 (\amount ->
		zipWith id
			[ (:) Table.cell
			 { Table.cell_content = Ledger.Write.amount amount
			 , Table.cell_width   = Ledger.Write.amount_length amount
			 }
			]
	 )
	 (repeat [])