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

import           Control.Monad (liftM)
import qualified Data.List
import           Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Text
import           Data.Text (Text)
import qualified Data.Text.Lazy as TL
import           Prelude hiding (error)
import           System.Environment (getEnvironment)
import           System.IO.Memoize (once)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Error as Parsec.Error

import           Hcompta.Amount (Amount)
import           Hcompta.Amount.Unit (Unit)
import qualified Hcompta.Amount.Write as Amount.Write
import           Hcompta.Date (Date)
import qualified Hcompta.Date.Read as Date.Read
import qualified Hcompta.Date.Write as Date.Write
import qualified Hcompta.Filter.Read as Filter.Read
import           Hcompta.Lib.Leijen (ToDoc(..), (<>))
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Lib.Parsec as Lib.Parsec
data Lang
 = FR
 | EN
 deriving (Show)

-- TODO: check that this is expected behavior
--       and portability issues
get_lang :: IO Lang
get_lang = do
	once getEnvironment
	>>= liftM (\env ->
		fromMaybe EN $ lang_of_strings $
		Data.List.concatMap
		 ((\lang ->
			let short = takeWhile (/= '_') lang in
			if short == lang
			then [lang]
			else [lang, short])
		 . Data.List.takeWhile (/= '.') ) $
		catMaybes
		 [ Data.List.lookup "LC_ALL"   env
		 , Data.List.lookup "LC_CTYPE" env
		 , Data.List.lookup "LANG"     env
		 ])

lang_of_strings :: [String] -> Maybe Lang
lang_of_strings s =
	case s of
	 ("fr"   :_) -> Just $ FR
	 ("fr_FR":_) -> Just $ FR
	 ("en"   :_) -> Just $ EN
	 ("en_US":_) -> Just $ EN
	 (_:xs)      -> lang_of_strings xs
	 []          -> Nothing

