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 Prelude hiding (error)
9 import Control.Monad (liftM)
10 import qualified Data.List
11 import Data.Maybe (catMaybes, fromMaybe)
12 import qualified Data.Text
13 import Data.Text (Text)
14 import qualified Data.Text.Lazy as TL
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 qualified Hcompta.Format.Ledger.Write as Ledger.Write
21 import Hcompta.Model.Amount.Unit (Unit)
22 import Hcompta.Model.Amount (Amount)
23 import qualified Hcompta.Model.Date.Read as Date.Read
24 import qualified Hcompta.Model.Filter.Read as Filter.Read
25 import qualified Hcompta.Lib.Leijen as W
26 import Hcompta.Lib.Leijen (ToDoc(..), (<>))
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 (\c -> c /= '.') ) $
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 _ = Ledger.Write.unit
77 instance ToDoc m Amount where
78 toDoc _ = Ledger.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_Test_Date d -> toDoc lang d
180 Filter.Read.Error_Unknown -> "error"
181 Filter.Read.Error_Test_Date d -> toDoc lang d
185 | Message_no_ledger_file_given
186 | Message_failed_to_read_file
187 {message_path :: FilePath}
188 | Message_failed_to_include_file
189 {message_path :: FilePath}
190 | Message_the_following_transaction_is_not_equilibrated_because {}
191 | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
192 | Message_unit_sums_up_to_the_non_null_amount
193 {message_Unit :: Unit
194 ,message_Amount :: Amount}
195 | Message_year_or_day_is_missing {}
196 | Message_invalid_date
197 {message_Year :: Integer
198 ,message_Month :: Int
201 | Message_invalid_time_of_day
202 { message_Hour :: Int
203 , message_Month :: Int
204 , message_Second :: Integer
206 | Message_unexpect {message_Doc :: W.Doc}
207 | Message_sysunexpect {message_Msg :: String}
208 | Message_expect {message_Doc :: W.Doc}
209 | Message_message {message_Msg :: String}
210 | Message_sysunexpect_end_of_input {}
213 | Message_Balance_total {}
214 | Message_Balance_debit {}
215 | Message_Balance_credit {}
217 instance ToDoc Lang Message where
222 Message_no_ledger_file_given ->
223 "no ledger file given, please use:" <> W.line <>
224 "- either -i FILE parameter" <> W.line <>
225 "- or LEDGER_FILE environment variable."
226 Message_failed_to_read_file path ->
227 "failed to read file: " <> (#)path
228 Message_failed_to_include_file path ->
229 "failed to include file: " <> (#)path
230 Message_the_following_transaction_is_not_equilibrated_because ->
231 "the following transaction is not equilibrated, because:"
232 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
233 "the following virtual transaction is not equilibrated, because:"
234 Message_unit_sums_up_to_the_non_null_amount unit amount ->
235 " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
236 Message_year_or_day_is_missing ->
237 "year or day is missing"
238 Message_invalid_date year month day ->
239 "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
240 Message_invalid_time_of_day hour minute second ->
241 "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
242 Message_unexpect doc ->
244 Message_sysunexpect doc ->
245 "is written : " <> (#)doc
246 Message_expect doc ->
247 "but expect : " <> (#)doc
248 Message_message doc ->
250 Message_sysunexpect_end_of_input ->
251 "end of file unexpected"
256 Message_Balance_total ->
258 Message_Balance_debit ->
260 Message_Balance_credit ->
268 Message_no_ledger_file_given ->
269 "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
270 " - soit le paramètre -i FICHIER," <> W.line <>
271 " - soit la variable d’environnement LEDGER_FILE."
272 Message_failed_to_read_file path ->
273 "échec de la lecture du fichier : " <> (#)path
274 Message_failed_to_include_file path ->
275 "échec à l’inclusion du fichier : " <> (#)path
276 Message_the_following_transaction_is_not_equilibrated_because ->
277 "la transaction suivante n’est pas équilibrée, car :"
278 Message_the_following_virtual_transaction_is_not_equilibrated_because ->
279 "la transaction virtuelle suivante n’est pas équilibrée, car :"
280 Message_unit_sums_up_to_the_non_null_amount unit amount ->
281 " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
282 Message_year_or_day_is_missing ->
283 "l’année ou le jour est manquant-e"
284 Message_invalid_date year month day ->
285 "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
286 Message_invalid_time_of_day hour minute second ->
287 "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
288 Message_unexpect doc ->
289 "trouve : " <> (#)doc
290 Message_sysunexpect doc ->
291 "est écrit : " <> (#)doc
292 Message_expect doc ->
293 "mais s’attend à : " <> (#)doc
294 Message_message doc ->
296 Message_sysunexpect_end_of_input ->
297 "fin de fichier inattendue"
302 Message_Balance_total ->
304 Message_Balance_debit ->
306 Message_Balance_credit ->