]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Lang.hs
Ajout : CLI.Command.Balance : --format {open,close}.
[comptalang.git] / cli / Hcompta / CLI / Lang.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Hcompta.CLI.Lang where
7
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
19
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
28
29 data Lang
30 = FR
31 | EN
32 deriving (Show)
33
34 -- TODO: check that this is expected behavior
35 -- and portability issues
36 get_lang :: IO Lang
37 get_lang = do
38 once getEnvironment
39 >>= liftM (\env ->
40 fromMaybe EN $ lang_of_strings $
41 Data.List.concatMap
42 ((\lang ->
43 let short = takeWhile (/= '_') lang in
44 if short == lang
45 then [lang]
46 else [lang, short])
47 . Data.List.takeWhile (/= '.') ) $
48 catMaybes
49 [ Data.List.lookup "LC_ALL" env
50 , Data.List.lookup "LC_CTYPE" env
51 , Data.List.lookup "LANG" env
52 ])
53
54 lang_of_strings :: [String] -> Maybe Lang
55 lang_of_strings s =
56 case s of
57 ("fr" :_) -> Just $ FR
58 ("fr_FR":_) -> Just $ FR
59 ("en" :_) -> Just $ EN
60 ("en_US":_) -> Just $ EN
61 (_:xs) -> lang_of_strings xs
62 [] -> Nothing
63
64 (#) :: ToDoc () a => a -> W.Doc
65 (#) = toDoc ()
66
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
72 toDoc _ = W.int
73 instance ToDoc m Integer where
74 toDoc _ = W.integer
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
80 toDoc FR e =
81 case e of
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 <> ")"
88 toDoc EN e =
89 case e of
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
97 toDoc EN pos = do
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
103 toDoc FR pos = do
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
111 toDoc lang errors =
112 W.vsep $ do
113 (flip map) errors $ (\error ->
114 case error of
115 Lib.Parsec.Error_At pos errs -> W.vsep $
116 [ toDoc lang pos
117 , toDoc lang errs
118 ]
119 Lib.Parsec.Error_Parser err ->
120 W.vsep $
121 [ toDoc lang (Parsec.errorPos err)
122 , showErrorMessages
123 (Parsec.Error.errorMessages err)
124 ]
125 Lib.Parsec.Error_Custom pos err -> W.vsep $
126 [ toDoc lang pos
127 , toDoc lang err
128 ]
129 )
130 where
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]
136 where
137 (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
138 (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1
139 (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2
140
141 showExpect = showMany (Just (toDoc lang . Message_expect)) expect
142 showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect
143 showSysUnExpect
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
147 where
148 firstMsg = Parsec.Error.messageString (head sysUnExpect)
149
150 showMessages = showMany Nothing messages
151
152 -- helpers
153 showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
154 showMany pre msgs_ =
155 case clean (map Parsec.Error.messageString msgs_) of
156 [] -> W.empty
157 ms ->
158 case pre of
159 Nothing -> commasOr ms
160 Just p -> p $ commasOr ms
161
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)
170 . clean
171
172 clean = Data.List.nub . filter (not . null)
173 instance ToDoc Lang Filter.Read.Error where
174 toDoc lang@FR err =
175 case err of
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 <> ")"
180 toDoc lang@EN err =
181 case err of
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 <> ")"
186
187 data Message
188 = Message_ERROR
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
203 ,message_Day :: Int
204 }
205 | Message_invalid_time_of_day
206 { message_Hour :: Int
207 , message_Month :: Int
208 , message_Second :: Integer
209 }
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 {}
215 | Message_unknown {}
216 | Message_or {}
217 | Message_Balance {}
218 | Message_Debit {}
219 | Message_Credit {}
220 | Message_Running_debit {}
221 | Message_Running_credit {}
222 | Message_Running_balance {}
223 | Message_Account {}
224 | Message_Date {}
225 | Message_Description {}
226 | Message_Equilibrium {}
227 | Message_Equilibrium_posting {}
228 | Message_Balance_Description Bool
229 instance ToDoc Lang Message where
230 toDoc EN msg =
231 case msg of
232 Message_ERROR ->
233 "ERROR"
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 ->
255 "found : " <> (#)doc
256 Message_sysunexpect doc ->
257 "is written : " <> (#)doc
258 Message_expect doc ->
259 "but expect : " <> (#)doc
260 Message_message doc ->
261 (#)doc
262 Message_sysunexpect_end_of_input ->
263 "end of file unexpected"
264 Message_unknown ->
265 "unkown"
266 Message_or ->
267 "or"
268 Message_Balance ->
269 "Balance"
270 Message_Debit ->
271 "Debit"
272 Message_Credit ->
273 "Credit"
274 Message_Running_debit ->
275 "Running debit"
276 Message_Running_credit ->
277 "Running credit"
278 Message_Running_balance ->
279 "Running balance"
280 Message_Account ->
281 "Account"
282 Message_Date ->
283 "Date"
284 Message_Description ->
285 "Description"
286 Message_Equilibrium ->
287 "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"
294 toDoc FR msg =
295 case msg of
296 Message_ERROR ->
297 "ERREUR"
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 ->
325 (#)doc
326 Message_sysunexpect_end_of_input ->
327 "fin de fichier inattendue"
328 Message_unknown ->
329 "inconnu"
330 Message_or ->
331 "ou"
332 Message_Balance ->
333 "Solde"
334 Message_Debit ->
335 "Débit"
336 Message_Credit ->
337 "Crédit"
338 Message_Running_debit ->
339 "Débit cumulé"
340 Message_Running_credit ->
341 "Crédit cumulé"
342 Message_Running_balance ->
343 "Solde cumulé"
344 Message_Account ->
345 "Compte"
346 Message_Date ->
347 "Date"
348 Message_Description ->
349 "Libellé"
350 Message_Equilibrium ->
351 "Équilibre"
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"