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

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.Functor (Functor(..), (<$>))
import           Data.List ((++))
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..), (<>))
import           Data.String (String)
import           Prelude (($), (.), FilePath, IO, flip, unlines)
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.Chart (Chart)
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.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.Filter.Reduce as Filter.Reduce
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
import qualified Hcompta.Format.Ledger.Amount as Ledger.Amount
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Journal as Journal

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 , ctx_output             :: [(Write.Mode, FilePath)]
 , ctx_align              :: Bool
 , ctx_reduce_date        :: Bool
 , ctx_filter_transaction :: Filter.Simplified
                             (Filter.Filter_Bool
                             (Filter.Filter_Transaction
                             (Ledger.Chart_With Ledger.Transaction)))
 } deriving (Show)

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

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_Journal
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" journal ["++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 "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
	, Option "" ["align"]
	 (OptArg (\arg ctx -> do
		ctx_align <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal c $
			W.text "--align option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_align})
	  "[yes|no]")
	 "align output"
	{- NOTE: not used so far.
	, Option "" ["reduce-date"]
	 (OptArg (\arg 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"
	-}
	, Option "t" ["transaction-filter"]
	 (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 -> do
				Write.debug c $ "filter: transaction: " ++ show ok
				return ok
		return $ ctx{ctx_filter_transaction}) $
		C.translate c Lang.Type_Filter_Transaction) $
		C.translate c Lang.Help_Option_Filter_Transaction
	]

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 Data.Either.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) 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)
		{- NOTE: not used so far
		let reducer_date =
			if ctx_reduce_date ctx
			then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
			else mempty
		Write.debug c $ "filter: transaction: reducer: " ++ show reducer_date
		-}
		let sty = Write.style{ Write.style_pretty = ctx_align ctx }
		let (_chart, amount_styles, journal) = ledger_journal ctx journals
		Write.write c sty (ctx_output ctx) $ do
		Ledger.Write.transactions amount_styles $ fmap Ledger.with_chart journal

ledger_journal
 :: Ctx
 -> [ Ledger.Journal (Journal.Journal (Ledger.Chart_With Ledger.Transaction)) ]
 -> ( Chart Ledger.Account
    , Ledger.Amount.Styles
    , Journal.Journal (Ledger.Chart_With Ledger.Transaction)
    )
ledger_journal _ctx =
	Data.Foldable.foldl'
	 (flip (\j ->
		flip mappend $
		( Ledger.journal_chart j
		, Ledger.journal_amount_styles j
		, ) $
		Ledger.Journal.fold
		 (\Ledger.Journal
			 { Ledger.journal_sections=t
			 } -> mappend t
		 ) j mempty
	 ))
	 mempty