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

import           Control.DeepSeq (NFData(..))
import           Control.Monad (Monad(..), forM_, liftM, mapM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (runExceptT)
import           Data.Either (Either(..), partitionEithers)
import           Data.Foldable (Foldable(..))
import           Data.List ((++))
import           Data.Monoid (Monoid(..), (<>))
import           Data.String (String)
import           Text.Show (Show)
import           Prelude (($), Bounded(..), FilePath, IO, flip, unlines)
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.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           Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Leijen as W

data Ctx
 =   Ctx
 { ctx_input              :: [FilePath]
 } deriving (Show)

nil :: Ctx
nil =
	Ctx
	 { ctx_input = []
	 }

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_Journals
		, ""
		, C.translate c Lang.Section_Syntax
		, "  "++bin++" journals ["++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
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <-
		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 () 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
		let files = ledger_journals ctx journals
		style_color <- Write.with_color c IO.stdout
		W.displayIO IO.stdout $ do
		W.renderPretty style_color 1.0 maxBound $ do
		doc_journals c ctx files

newtype Journals t = Journals ()
 deriving (Show)
instance Monoid (Journals t) where
	mempty = Journals ()
	mappend _ _ = mempty
instance NFData t => NFData (Journals t) where
	rnf (Journals t) = rnf t

instance Consable () Journals t where
	mcons () _t !_js = mempty

ledger_journals
 :: Ctx
 -> [Ledger.Journal (Journals (Ledger.Chart_With Ledger.Transaction))]
 -> [FilePath]
ledger_journals _ctx =
	Data.Foldable.foldl'
	 (flip $ Ledger.Journal.fold
		 (\Ledger.Journal{Ledger.journal_file=f} ->
			mappend [f]))
	 mempty

doc_journals
 :: C.Context
 -> Ctx
 -> [FilePath]
 -> W.Doc
doc_journals _context _ctx =
	foldr
	 (\file doc -> doc <> W.toDoc () file <> W.line)
	 W.empty