1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Hcompta.CLI.Lang where
8 import Control.Monad (liftM)
9 import qualified Data.List
10 import Data.Maybe (catMaybes, fromMaybe)
11 import qualified Data.Text
12 import Data.Text (Text)
13 import qualified Data.Text.Lazy as TL
14 import Prelude hiding (error)
15 import System.Environment (getEnvironment)
16 import System.IO.Memoize (once)
17 import qualified Text.Parsec as Parsec
18 import qualified Text.Parsec.Error as Parsec.Error
20 import Hcompta.Amount (Amount)
21 import Hcompta.Amount.Unit (Unit)
22 import qualified Hcompta.Amount.Write as Amount.Write
23 import qualified Hcompta.Date.Read as Date.Read
24 import qualified Hcompta.Filter.Read as Filter.Read
25 import Hcompta.Lib.Leijen (ToDoc(..), (<>))
26 import qualified Hcompta.Lib.Leijen as W
27 import qualified Hcompta.Lib.Parsec as Lib.Parsec
34 -- TODO: check that this is expected behavior
35 -- and portability issues
40 fromMaybe EN $ lang_of_strings $
43 let short = takeWhile (/= '_') lang in
47 . Data.List.takeWhile (/= '.') ) $
49 [ Data.List.lookup "LC_ALL" env
50 , Data.List.lookup "LC_CTYPE" env
51 , Data.List.lookup "LANG" env
54 lang_of_strings :: [String] -> Maybe Lang
57 ("fr" :_) -> Just $ FR
58 ("fr_FR":_) -> Just $ FR
59 ("en" :_) -> Just $ EN
60 ("en_US":_) -> Just $ EN
61 (_:xs) -> lang_of_strings xs
64 (#) :: ToDoc () a => a -> W.Doc
67 instance ToDoc m Text where
68 toDoc _ = W.strict_text
69 instance ToDoc m String where
70 toDoc _ = W.strict_text . Data.Text.pack
71 instance ToDoc m Int where
73 instance ToDoc m Integer where
75 instance ToDoc m Unit where
76 toDoc _ = Amount.Write.unit
77 instance ToDoc m Amount where
78 toDoc _ = Amount.Write.amount
79 instance ToDoc Lang Date.Read.Error where
82 Date.Read.Error_year_or_day_is_missing ->
83 "l’année ou le jour est manquant·e"
84 Date.Read.Error_invalid_date (year, month, day) ->
85 "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
86 Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
87 "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
90 Date.Read.Error_year_or_day_is_missing ->
91 "year or day is missing"
92 Date.Read.Error_invalid_date (year, month, day) ->
93 "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
94 Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
95 "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
96 instance ToDoc Lang Parsec.SourcePos where
98 let line = Parsec.sourceLine pos
99 let col = Parsec.sourceColumn pos
100 case Parsec.sourceName pos of
101 "" -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
102 path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
104 let line = Parsec.sourceLine pos
105 let col = Parsec.sourceColumn pos
106 case Parsec.sourceName pos of
107 "" -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
108 path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
109 instance ToDoc Lang e
110 => ToDoc Lang [Lib.Parsec.Error e] where
113 (flip map) errors $ (\error ->
115 Lib.Parsec.Error_At pos errs -> W.vsep $
119 Lib.Parsec.Error_Parser err ->
121 [ toDoc lang (Parsec.errorPos err)
123 (Parsec.Error.errorMessages err)
125 Lib.Parsec.Error_Custom pos err -> W.vsep $
131 showErrorMessages :: [Parsec.Error.Message] -> W.Doc
132 showErrorMessages msgs
133 | null msgs = toDoc lang $ Message_unknown
134 | otherwise = W.vsep $ -- clean $
135 [showSysUnExpect, showUnExpect, showExpect, showMessages]
137 (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
138 (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1
139 (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2
141 showExpect = showMany (Just (toDoc lang . Message_expect)) expect
142 showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect
144 | not (null unExpect) || null sysUnExpect = W.empty
145 | null firstMsg = toDoc lang $ Message_sysunexpect_end_of_input
146 | otherwise = toDoc lang $ Message_sysunexpect firstMsg
148 firstMsg = Parsec.Error.messageString (head sysUnExpect)
150 showMessages = showMany Nothing messages
153 showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
155 case clean (map Parsec.Error.messageString msgs_) of
159 Nothing -> commasOr ms
160 Just p -> p $ commasOr ms
162 commasOr :: [String] -> W.Doc
163 commasOr [] = W.empty
164 commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
165 commasOr ms = commaSep (init ms)
166 <> (W.space <> toDoc lang Message_or <> W.space)
167 <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
168 commaSep = W.intercalate (W.comma <> W.space)
169 (W.bold . W.dullblack . W.text . TL.pack)
172 clean = Data.List.nub . filter (not . null)
173 instance ToDoc Lang Filter.Read.Error where
176 Filter.Read.Error_Unknown -> "erreur"
177 Filter.Read.Error_Filter_Date d -> toDoc lang d
178 Filter.Read.Error_Filter_Date_Interval (l, h) ->
179 "mauvais intervalle: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"
182 Filter.Read.Error_Unknown -> "error"
183 Filter.Read.Error_Filter_Date d -> toDoc lang d
184 Filter.Read.Error_Filter_Date_Interval (l, h) ->
185 "wrong interval: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"
189 | Message_no_ledger_file_given
190 | Message_failed_to_read_file
191 {message_path :: FilePath}
192 | Message_failed_to_include_file
193 {message_path :: FilePath}
194 | Message_the_following_transaction_is_not_equilibrated_because {}
195 | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
196 | Message_unit_sums_up_to_the_non_null_amount
197 {message_Unit :: Unit
198 ,message_Amount :: Amount}
199 | Message_year_or_day_is_missing {}
200 | Message_invalid_date
201 {message_Year :: Integer
202 ,message_Month :: Int
205 | Message_invalid_time_of_day
206 { message_Hour :: Int
207 , message_Month :: Int
208 , message_Second :: Integer
210 | Message_unexpect {message_Doc :: W.Doc}
211 | Message_sysunexpect {message_Msg :: String}
212 | Message_expect {message_Doc :: W.Doc}
213 | Message_message {message_Msg :: String}
214 | Message_sysunexpect_end_of_input {}
220 | Message_Running_debit {}
221 | Message_Running_credit {}
222 | Message_Running_balance {}
225 | Message_Description {}
226 | Message_Equilibrium {}
227 | Message_Equilibrium_posting {}
228 | Message_Balance_Description Bool
229 instance ToDoc Lang Message where
234 Message_no_ledger_file_given ->
235 "no ledger file given, please use:" <> W.line <>
236 "- either -i FILE parameter" <> W.line <>
237 "- or LEDGER_FILE environment variable."
238 Message_failed_to_read_file path ->
239 "failed to read file: " <> (#)path
240 Message_failed_to_include_file path ->
241 "failed to include file: " <> (#)path
242 Message_the_following_transaction_is_not_equilibrated_because ->
243 "the following transaction is not equilibrated, because:"
244 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
245 "the following virtual transaction is not equilibrated, because:"
246 Message_unit_sums_up_to_the_non_null_amount unit amount ->
247 " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
248 Message_year_or_day_is_missing ->
249 "year or day is missing"
250 Message_invalid_date year month day ->
251 "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
252 Message_invalid_time_of_day hour minute second ->
253 "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
254 Message_unexpect doc ->
256 Message_sysunexpect doc ->
257 "is written : " <> (#)doc
258 Message_expect doc ->
259 "but expect : " <> (#)doc
260 Message_message doc ->
262 Message_sysunexpect_end_of_input ->
263 "end of file unexpected"
274 Message_Running_debit ->
276 Message_Running_credit ->
278 Message_Running_balance ->
284 Message_Description ->
286 Message_Equilibrium ->
288 Message_Equilibrium_posting ->
289 "Equilibrium posting"
290 Message_Balance_Description negate_transaction ->
291 case negate_transaction of
292 True -> "Closing balance"
293 False -> "Opening balance"
298 Message_no_ledger_file_given ->
299 "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
300 " - soit le paramètre -i FICHIER," <> W.line <>
301 " - soit la variable d’environnement LEDGER_FILE."
302 Message_failed_to_read_file path ->
303 "échec de la lecture du fichier : " <> (#)path
304 Message_failed_to_include_file path ->
305 "échec à l’inclusion du fichier : " <> (#)path
306 Message_the_following_transaction_is_not_equilibrated_because ->
307 "la transaction suivante n’est pas équilibrée, car :"
308 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
309 "la transaction virtuelle suivante n’est pas équilibrée, car :"
310 Message_unit_sums_up_to_the_non_null_amount unit amount ->
311 " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
312 Message_year_or_day_is_missing ->
313 "l’année ou le jour est manquant-e"
314 Message_invalid_date year month day ->
315 "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
316 Message_invalid_time_of_day hour minute second ->
317 "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
318 Message_unexpect doc ->
319 "trouve : " <> (#)doc
320 Message_sysunexpect doc ->
321 "est écrit : " <> (#)doc
322 Message_expect doc ->
323 "mais s’attend à : " <> (#)doc
324 Message_message doc ->
326 Message_sysunexpect_end_of_input ->
327 "fin de fichier inattendue"
338 Message_Running_debit ->
340 Message_Running_credit ->
342 Message_Running_balance ->
348 Message_Description ->
350 Message_Equilibrium ->
352 Message_Equilibrium_posting ->
353 "Mouvement d’équilibre"
354 Message_Balance_Description negate_transaction ->
355 case negate_transaction of
356 True -> "Solde de clôture"
357 False -> "Solde d’ouverture"