{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Command.Journals where

import           Control.Arrow ((+++))
import           Control.Monad (Monad(..), liftM, mapM)
import           Control.Monad.IO.Class (liftIO)
import           Data.Either (Either(..), partitionEithers)
import           Data.Foldable (Foldable(..))
import           Data.Function (($), (.), const)
import           Data.List ((++))
import           Data.Maybe (Maybe(..))
import           Data.Monoid (Monoid(..), (<>))
import           Data.String (String)
import           Prelude (Bounded(..), FilePath, IO, unlines)
import           System.Console.GetOpt
                  ( ArgDescr(..)
                  , OptDescr(..)
                  , usageInfo )
import qualified System.Environment as Env
import           System.Exit (exitSuccess)
import qualified System.IO as IO
import           Text.Show (Show)

import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Env as CLI.Env
import qualified Hcompta.CLI.Format as Format
import           Hcompta.CLI.Format (Format(..), Formats)
import           Hcompta.CLI.Format.Ledger ()
import           Hcompta.CLI.Format.JCC ()
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
-- import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Format.JCC as JCC
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Lib.Leijen as W

data Context
 =   Context
 { ctx_input        :: [FilePath]
 , ctx_input_format :: Formats
 } deriving (Show)

context :: Context
context =
	Context
	 { ctx_input        = []
	 , ctx_input_format = 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_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 Context
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 "if" ["input-format"]
	 (OptArg (\arg ctx -> do
		ctx_input_format <- case arg of
		 Nothing       -> return $ Format_JCC ()
		 Just "jcc"    -> return $ Format_JCC ()
		 Just "ledger" -> return $ Format_Ledger ()
		 Just _        -> Write.fatal c $
			W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
		return $ ctx{ctx_input_format})
	  "[jcc|ledger]")
	  "input format"
	]

run :: C.Context -> [String] -> IO ()
run c args = do
	(ctx, inputs) <- Args.parse c usage options (context, args)
	input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
	read_journals <- mapM (liftIO . journal_read ctx) input_paths
	case partitionEithers read_journals of
	 (errs@(_:_), _journals) -> Write.fatals c errs
	 ([], journals) -> do
		with_color <- Write.with_color c IO.stdout
		W.displayIO IO.stdout $ do
		W.renderPretty with_color 1.0 maxBound $
			W.toDoc () $
			mconcat journals

-- * Class 'Journal'

class
 ( Format.Journal_Monoid (j m)
 , Format.Journal_Read j
 ) => Journal j m where
	journal_files :: j m -> [FilePath]

-- JCC
instance Journal JCC.Journal Journals_JCC where
	journal_files j = [JCC.journal_file j]

-- Ledger
instance Journal Ledger.Journal Journals_Ledger where
	journal_files = Ledger.journal_files

type Journals_JCC    = ()
type Journals_Ledger = ()

-- * Type 'Journals'

newtype Journals =
	Journals [FilePath]
 deriving (Show)
instance Monoid Journals where
	mempty = Journals []
	mappend (Journals x) (Journals y) =
		Journals (mappend x y)
	mconcat = foldl' mappend mempty
instance W.ToDoc () Journals where
	toDoc () (Journals files) =
		foldr
		 (\file doc -> doc <> W.toDoc () file <> W.line)
		 W.empty files

type Journal_Read_Cons txn = txn -> ()
journal_read
 :: Context -> FilePath
 -> IO (Either (Format.Message W.Doc) Journals)
journal_read ctx =
	case ctx_input_format ctx of
	 Format_JCC () ->
		let wrap (j::JCC.Journal Journals_JCC) =
			Format.journal_fold journals_cons j mempty in
		let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
			 = const () in
		liftM ((+++) Format.Message wrap) .
		Format.journal_read cons
	 Format_Ledger () ->
		let wrap (j::Ledger.Journal Journals_Ledger) =
			Format.journal_fold journals_cons j mempty in
		let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
			 = const () in
		liftM ((+++) Format.Message wrap) .
		Format.journal_read cons

journals_cons :: Journal j m => j m -> Journals -> Journals
journals_cons j !(Journals files) =
	Journals (journal_files j ++ files)