{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Format.Ledger where

import           Prelude hiding (error)
import           Control.Exception (tryJust)
import           Control.Monad (guard)
import qualified Data.List
import qualified Data.Text.Lazy as TL
import           System.Environment as Env (getEnv)
import           System.IO.Error (isDoesNotExistError)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Error as Parsec.Error

import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen (ToDoc(..), (<>))
import qualified Hcompta.Lib.Parsec as Lib.Parsec
import qualified Hcompta.Calc.Balance as Calc.Balance
import qualified Hcompta.CLI.Context as Context
import           Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.I18N as I18N
import qualified Hcompta.CLI.Write as Write
import qualified Hcompta.Model.Filter.Read as Filter.Read
import qualified Hcompta.Format.Ledger.Read as Ledger.Read
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import qualified Hcompta.Model.Amount as Amount

-- | Return 'FilePath's containing 'Hcompta.Format.Ledger.Journal's:
--
-- * either those given if any,
-- * or the one in LEDGER_FILE environment variable if any,
-- * or the one in LEDGER environment variable if any.
paths :: Context.Context -> [FilePath] -> IO [FilePath]
paths context [] = do
	tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER_FILE"
	>>= \x -> case x of
	 Right ok -> return [ok]
	 Left  _ko -> do
		tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER"
		>>= \xx -> case xx of
		 Right ok -> return [ok]
		 Left  _ko -> do
			let langs = Context.langs context
			Write.fatal context $
				I18N.render langs
				I18N.Message_no_ledger_file_given
paths _context ps = return ps

instance ToDoc Context Parsec.SourcePos where
	toDoc context pos = do
		let langs = Context.langs context
		I18N.render langs $ do
		case Parsec.sourceName pos of
		 "" -> I18N.Message_at
			 (Parsec.sourceLine pos)
			 (Parsec.sourceColumn pos)
		 path -> I18N.Message_in_file path
			 (Parsec.sourceLine pos)
			 (Parsec.sourceColumn pos)

instance ToDoc Context e => ToDoc Context [Lib.Parsec.Error e] where
	toDoc context errors =
		W.vsep $ do
		(flip map) errors $ (\error ->
			case error of
			 Lib.Parsec.Error_At pos errs -> W.vsep $
				[ toDoc context pos
				, toDoc context errs
				]
			 Lib.Parsec.Error_Parser err ->
				W.vsep $
				 [ toDoc context (Parsec.errorPos err)
				 , showErrorMessages
					 (Parsec.Error.errorMessages err)
				 ]
			 Lib.Parsec.Error_Custom pos err -> W.vsep $
				[ toDoc context pos
				, toDoc context err
				]
		 )
		where
			langs = Context.langs context
			showErrorMessages :: [Parsec.Error.Message] -> W.Doc
			showErrorMessages msgs
				| null msgs = i18n $ I18N.Message_unknown
				| otherwise = W.vsep $ -- clean $
					[showSysUnExpect, showUnExpect, showExpect, showMessages]
				where
					i18n = I18N.render langs
					(sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
					(unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
					(expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
					
					showExpect   = showMany (Just (i18n . I18N.Message_expect)) expect
					showUnExpect = showMany (Just (i18n . I18N.Message_unexpect)) unExpect
					showSysUnExpect
					 | not (null unExpect) || null sysUnExpect = W.empty
					 | null firstMsg = i18n $ I18N.Message_sysunexpect_end_of_input
					 | otherwise     = i18n $ I18N.Message_sysunexpect firstMsg
						where
						firstMsg = Parsec.Error.messageString (head sysUnExpect)
					
					showMessages = showMany Nothing messages
					
					-- helpers
					showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
					showMany pre msgs_ =
						case clean (map Parsec.Error.messageString msgs_) of
						 [] -> W.empty
						 ms ->
							case pre of
							 Nothing -> commasOr ms
							 Just p -> p $ commasOr ms
					
					commasOr :: [String] -> W.Doc
					commasOr []  = W.empty
					commasOr [m] = W.text $ TL.pack m
					commasOr ms  = commaSep (init ms)
					               <> (W.space <> i18n I18N.Message_or <> W.space)
					               <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
					commaSep = W.intercalate (W.comma <> W.space)
					           (W.bold . W.dullblack . W.text . TL.pack)
					           . clean
					
					clean = Data.List.nub . filter (not . null)

instance ToDoc Context Ledger.Read.Error where
	toDoc context err =
		case err of
		 Ledger.Read.Error_year_or_day_is_missing ->
			I18N.render langs $ I18N.Message_year_or_day_is_missing
		 Ledger.Read.Error_invalid_date (y, m, d) ->
			I18N.render langs $ I18N.Message_invalid_date y m d
		 Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
			I18N.render langs $ I18N.Message_invalid_time_of_day h m s
		 Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
			i18n_transaction_not_equilibrated tr unit_sums
			 I18N.Message_the_following_transaction_is_not_equilibrated_because
		 Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
			i18n_transaction_not_equilibrated tr unit_sums
			 I18N.Message_the_following_virtual_transaction_is_not_equilibrated_because
		 Ledger.Read.Error_reading_file file_path exn -> W.vsep $
			 [ I18N.render langs $
				I18N.Message_failed_to_read_file file_path
			 , W.text $ TL.pack $ show exn
			 ]
		 Ledger.Read.Error_including_file file_path errs -> W.vsep $
			 [ I18N.render langs $
				I18N.Message_failed_to_include_file file_path
			 , toDoc context errs
			 ]
		where
			langs = Context.langs context
			i18n_transaction_not_equilibrated tr unit_sums msg =
				W.vsep $
				 [ I18N.render langs msg
				 , W.vsep $ Data.List.map
					 (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} ->
						let amt = Calc.Balance.amount_sum_balance unit_sum_amount in
						I18N.render langs $
						I18N.Message_unit_sums_up_to_the_non_null_amount
						 (Amount.unit amt) amt
					 ) unit_sums
				 , W.space
				 , Ledger.Write.transaction tr
				 ]

instance ToDoc Context Filter.Read.Error where
	toDoc context err =
		case err of
		 Filter.Read.Error_Unknown -> toDoc context ("error"::String)