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 (\c -> c /= '.') ) $
  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 instance ToDoc Lang Message where
 227         toDoc EN msg =
 228                 case msg of
 229                  Message_ERROR ->
 230                         "ERROR"
 231                  Message_no_ledger_file_given ->
 232                         "no ledger file given, please use:" <> W.line <>
 233                         "- either -i FILE parameter" <> W.line <>
 234                         "- or LEDGER_FILE environment variable."
 235                  Message_failed_to_read_file path ->
 236                         "failed to read file: " <> (#)path
 237                  Message_failed_to_include_file path ->
 238                         "failed to include file: " <> (#)path
 239                  Message_the_following_transaction_is_not_equilibrated_because ->
 240                         "the following transaction is not equilibrated, because:"
 241                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 242                         "the following virtual transaction is not equilibrated, because:"
 243                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 244                         " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
 245                  Message_year_or_day_is_missing ->
 246                         "year or day is missing"
 247                  Message_invalid_date year month day ->
 248                         "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
 249                  Message_invalid_time_of_day hour minute second ->
 250                         "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
 251                  Message_unexpect doc ->
 252                         "found : " <> (#)doc
 253                  Message_sysunexpect doc ->
 254                         "is written : " <> (#)doc
 255                  Message_expect doc ->
 256                         "but expect : " <> (#)doc
 257                  Message_message doc ->
 258                         (#)doc
 259                  Message_sysunexpect_end_of_input ->
 260                         "end of file unexpected"
 261                  Message_unknown ->
 262                         "unkown"
 263                  Message_or ->
 264                         "or"
 265                  Message_Balance ->
 266                         "Balance"
 267                  Message_Debit ->
 268                         "Debit"
 269                  Message_Credit ->
 270                         "Credit"
 271                  Message_Running_debit ->
 272                         "Running debit"
 273                  Message_Running_credit ->
 274                         "Running credit"
 275                  Message_Running_balance ->
 276                         "Running balance"
 277                  Message_Account ->
 278                         "Account"
 279                  Message_Date ->
 280                         "Date"
 281                  Message_Description ->
 282                         "Description"
 283         toDoc FR msg =
 284                 case msg of
 285                  Message_ERROR ->
 286                         "ERREUR"
 287                  Message_no_ledger_file_given ->
 288                         "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
 289                         " - soit le paramètre -i FICHIER," <> W.line <>
 290                         " - soit la variable d’environnement LEDGER_FILE."
 291                  Message_failed_to_read_file path ->
 292                         "échec de la lecture du fichier : " <> (#)path
 293                  Message_failed_to_include_file path ->
 294                         "échec à l’inclusion du fichier : " <> (#)path
 295                  Message_the_following_transaction_is_not_equilibrated_because ->
 296                         "la transaction suivante n’est pas équilibrée, car :"
 297                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 298                         "la transaction virtuelle suivante n’est pas équilibrée, car :"
 299                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 300                         " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
 301                  Message_year_or_day_is_missing ->
 302                         "l’année ou le jour est manquant-e"
 303                  Message_invalid_date year month day ->
 304                         "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
 305                  Message_invalid_time_of_day hour minute second ->
 306                         "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
 307                  Message_unexpect doc ->
 308                         "trouve : " <> (#)doc
 309                  Message_sysunexpect doc ->
 310                         "est écrit : " <> (#)doc
 311                  Message_expect doc ->
 312                         "mais s’attend à : " <> (#)doc
 313                  Message_message doc ->
 314                         (#)doc
 315                  Message_sysunexpect_end_of_input ->
 316                         "fin de fichier inattendue"
 317                  Message_unknown ->
 318                         "inconnu"
 319                  Message_or ->
 320                         "ou"
 321                  Message_Balance ->
 322                         "Solde"
 323                  Message_Debit ->
 324                         "Débit"
 325                  Message_Credit ->
 326                         "Crédit"
 327                  Message_Running_debit ->
 328                         "Débit cumulé"
 329                  Message_Running_credit ->
 330                         "Crédit cumulé"
 331                  Message_Running_balance ->
 332                         "Solde cumulé"
 333                  Message_Account ->
 334                         "Compte"
 335                  Message_Date ->
 336                         "Date"
 337                  Message_Description ->
 338                         "Libellé"