(#) :: ToDoc () a => a -> W.Doc
(#) = toDoc ()

instance ToDoc m Text where
	toDoc _ = W.strict_text
instance ToDoc m String where
	toDoc _ = W.strict_text . Data.Text.pack
instance ToDoc m Int where
	toDoc _ = W.int
instance ToDoc m Integer where
	toDoc _ = W.integer
instance ToDoc m Unit where
	toDoc _ = Amount.Write.unit
instance ToDoc m Amount where
	toDoc _ = Amount.Write.amount
instance ToDoc m Date where
	toDoc _ = Date.Write.date
instance ToDoc Lang Date.Read.Error where
	toDoc FR e =
		case e of
		 Date.Read.Error_year_or_day_is_missing ->
			"l’année ou le jour est manquant·e"
		 Date.Read.Error_invalid_date (year, month, day) ->
			"date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
		 Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
			"heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
	toDoc EN e =
		case e of
		 Date.Read.Error_year_or_day_is_missing ->
			"year or day is missing"
		 Date.Read.Error_invalid_date (year, month, day) ->
			"invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
		 Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
			"invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
instance ToDoc Lang Parsec.SourcePos where
	toDoc EN pos = do
		let line = Parsec.sourceLine   pos
		let col  = Parsec.sourceColumn pos
		case Parsec.sourceName pos of
		 ""   -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
		 path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
	toDoc FR pos = do
		let line = Parsec.sourceLine   pos
		let col  = Parsec.sourceColumn pos
		case Parsec.sourceName pos of
		 ""   -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
		 path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
instance ToDoc Lang e
 => ToDoc Lang [Lib.Parsec.Error e] where
	toDoc lang errors =
		W.vsep $ do
		(flip map) errors $ (\error ->
			case error of
			 Lib.Parsec.Error_At pos errs -> W.vsep $
				[ toDoc lang pos
				, toDoc lang errs
				]
			 Lib.Parsec.Error_Parser err ->
				W.vsep $
				 [ toDoc lang (Parsec.errorPos err)
				 , showErrorMessages
					 (Parsec.Error.errorMessages err)
				 ]
			 Lib.Parsec.Error_Custom pos err -> W.vsep $
				[ toDoc lang pos
				, toDoc lang err
				]
		 )
		where
			showErrorMessages :: [Parsec.Error.Message] -> W.Doc
			showErrorMessages msgs
				| null msgs = toDoc lang $ Message_unknown
				| otherwise = W.vsep $ -- clean $
					[showSysUnExpect, showUnExpect, showExpect, showMessages]
				where
					(sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
					(unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
					(expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
					
					showExpect   = showMany (Just (toDoc lang . Message_expect)) expect
					showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect
					showSysUnExpect
					 | not (null unExpect) || null sysUnExpect = W.empty
					 | null firstMsg = toDoc lang $ Message_sysunexpect_end_of_input
					 | otherwise     = toDoc lang $ 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.bold $ W.dullblack $ W.text $ TL.pack m
					commasOr ms  = commaSep (init ms)
					               <> (W.space <> toDoc lang 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 Lang Filter.Read.Error where
	toDoc lang@FR err =
		case err of
		 Filter.Read.Error_Unknown -> "erreur"
		 Filter.Read.Error_Filter_Date d -> toDoc lang d
		 Filter.Read.Error_Filter_Date_Interval (l, h) ->
			"mauvais intervalle: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"
	toDoc lang@EN err =
		case err of
		 Filter.Read.Error_Unknown -> "error"
		 Filter.Read.Error_Filter_Date d -> toDoc lang d
		 Filter.Read.Error_Filter_Date_Interval (l, h) ->
			"wrong interval: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"

data Message
 = Message_ERROR
 | Message_no_ledger_file_given
 | Message_failed_to_read_file
	{message_path :: FilePath}
 | Message_failed_to_include_file
	{message_path :: FilePath}
 | Message_the_following_transaction_is_not_equilibrated_because {}
 | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
 | Message_unit_sums_up_to_the_non_null_amount
	{message_Unit   :: Unit
	,message_Amount :: Amount}
 | Message_year_or_day_is_missing {}
 | Message_invalid_date
	{message_Year  :: Integer
	,message_Month :: Int
	,message_Day   :: Int
	}
 | Message_invalid_time_of_day
	{ message_Hour   :: Int
	, message_Month  :: Int
	, message_Second :: Integer
	}
 | Message_unexpect {message_Doc :: W.Doc}
 | Message_sysunexpect {message_Msg :: String}
 | Message_expect {message_Doc :: W.Doc}
 | Message_message {message_Msg :: String}
 | Message_sysunexpect_end_of_input {}
 | Message_unknown {}
 | Message_or {}
 | Message_Balance {}
 | Message_Debit {}
 | Message_Credit {}
 | Message_Running_debit {}
 | Message_Running_credit {}
 | Message_Running_balance {}
 | Message_Account {}
 | Message_Date {}
 | Message_Description {}
 | Message_Equilibrium {}
 | Message_Equilibrium_posting {}
 | Message_Balance_Description Bool
 | Message_Accounts
 | Message_Depths
 | Message_Transactions
 | Message_Units
 | Message_Journals
 | Message_Tags
 | Message_Distincts
instance ToDoc Lang Message where
	toDoc EN msg =
		case msg of
		 Message_ERROR ->
			"ERROR"
		 Message_no_ledger_file_given ->
			"no ledger file given, please use:" <> W.line <>
			"- either -i FILE parameter" <> W.line <>
			"- or LEDGER_FILE environment variable."
		 Message_failed_to_read_file path ->
			"failed to read file: " <> (#)path
		 Message_failed_to_include_file path ->
			"failed to include file: " <> (#)path
		 Message_the_following_transaction_is_not_equilibrated_because ->
			"the following transaction is not equilibrated, because:"
		 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
			"the following virtual transaction is not equilibrated, because:"
		 Message_unit_sums_up_to_the_non_null_amount unit amount ->
			" - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
		 Message_year_or_day_is_missing ->
			"year or day is missing"
		 Message_invalid_date year month day ->
			"invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
		 Message_invalid_time_of_day hour minute second ->
			"invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
		 Message_unexpect doc ->
			"found : " <> (#)doc
		 Message_sysunexpect doc ->
			"is written : " <> (#)doc
		 Message_expect doc ->
			"but expect : " <> (#)doc
		 Message_message doc ->
			(#)doc
		 Message_sysunexpect_end_of_input ->
			"end of file unexpected"
		 Message_unknown ->
			"unkown"
		 Message_or ->
			"or"
		 Message_Balance ->
			"Balance"
		 Message_Debit ->
			"Debit"
		 Message_Credit ->
			"Credit"
		 Message_Running_debit ->
			"Running debit"
		 Message_Running_credit ->
			"Running credit"
		 Message_Running_balance ->
			"Running balance"
		 Message_Account ->
			"Account"
		 Message_Date ->
			"Date"
		 Message_Description ->
			"Description"
		 Message_Equilibrium ->
			"Equilibrium"
		 Message_Equilibrium_posting ->
			"Equilibrium posting"
		 Message_Balance_Description negate_transaction ->
			case negate_transaction of
			 True  -> "Closing balance"
			 False -> "Opening balance"
		 Message_Accounts -> "Accounts"
		 Message_Depths -> "Depths"
		 Message_Transactions -> "Transactions"
		 Message_Units -> "Units"
		 Message_Journals -> "Journals"
		 Message_Tags -> "Tags"
		 Message_Distincts -> "Distincts"
	toDoc FR msg =
		case msg of
		 Message_ERROR ->
			"ERREUR"
		 Message_no_ledger_file_given ->
			"aucun fichier indiqué, veuillez utiliser :" <> W.line <>
			" - soit le paramètre -i FICHIER," <> W.line <>
			" - soit la variable d’environnement LEDGER_FILE."
		 Message_failed_to_read_file path ->
			"échec de la lecture du fichier : " <> (#)path
		 Message_failed_to_include_file path ->
			"échec à l’inclusion du fichier : " <> (#)path
		 Message_the_following_transaction_is_not_equilibrated_because ->
			"la transaction suivante n’est pas équilibrée, car :"
		 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
			"la transaction virtuelle suivante n’est pas équilibrée, car :"
		 Message_unit_sums_up_to_the_non_null_amount unit amount ->
			" - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
		 Message_year_or_day_is_missing ->
			"l’année ou le jour est manquant-e"
		 Message_invalid_date year month day ->
			"date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
		 Message_invalid_time_of_day hour minute second ->
			"heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
		 Message_unexpect doc ->
			"trouve : " <> (#)doc
		 Message_sysunexpect doc ->
			"est écrit : " <> (#)doc
		 Message_expect doc ->
			"mais s’attend à : " <> (#)doc
		 Message_message doc ->
			(#)doc
		 Message_sysunexpect_end_of_input ->
			"fin de fichier inattendue"
		 Message_unknown ->
			"inconnu"
		 Message_or ->
			"ou"
		 Message_Balance ->
			"Solde"
		 Message_Debit ->
			"Débit"
		 Message_Credit ->
			"Crédit"
		 Message_Running_debit ->
			"Débit cumulé"
		 Message_Running_credit ->
			"Crédit cumulé"
		 Message_Running_balance ->
			"Solde cumulé"
		 Message_Account ->
			"Compte"
		 Message_Date ->
			"Date"
		 Message_Description ->
			"Libellé"
		 Message_Equilibrium ->
			"Équilibre"
		 Message_Equilibrium_posting ->
			"Mouvement d’équilibre"
		 Message_Balance_Description negate_transaction ->
			case negate_transaction of
			 True  -> "Solde de clôture"
			 False -> "Solde d’ouverture"
		 Message_Accounts -> "Comptes"
		 Message_Depths -> "Profondeurs"
		 Message_Transactions -> "Écritures"
		 Message_Units -> "Unités"
		 Message_Journals -> "Journaux"
		 Message_Tags -> "Tags"
		 Message_Distincts -> "Distincts"