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

import           Control.Applicative ((<$>))
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 qualified Data.Sequence
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import           Prelude hiding (foldr)
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 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           Hcompta.Date (Date)
import qualified Hcompta.Date.Write as Date.Write
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.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
import           Hcompta.GL (GL(..))
import qualified Hcompta.GL as GL

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
 , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_input              = []
	 , ctx_transaction_filter = Filter.Any
	 , ctx_posting_filter     = Filter.Any
	 }

usage :: IO String
usage = do
	bin <- Env.getProgName
	return $ unlines $
		[ "SYNTAX "
		, "  "++bin++" gl [-t TRANSACTION_FILTER] [-p POSTING_FILTER] GL_FILTER"
		, ""
		, 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, multiple uses merge the data as would a concatenation do"
	, Option "p" ["posting-filter"]
	 (ReqArg (\s context ctx -> do
		ctx_posting_filter <-
			fmap (Filter.And $ ctx_posting_filter ctx) $
			liftIO $ Filter.Read.read Filter.Read.test_posting s
			>>= \f -> case f of
			 Left  ko -> Write.fatal context $ ko
			 Right ok -> return ok
		return $ ctx{ctx_posting_filter}) "FILTER")
	 "filter at posting level, multiple uses are merged with a logical and"
	, Option "t" ["transaction-filter"]
	 (ReqArg (\s context ctx -> do
		ctx_transaction_filter <-
			fmap (Filter.And $ ctx_transaction_filter ctx) $
			liftIO $ Filter.Read.read Filter.Read.test_transaction s
			>>= \f -> case f of
			 Left  ko -> Write.fatal context $ ko
			 Right ok -> return ok
		return $ ctx{ctx_transaction_filter}) "FILTER")
	 "filter at transaction level, multiple uses are merged with a logical and"
	]

run :: Context.Context -> [String] -> IO ()
run context args = do
	(ctx, text_filters) <- Args.parse context usage options (nil, args)
	read_journals <- 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 read_journals of
	 (errs@(_:_), _journals) ->
		(flip mapM_) errs $ \(_path, err) -> do
			Write.fatal context $ err
	 ([], journals) -> do
		gl_filter <-
			foldr Filter.And Filter.Any <$> do
			(flip mapM) text_filters $ \s ->
				liftIO $ Filter.Read.read
				 Filter.Read.test_gl
				  s
				>>= \f -> case f of
				 Left  ko -> Write.fatal context $ ko
				 Right ok -> return ok
		Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
		Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
		Write.debug context $ "gl_filter: " ++ show gl_filter
		let gl =
			ledger_gl
			 (ctx_transaction_filter ctx)
			 (ctx_posting_filter ctx)
			 gl_filter
			 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_Account)         Table.Align_Left
				, Table.column (title Lang.Message_Date)            Table.Align_Left
				, Table.column (title Lang.Message_Debit)           Table.Align_Right
				, Table.column (title Lang.Message_Credit)          Table.Align_Right
				, Table.column (title Lang.Message_Running_debit)   Table.Align_Right
				, Table.column (title Lang.Message_Running_credit)  Table.Align_Right
				, Table.column (title Lang.Message_Running_balance) Table.Align_Right
				, Table.column (title Lang.Message_Description)     Table.Align_Left
				] $
				write_gl gl (repeat [])

ledger_gl
 :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
 -> Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
 -> Filter.Test_Bool (Filter.Test_GL    (Account, Date, Amount.Sum Amount, Amount.Sum Amount))
 -> [Ledger.Journal]
 -> GL Ledger.Transaction
ledger_gl
 transaction_filter
 posting_filter
 gl_filter
 journals =
	let gl =
		Data.Foldable.foldl
		 (\jr j ->
			Data.Foldable.foldl
			 (\tr t ->
				case Filter.test transaction_filter t of
				 False -> tr
				 True ->
					GL.general_ledger
					 t{ Ledger.transaction_postings =
						Data.Map.map
						 (Data.Foldable.foldMap
							 (\p ->
								Data.Map.foldrWithKey
								 (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
								 []
								 (Ledger.posting_amounts p)
							 )
						 ) $
						Data.Map.mapMaybe
						 (\ps -> case Data.List.filter (Filter.test posting_filter) ps of
							 [] -> Nothing
							 x  -> Just x)
						 (Ledger.transaction_postings t)
					 }
					 tr
			 )
			jr (Compose $ Ledger.journal_transactions j)
		 )
		 GL.nil
		 journals in
	GL.GL $
	Lib.TreeMap.map_Maybe_with_Path
	 (\acct expanded_lines ->
		case Data.Map.mapMaybeWithKey
		 (\date seq_lines ->
			case Data.Foldable.foldMap
			 (\line@GL.GL_Line
			 { GL.gl_line_transaction = _t
			 , GL.gl_line_posting     = p
			 , GL.gl_line_sum         = s
			 } ->
				if Filter.test gl_filter
				 ( acct
				 , date
				 , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
				 , snd . Data.Map.elemAt 0 <$> s
				 )
				then Data.Sequence.singleton line
				else Data.Sequence.empty
			 ) seq_lines of
			 m | Data.Sequence.null m -> Nothing
			 m -> Just m
		 )
		 (GL.inclusive expanded_lines) of
			m | Data.Map.null m -> Nothing
			m -> Just m
		) $
	GL.expanded gl

write_gl
 :: GL Ledger.Transaction
 -> [[Table.Cell]]
 -> [[Table.Cell]]
write_gl (GL gl) =
	flip (Lib.TreeMap.foldr_with_Path
	 (\acct ->
		flip $ Data.Map.foldrWithKey
		 (\date ->
			flip (Data.Foldable.foldr
			 (\GL.GL_Line
				 { GL.gl_line_transaction = t
				 , GL.gl_line_posting     = p
				 , GL.gl_line_sum         = s
				 } ->
				flip (Data.Map.foldrWithKey
				 (\unit amt -> do
					let ptype = Ledger.Posting_Type_Regular
					let descr = Ledger.transaction_description t
					zipWith (:)
						[ Table.cell
						 { Table.cell_content = Ledger.Write.account        ptype acct
						 , Table.cell_width   = Ledger.Write.account_length ptype acct
						 }
						, Table.cell
						 { Table.cell_content = Date.Write.date        date
						 , Table.cell_width   = Date.Write.date_length date
						 }
						, Table.cell
						 { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_positive amt)
						 , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_positive amt)
						 }
						, Table.cell
						 { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_negative amt)
						 , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_negative amt)
						 }
						, Table.cell
						 { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
						 , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
						 }
						, Table.cell
						 { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
						 , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
						 }
						, Table.cell
						 { Table.cell_content = maybe W.empty Amount.Write.amount        (Data.Map.lookup unit $ Amount.sum_balance s)
						 , Table.cell_width   = maybe 0       Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
						 }
						, Table.cell
						 { Table.cell_content = toDoc ()    descr
						 , Table.cell_width   = Text.length descr
						 }
						]
				 ))
				 (Ledger.posting_amounts p)
			 ))
		 )
	 ))
	 gl