{-# 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.Map.Strict as Data.Map
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.Lib.Shakespeare.Leijen as I18N
import qualified Hcompta.CLI.Write as Write
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.renderMessage Context.App langs
				Write.I18N_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.renderMessage Context.App langs $ do
		case Parsec.sourceName pos of
		 "" -> Write.I18N_at
			 (Parsec.sourceLine pos)
			 (Parsec.sourceColumn pos)
		 path -> Write.I18N_in_file path
			 (Parsec.sourceLine pos)
			 (Parsec.sourceColumn pos)

instance ToDoc Context [Lib.Parsec.Error Ledger.Read.Error] 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)
				 ]
				 {-
				 : (flip Data.List.map)
					 (uniq $ Parsec.Error.errorMessages err)
					 (\e ->
						I18N.renderMessage Context.App langs $
						case e of
						 Parsec.Error.SysUnExpect msg -> Write.I18N_sysunexpect msg
						 Parsec.Error.UnExpect    msg -> Write.I18N_unexpect    msg
						 Parsec.Error.Expect      msg -> Write.I18N_expect      msg
						 Parsec.Error.Message     msg -> Write.I18N_message     msg
					 )
				 )
				 -}
			 Lib.Parsec.Error_Custom pos err -> W.vsep $
				[ toDoc context pos
				, case err of
				 Ledger.Read.Error_year_or_day_is_missing ->
					I18N.renderMessage Context.App langs $
					 Write.I18N_year_or_day_is_missing
				 Ledger.Read.Error_invalid_date (y, m, d) ->
					I18N.renderMessage Context.App langs $
					 Write.I18N_invalid_date y m d
				 Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
					I18N.renderMessage Context.App langs $
					 Write.I18N_invalid_time_of_day h m s
				 Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
					i18n_transaction_not_equilibrated tr unit_sums
					 Write.I18N_the_following_transaction_is_not_equilibrated_because
				 Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
					i18n_transaction_not_equilibrated tr unit_sums
					 Write.I18N_the_following_virtual_transaction_is_not_equilibrated_because
				 Ledger.Read.Error_reading_file file_path exn -> W.vsep $
					 [ I18N.renderMessage Context.App langs $
						Write.I18N_failed_to_read_file file_path
					 , W.text $ TL.pack $ show exn
					 ]
				 Ledger.Read.Error_including_file file_path errs -> W.vsep $
					 [ I18N.renderMessage Context.App langs $
						Write.I18N_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.renderMessage Context.App 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 Data.Map.! () in
						I18N.renderMessage Context.App langs $
						Write.I18N_unit_sums_up_to_the_non_null_amount
						 (Amount.unit amt) amt
					 ) unit_sums
				 , W.space
				 , Ledger.Write.transaction tr
				 ]
			showErrorMessages :: [Parsec.Error.Message] -> W.Doc
			showErrorMessages msgs
				| null msgs = i18n $ Write.I18N_unknown
				| otherwise = W.vsep $ -- clean $
					[showSysUnExpect, showUnExpect, showExpect, showMessages]
				where
					i18n = I18N.renderMessage Context.App 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 . Write.I18N_expect)) expect
					showUnExpect = showMany (Just (i18n . Write.I18N_unexpect)) unExpect
					showSysUnExpect
					 | not (null unExpect) || null sysUnExpect = W.empty
					 | null firstMsg = i18n $ Write.I18N_sysunexpect_end_of_input
					 | otherwise     = i18n $ Write.I18N_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 Write.I18N_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)