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

import           Control.Applicative ((<$>))
import           Control.Arrow (first)
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.Foldable (Foldable(..))
import           Data.List ((++), repeat)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..), (<>))
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import           Data.String (String)
import qualified Data.Text as Text
import           Prelude (($), (.), FilePath, IO, id, flip, unlines, zipWith)
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 qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
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.Chart as Chart
import           Hcompta.Date (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.Amount as Ledger.Amount
import qualified Hcompta.Format.Ledger.Amount.Write as Amount.Write
import qualified Hcompta.Format.Ledger.Date.Write as Date.Write
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.GL (GL(..))
import qualified Hcompta.GL as GL
import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
import qualified Hcompta.Lib.TreeMap as TreeMap
import qualified Hcompta.Polarize as Polarize
import qualified Hcompta.Tag as Tag

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 , ctx_output             :: [(Write.Mode, FilePath)]
 , ctx_filter_transaction :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Transaction
                             (Ledger.Chart_With Ledger.Transaction)))
 , ctx_filter_posting     :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Posting
                             (Ledger.Chart_With Ledger.Posting)))
 , ctx_filter_gl          :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_GL
                             ( (Tag.Tags, Ledger.Account)
                             , Date
                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
 , ctx_reduce_date        :: Bool
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_filter_gl          = mempty
	 , ctx_filter_posting     = mempty
	 , ctx_filter_transaction = mempty
	 , ctx_input              = []
	 , ctx_output             = []
	 , ctx_reduce_date        = True
	 }

usage :: C.Context -> IO String
usage c = do
	bin <- Env.getProgName
	return $ unlines $
		[ C.translate c Lang.Section_Description
		, "  "++C.translate c Lang.Help_Command_General_Ledger
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
		                " ["++C.translate c Lang.Type_File_Journal++"] [...]"
		, ""
		, usageInfo (C.translate c Lang.Section_Options) (options c)
		]

