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

-- import           Control.Applicative ((<$>))
import           Control.Monad (foldM, liftM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import           Data.Foldable ()
import           Data.Functor.Compose (Compose(..))
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import           System.Console.GetOpt
                 ( ArgDescr(..)
                 , OptDescr(..)
                 , usageInfo )
import           Data.Monoid ((<>))
import           Prelude hiding (foldr)
import           System.Environment as Env (getProgName)
import           System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO

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.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.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Lib.Interval as Interval

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 , ctx_align              :: Bool
 , ctx_date_reducer       :: Bool
 , ctx_transaction_filter :: Filter.Simplified
                             (Filter.Test_Bool
                             (Filter.Test_Transaction
                             Ledger.Transaction))
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_input = []
	 , ctx_align = True
	 , ctx_date_reducer = True
	 , ctx_transaction_filter = mempty
	 }

usage :: IO String
usage = do
	bin <- Env.getProgName
	return $unlines $
		[ "SYNTAX "
		, "  "++bin++" journal"
		, " [-t TRANSACTION_FILTER]"
		, " JOURNAL_FILE [...]"
		, ""
		, 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 "" ["align"]
	 (OptArg (\arg context ctx -> do
		ctx_align <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			W.text "--align option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_align})
	  "[yes|no]")
	 "align output"
	, Option "" ["date-reducer"]
	 (OptArg (\arg context ctx -> do
		ctx_date_reducer <- case arg of
		 Nothing    -> return $ True
		 Just "yes" -> return $ True
		 Just "no"  -> return $ False
		 Just _     -> Write.fatal context $
			W.text "--date-reducer option expects \"yes\", or \"no\" as value"
		return $ ctx{ctx_date_reducer})
	  "[yes|no]")
	 "use advanced date reducer to speed up filtering"
	, Option "t" ["transaction-filter"]
	 (ReqArg (\s context ctx -> do
		ctx_transaction_filter <-
			liftM (\t -> (<>) (ctx_transaction_filter ctx)
			 (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
			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, inputs) <- Args.parse context usage options (nil, args)
	read_journals <- do
		CLI.Ledger.paths context $ ctx_input ctx ++ inputs
		>>= 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
		Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
		let date_reducer =
			if ctx_date_reducer ctx
			then Filter.Reduce.bool_date <$> ctx_transaction_filter ctx
			else mempty
		Write.debug context $ "transaction_filter: date_reducer: " ++ show date_reducer
		style_color <- Write.with_color context IO.stdout
		let sty = Ledger.Write.Style
			 { Ledger.Write.style_align = ctx_align ctx
			 , Ledger.Write.style_color
			 }
		transactions <-
			foldM
			 (flip (Ledger.Journal.foldM
				 (\j j_ts -> do
					let ts = Ledger.journal_transactions j
					ts_filtered <-
						case Filter.simplified $ ctx_transaction_filter ctx of
						 Right True  -> return $ ts:[]
						 Right False -> return $ []
						 Left flt ->
							liftM
							 (Data.List.map
								 (Data.Map.mapMaybe
									 (\lt ->
										case Data.List.filter (Filter.test flt) lt of
										 [] -> Nothing
										 l  -> Just l
									 ))) $
							case Filter.simplified date_reducer of
							 Left reducer -> do
								let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
								Write.debug context $ "transaction_filter: date_sieve: "
								 ++ "journal=" ++ (show $ Ledger.journal_file j)
								 ++ ": " ++ show (Interval.Pretty date_sieve)
								return ts_reduced
							 Right True  -> return $ ts:[]
							 Right False -> return $ []
					return $
						Data.Map.unionsWith (++) (j_ts:ts_filtered)
				 )))
			 Data.Map.empty
			 journals
		Ledger.Write.put sty IO.stdout $ do
		Ledger.Write.transactions (Compose transactions)