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

import           Prelude hiding (foldr)
-- import           Control.Arrow (first)
-- import           Control.Applicative ((<$>))
-- import           Control.Monad ((>=>))
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import           Data.Foldable (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 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.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           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
import qualified Hcompta.Model.Filter as Filter
import qualified Hcompta.Model.Filter.Read as Filter.Read

data Ctx
 =   Ctx
 { ctx_input :: [FilePath]
 , ctx_align :: Bool
 } deriving (Eq, Show)

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

usage :: IO String
usage = do
	bin <- Env.getProgName
	return $unlines $
		[ "SYNTAX "
		, "  "++bin++" print [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 "" ["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"
	]

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 $ toDoc context err
	 ([], journals) -> do
		(filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <-
			(flip mapM) text_filters $ \s ->
				case Filter.Read.read Filter.Read.test_transaction s of
				 Left  ko -> Write.fatal context $ toDoc context ko
				 Right ok -> return ok
		Write.debug context $ show filters
		style_color <- Write.with_color context IO.stdout
		let sty = Ledger.Write.Style
			 { Ledger.Write.style_align = ctx_align ctx
			 , Ledger.Write.style_color
			 }
		let transactions =
			foldr
			 (Ledger.Journal.fold
				 (flip (foldr
					 (flip (foldr
						 (\tr ->
							case Filter.test
							 (foldr Filter.And Filter.Any filters) tr of
							 False -> id
							 True  -> (:) tr
						 ))))
				 . Ledger.journal_transactions))
			 []
			 journals
		Ledger.Write.put sty IO.stdout $ do
		Ledger.Write.transactions transactions