options :: C.Context -> Args.Options Ctx
options c =
	[ Option "g" ["filter-gl"]
	 (ReqArg (\s ctx -> do
		ctx_filter_gl <-
			liftM ((ctx_filter_gl ctx <>) . Filter.simplify) $
				liftIO $ Filter.Read.read Filter.Read.filter_gl s
				>>= \f -> case f of
				 Left  ko -> Write.fatal c $ ko
				 Right ok -> return ok
		return $ ctx{ctx_filter_gl}) $
		C.translate c Lang.Type_Filter_General_Ledger) $
		C.translate c Lang.Help_Option_Filter_General_Ledger
	, Option "p" ["filter-posting"]
	 (ReqArg (\s 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 c $ ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_posting}) $
		C.translate c Lang.Type_Filter_Posting) $
		C.translate c Lang.Help_Option_Filter_Posting
	, Option "t" ["filter-transaction"]
	 (ReqArg (\s 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 c $ ko
			 Right ok -> return ok
		return $ ctx{ctx_filter_transaction}) $
		C.translate c Lang.Type_Filter_Transaction) $
		C.translate c Lang.Help_Option_Filter_Transaction
	, Option "h" ["help"]
	 (NoArg (\_ctx -> do
		usage c >>= IO.hPutStr IO.stderr
		exitSuccess)) $
		C.translate c Lang.Help_Option_Help
	, Option "i" ["input"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_input=s:ctx_input ctx}) $
		C.translate c Lang.Type_File_Journal) $
		C.translate c Lang.Help_Option_Input
	, Option "o" ["output"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
		C.translate c Lang.Type_File) $
		C.translate c Lang.Help_Option_Output
	, Option "O" ["overwrite"]
	 (ReqArg (\s ctx -> do
		return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
		C.translate c Lang.Type_File) $
		C.translate c Lang.Help_Option_Overwrite
	{- NOTE: not used so far.
	, Option "" ["reduce-date"]
	 (OptArg (\arg c ctx -> do
		ctx_reduce_date <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c $
			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"
	-}
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <-
		first (\x ->
			case ctx_output x of
			 [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
			 _  -> x) <$>
		Args.parse c usage options (nil, args)
	read_journals <-
		liftM partitionEithers $ do
		CLI.Ledger.paths c $ 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 c $ err
	 ([], journals) -> do
		Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
		Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
		Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
		let (amount_styles, gl) = ledger_gl ctx journals
		let lang = C.lang c
		Write.write c Write.style (ctx_output ctx) $ do
		toDoc () $ do
		zipWith id
		 [ Table.column (Lang.translate lang Lang.Title_Account)         Table.Align_Left
		 , Table.column (Lang.translate lang Lang.Title_Date)            Table.Align_Left
		 , Table.column (Lang.translate lang Lang.Title_Debit)           Table.Align_Right
		 , Table.column (Lang.translate lang Lang.Title_Credit)          Table.Align_Right
		 , Table.column (Lang.translate lang Lang.Title_Running_debit)   Table.Align_Right
		 , Table.column (Lang.translate lang Lang.Title_Running_credit)  Table.Align_Right
		 , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
		 , Table.column (Lang.translate lang Lang.Title_Description)     Table.Align_Left
		 ] $ do
		write_gl amount_styles gl (repeat [])

ledger_gl
 :: Ctx
 -> [ Ledger.Journal (GL.GL (Ledger.Chart_With Ledger.Transaction)) ]
 -> ( Ledger.Amount.Styles
    , GL (Ledger.Chart_With Ledger.Transaction)
    )
ledger_gl ctx journals =
	let (_chart, amount_styles, gl) =
		foldl'
		 (flip (\j ->
			flip mappend $
			( Ledger.journal_chart j
			, Ledger.journal_amount_styles j
			, ) $
			Ledger.Journal.fold
			 (\Ledger.Journal
				 { Ledger.journal_sections=g
				 } -> mappend g
			 ) j mempty
		 ))
		 mempty journals in
	(amount_styles,) $
	GL.GL $
	TreeMap.map_Maybe_with_Path
	 (\acct expanded_lines ->
		case Map.mapMaybeWithKey
		 (\date seq_lines ->
			case foldMap
			 (\line@GL.GL_Line
			 { GL.gl_line_transaction = _t
			 , GL.gl_line_posting     = Ledger.Chart_With c p
			 , GL.gl_line_sum         = s
			 } ->
				Map.foldlWithKey
				 (\acc unit qty ->
					let sqty = (Map.!) s unit in
					if Filter.test (ctx_filter_gl ctx)
					 ( (Chart.account_tags acct c, acct)
					 , date
					 , (unit, Polarize.polarize qty)
					 , (unit, sqty)
					 )
					then (Seq.|>) acc line
					 { GL.gl_line_posting = Ledger.Chart_With c p
						 { Ledger.posting_amounts = Map.singleton unit qty }
					 , GL.gl_line_sum = Map.singleton unit sqty
					 }
					else acc
				 )
				 Seq.empty
				 (Ledger.posting_amounts p)
			 ) seq_lines of
			 m | Seq.null m -> Nothing
			 m -> Just m
		 )
		 (GL.inclusive expanded_lines) of
			m | Map.null m -> Strict.Nothing
			m -> Strict.Just m
		) $
	GL.expanded gl

write_gl
 :: Ledger.Amount.Styles
 -> GL (Ledger.Chart_With Ledger.Transaction)
 -> [[Table.Cell]]
 -> [[Table.Cell]]
write_gl amount_styles (GL gl) =
	flip (TreeMap.foldr_with_Path
	 (\acct ->
		flip $ Map.foldrWithKey
		 (\date ->
			flip (foldr
			 (\GL.GL_Line
				 { GL.gl_line_transaction = Ledger.Chart_With _ t
				 , GL.gl_line_posting     = Ledger.Chart_With _ p
				 , GL.gl_line_sum         = s
				 } ->
				flip (Map.foldrWithKey
				 (\unit qty ->
					let ms = Map.lookup unit s in
					zipWith (:)
						[ let ptype = Ledger.Posting_Type_Regular in
							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
						 }
						, cell_amount unit (Polarize.polarizable_positive qty)
						, cell_amount unit (Polarize.polarizable_negative qty)
						, cell_amount unit (ms >>= Polarize.polarized_positive)
						, cell_amount unit (ms >>= Polarize.polarized_negative)
						, cell_amount unit (liftM Polarize.depolarize ms)
						, let descr = Ledger.transaction_description t in
							Table.cell
							 { Table.cell_content = toDoc ()    descr
							 , Table.cell_width   = Text.length descr
							 }
						]
				 ))
				 (Ledger.posting_amounts p)
			 ))
		 )
	 ))
	 gl
	where
		cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
		cell_amount unit mq =
			case mq of
			 Nothing -> Table.cell
			 Just q ->
				let a  = Ledger.Amount.Amount unit q in
				let sa = Ledger.Amount.style amount_styles a in
				Table.cell
				 { Table.cell_content = Amount.Write.amount        sa
				 , Table.cell_width   = Amount.Write.amount_length sa
				 }