{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
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           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)

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.Write as Write
import qualified Hcompta.Calc.Balance as Balance
import qualified Hcompta.Format.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 ((<>))
import qualified Hcompta.Model.Amount as Amount
import qualified Hcompta.Model.Transaction.Posting as Posting
-- import qualified Hcompta.Format.Ledger.Write

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
			 "--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) ->
			Write.fatal context $ ko
	 ([], journals) -> do
		CLI.Ledger.equilibre context journals
		let balance =
			Data.List.foldl
			 (\b j -> Balance.journal_with_virtual
				 (Hcompta.Format.Ledger.Journal.to_Model j) b)
			 Balance.nil
			 journals
		Write.debug context $ ppShow $ balance
		Write.debug context $ ppShow $
			Lib.TreeMap.flatten (const ()) (Balance.by_account balance)
		let expanded = Balance.expand $ Balance.by_account balance
		Write.debug context $ ppShow $ expanded
		with_color <- Write.with_color context IO.stdout
		Ledger.Write.put with_color IO.stdout $ do
			let (max_amount_length, accounts) = write_accounts ctx expanded
			accounts <> do
			(if W.is_empty accounts
				then W.empty
				else (W.bold $ W.dullblack $
					W.text (TL.pack $ replicate max_amount_length '-') <>
					(if max_amount_length <= 0 then W.empty else W.line))) <> do
			write_amounts max_amount_length $
				Data.Map.map Balance.amount $
				(Balance.by_unit balance)

write_accounts :: Ctx -> Balance.Expanded -> (Int, W.Doc)
write_accounts ctx accounts = do
	let max_amount_length =
		uncurry (+) $
		Data.Foldable.foldl
		 (\(len, plus) Balance.Account_Sum_Expanded{Balance.inclusive=amounts} ->
			let amounts_ = (if ctx_redundant ctx then amounts else Data.Map.filter (not . Amount.is_zero) amounts) in
			( Data.Map.foldr (max . Ledger.Write.amount_length) len amounts
			, (if Data.Map.size amounts_ > 1
				then 2 -- NOTE: length "+ "
				else plus)
			)
		 )
		 (0, 0) accounts
	(max_amount_length,) $ do
	Lib.TreeMap.foldl_with_Path_and_Node
	 (\doc account node amounts ->
		let descendants = Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node) in
		if not (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
		 )
		then doc
		else
			doc <> Data.Map.foldl
			 (\doc_ amount ->
				if not (ctx_redundant ctx) && Amount.is_zero amount
				then doc_
				else
					doc_ <>
					(if W.is_empty doc_
					then do
						W.fill (max_amount_length - Ledger.Write.amount_length amount) W.empty <> do
						Ledger.Write.amount amount <> do
						W.space <> W.space <> do
						Ledger.Write.account Posting.Type_Regular account
					else do
						(W.bold $ W.dullblack $ W.text "+" <> W.space) <> do
						W.fill (max_amount_length - Ledger.Write.amount_length amount - 2) W.empty <> do
						Ledger.Write.amount amount) <> do
					W.line
			 ) W.empty (Balance.inclusive amounts)
	 )
	 W.empty accounts

write_amounts :: Int -> Amount.By_Unit -> W.Doc
write_amounts max_amount_length_ amounts = do
	let max_amount_length =
		Data.Map.foldr
		 (max . Ledger.Write.amount_length)
		 max_amount_length_ amounts
	(if Data.Map.size amounts > 1
		then W.space <> W.space
		else W.empty) <> do
	W.intercalate
	 (W.line <> (W.bold $ W.dullblack $ W.text "+") <> W.space)
	 (\amount ->
		let len =
			max_amount_length
			- Ledger.Write.amount_length amount
			- (if Data.Map.size amounts > 1
				then 2 -- NOTE: length "+ "
				else 0) in
		W.fill len W.empty <> do
		Ledger.Write.amount amount)
	 amounts <> do
	(if Data.Map.null amounts then W.empty else W.line)