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"