cli/Hcompta/CLI/Lang.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TupleSections #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.CLI.Lang where
   8
   9 import           Control.Monad (liftM)
  10 import qualified Data.List
  11 import           Data.Maybe (catMaybes, fromMaybe)
  12 import           Data.List.NonEmpty (NonEmpty(..))
  13 import qualified Data.Text
  14 import           Data.Text (Text)
  15 import qualified Data.Text.Lazy as TL
  16 import           Prelude hiding (error)
  17 import           System.Environment (getEnvironment)
  18 import           System.IO.Memoize (once)
  19 import qualified Text.Parsec as Parsec
  20 import qualified Text.Parsec.Error as Parsec.Error
  21
  22 import           Hcompta.Account (Account)
  23 import qualified Hcompta.Account as Account
  24 import           Hcompta.Amount (Amount)
  25 import           Hcompta.Amount.Unit (Unit)
  26 import qualified Hcompta.Amount.Write as Amount.Write
  27 import           Hcompta.Date (Date)
  28 import qualified Hcompta.Date.Read as Date.Read
  29 import qualified Hcompta.Date.Write as Date.Write
  30 import qualified Hcompta.Filter.Read as Filter.Read
  31 import           Hcompta.Lib.Leijen (ToDoc(..), (<>))
  32 import qualified Hcompta.Lib.Leijen as W
  33 import qualified Hcompta.Lib.Parsec as Lib.Parsec
  34 import           Hcompta.Tag (Tag)
  35
  36 data Lang
  37  = FR
  38  | EN
  39  deriving (Show)
  40
  41 class Translate from to where
  42         translate :: Lang -> from -> to
  43
  44 -- TODO: check that this is expected behavior
  45 --       and portability issues
  46 get_lang :: IO Lang
  47 get_lang = do
  48         once getEnvironment
  49         >>= liftM (\env ->
  50                 fromMaybe EN $ lang_of_strings $
  51                 Data.List.concatMap
  52                  ((\lang ->
  53                         let short = takeWhile (/= '_') lang in
  54                         if short == lang
  55                         then [lang]
  56                         else [lang, short])
  57                  . Data.List.takeWhile (/= '.') ) $
  58                 catMaybes
  59                  [ Data.List.lookup "LC_ALL"   env
  60                  , Data.List.lookup "LC_CTYPE" env
  61                  , Data.List.lookup "LANG"     env
  62                  ])
  63
  64 lang_of_strings :: [String] -> Maybe Lang
  65 lang_of_strings s =
  66         case s of
  67          ("fr"   :_) -> Just $ FR
  68          ("fr_FR":_) -> Just $ FR
  69          ("en"   :_) -> Just $ EN
  70          ("en_US":_) -> Just $ EN
  71          (_:xs)      -> lang_of_strings xs
  72          []          -> Nothing
  73
  74 (#) :: ToDoc () a => a -> W.Doc
  75 (#) = toDoc ()
  76
  77 instance ToDoc m Text where
  78         toDoc _ = W.strict_text
  79 instance ToDoc m String where
  80         toDoc _ = W.strict_text . Data.Text.pack
  81 instance ToDoc m Int where
  82         toDoc _ = W.int
  83 instance ToDoc m Integer where
  84         toDoc _ = W.integer
  85 instance ToDoc m Unit where
  86         toDoc _ = Amount.Write.unit
  87 instance ToDoc m Amount where
  88         toDoc _ = Amount.Write.amount
  89 instance ToDoc m Date where
  90         toDoc _ = Date.Write.date
  91 instance ToDoc Lang Date.Read.Error where
  92         toDoc FR e =
  93                 case e of
  94                  Date.Read.Error_year_or_day_is_missing ->
  95                         "l’année ou le jour est manquant·e"
  96                  Date.Read.Error_invalid_date (year, month, day) ->
  97                         "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
  98                  Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
  99                         "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
 100         toDoc EN e =
 101                 case e of
 102                  Date.Read.Error_year_or_day_is_missing ->
 103                         "year or day is missing"
 104                  Date.Read.Error_invalid_date (year, month, day) ->
 105                         "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
 106                  Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
 107                         "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
 108 instance ToDoc Lang Parsec.SourcePos where
 109         toDoc EN pos = do
 110                 let line = Parsec.sourceLine   pos
 111                 let col  = Parsec.sourceColumn pos
 112                 case Parsec.sourceName pos of
 113                  ""   -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
 114                  path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
 115         toDoc FR pos = do
 116                 let line = Parsec.sourceLine   pos
 117                 let col  = Parsec.sourceColumn pos
 118                 case Parsec.sourceName pos of
 119                  ""   -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
 120                  path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
 121 instance ToDoc Lang e
 122  => ToDoc Lang [Lib.Parsec.Error e] where
 123         toDoc lang errors =
 124                 W.vsep $ do
 125                 (flip map) errors $ (\error ->
 126                         case error of
 127                          Lib.Parsec.Error_At pos errs -> W.vsep $
 128                                 [ toDoc lang pos
 129                                 , toDoc lang errs
 130                                 ]
 131                          Lib.Parsec.Error_Parser err ->
 132                                 W.vsep $
 133                                  [ toDoc lang (Parsec.errorPos err)
 134                                  , showErrorMessages
 135                                          (Parsec.Error.errorMessages err)
 136                                  ]
 137                          Lib.Parsec.Error_Custom pos err -> W.vsep $
 138                                 [ toDoc lang pos
 139                                 , toDoc lang err
 140                                 ]
 141                  )
 142                 where
 143                         showErrorMessages :: [Parsec.Error.Message] -> W.Doc
 144                         showErrorMessages msgs
 145                                 | null msgs = toDoc lang $ Message_unknown
 146                                 | otherwise = W.vsep $ -- clean $
 147                                         [showSysUnExpect, showUnExpect, showExpect, showMessages]
 148                                 where
 149                                         (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
 150                                         (unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
 151                                         (expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
 152
 153                                         showExpect   = showMany (Just (toDoc lang . Message_expect)) expect
 154                                         showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect
 155                                         showSysUnExpect
 156                                          | not (null unExpect) || null sysUnExpect = W.empty
 157                                          | null firstMsg = toDoc lang $ Message_sysunexpect_end_of_input
 158                                          | otherwise     = toDoc lang $ Message_sysunexpect firstMsg
 159                                                 where
 160                                                 firstMsg = Parsec.Error.messageString (head sysUnExpect)
 161
 162                                         showMessages = showMany Nothing messages
 163
 164                                         -- helpers
 165                                         showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
 166                                         showMany pre msgs_ =
 167                                                 case clean (map Parsec.Error.messageString msgs_) of
 168                                                  [] -> W.empty
 169                                                  ms ->
 170                                                         case pre of
 171                                                          Nothing -> commasOr ms
 172                                                          Just p -> p $ commasOr ms
 173
 174                                         commasOr :: [String] -> W.Doc
 175                                         commasOr []  = W.empty
 176                                         commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
 177                                         commasOr ms  = commaSep (init ms)
 178                                                        <> (W.space <> toDoc lang Message_or <> W.space)
 179                                                        <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
 180                                         commaSep = W.intercalate (W.comma <> W.space)
 181                                                    (W.bold . W.dullblack . W.text . TL.pack)
 182                                                    . clean
 183
 184                                         clean = Data.List.nub . filter (not . null)
 185 instance ToDoc Lang Filter.Read.Error where
 186         toDoc lang@FR err =
 187                 case err of
 188                  Filter.Read.Error_Unknown -> "erreur"
 189                  Filter.Read.Error_Filter_Date d -> toDoc lang d
 190                  Filter.Read.Error_Filter_Date_Interval (l, h) ->
 191                         "mauvais intervalle: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"
 192         toDoc lang@EN err =
 193                 case err of
 194                  Filter.Read.Error_Unknown -> "error"
 195                  Filter.Read.Error_Filter_Date d -> toDoc lang d
 196                  Filter.Read.Error_Filter_Date_Interval (l, h) ->
 197                         "wrong interval: (" <> toDoc lang l <> ", " <> toDoc lang h <> ")"
 198
 199 data Message
 200  = Message_ERROR
 201  | Message_no_ledger_file_given
 202  | Message_failed_to_read_file
 203         {message_path :: FilePath}
 204  | Message_failed_to_include_file
 205         {message_path :: FilePath}
 206  | Message_the_following_transaction_is_not_equilibrated_because {}
 207  | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
 208  | Message_unit_sums_up_to_the_non_null_amount
 209         {message_Unit   :: Unit
 210         ,message_Amount :: Amount}
 211  | Message_year_or_day_is_missing {}
 212  | Message_invalid_date
 213         {message_Year  :: Integer
 214         ,message_Month :: Int
 215         ,message_Day   :: Int
 216         }
 217  | Message_invalid_time_of_day
 218         { message_Hour   :: Int
 219         , message_Month  :: Int
 220         , message_Second :: Integer
 221         }
 222  | Message_unexpect {message_Doc :: W.Doc}
 223  | Message_sysunexpect {message_Msg :: String}
 224  | Message_expect {message_Doc :: W.Doc}
 225  | Message_message {message_Msg :: String}
 226  | Message_sysunexpect_end_of_input {}
 227  | Message_unknown {}
 228  | Message_or {}
 229  | Message_Balance {}
 230  | Message_Debit {}
 231  | Message_Credit {}
 232  | Message_Running_debit {}
 233  | Message_Running_credit {}
 234  | Message_Running_balance {}
 235  | Message_Account {}
 236  | Message_Date {}
 237  | Message_Description {}
 238  | Message_Balance_Description Bool
 239  | Message_Accounts
 240  | Message_Depths
 241  | Message_Transactions
 242  | Message_Units
 243  | Message_Journals
 244  | Message_Tags
 245  | Message_Distincts
 246 instance ToDoc Lang Message where
 247         toDoc EN msg =
 248                 case msg of
 249                  Message_ERROR ->
 250                         "ERROR"
 251                  Message_no_ledger_file_given ->
 252                         "no ledger file given, please use:" <> W.line <>
 253                         "- either -i FILE parameter" <> W.line <>
 254                         "- or LEDGER_FILE environment variable."
 255                  Message_failed_to_read_file path ->
 256                         "failed to read file: " <> (#)path
 257                  Message_failed_to_include_file path ->
 258                         "failed to include file: " <> (#)path
 259                  Message_the_following_transaction_is_not_equilibrated_because ->
 260                         "the following transaction is not equilibrated, because:"
 261                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 262                         "the following virtual transaction is not equilibrated, because:"
 263                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 264                         " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
 265                  Message_year_or_day_is_missing ->
 266                         "year or day is missing"
 267                  Message_invalid_date year month day ->
 268                         "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
 269                  Message_invalid_time_of_day hour minute second ->
 270                         "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
 271                  Message_unexpect doc ->
 272                         "found : " <> (#)doc
 273                  Message_sysunexpect doc ->
 274                         "is written : " <> (#)doc
 275                  Message_expect doc ->
 276                         "but expect : " <> (#)doc
 277                  Message_message doc ->
 278                         (#)doc
 279                  Message_sysunexpect_end_of_input ->
 280                         "end of file unexpected"
 281                  Message_unknown ->
 282                         "unkown"
 283                  Message_or ->
 284                         "or"
 285                  Message_Balance ->
 286                         "Balance"
 287                  Message_Debit ->
 288                         "Debit"
 289                  Message_Credit ->
 290                         "Credit"
 291                  Message_Running_debit ->
 292                         "Running debit"
 293                  Message_Running_credit ->
 294                         "Running credit"
 295                  Message_Running_balance ->
 296                         "Running balance"
 297                  Message_Account ->
 298                         "Account"
 299                  Message_Date ->
 300                         "Date"
 301                  Message_Description ->
 302                         "Description"
 303                  Message_Balance_Description negate_transaction ->
 304                         case negate_transaction of
 305                          True  -> "Closing balance"
 306                          False -> "Opening balance"
 307                  Message_Accounts -> "Accounts"
 308                  Message_Depths -> "Depths"
 309                  Message_Transactions -> "Transactions"
 310                  Message_Units -> "Units"
 311                  Message_Journals -> "Journals"
 312                  Message_Tags -> "Tags"
 313                  Message_Distincts -> "Distincts"
 314         toDoc FR msg =
 315                 case msg of
 316                  Message_ERROR ->
 317                         "ERREUR"
 318                  Message_no_ledger_file_given ->
 319                         "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
 320                         " - soit le paramètre -i FICHIER," <> W.line <>
 321                         " - soit la variable d’environnement LEDGER_FILE."
 322                  Message_failed_to_read_file path ->
 323                         "échec de la lecture du fichier : " <> (#)path
 324                  Message_failed_to_include_file path ->
 325                         "échec à l’inclusion du fichier : " <> (#)path
 326                  Message_the_following_transaction_is_not_equilibrated_because ->
 327                         "la transaction suivante n’est pas équilibrée, car :"
 328                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 329                         "la transaction virtuelle suivante n’est pas équilibrée, car :"
 330                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 331                         " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
 332                  Message_year_or_day_is_missing ->
 333                         "l’année ou le jour est manquant-e"
 334                  Message_invalid_date year month day ->
 335                         "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
 336                  Message_invalid_time_of_day hour minute second ->
 337                         "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
 338                  Message_unexpect doc ->
 339                         "trouve : " <> (#)doc
 340                  Message_sysunexpect doc ->
 341                         "est écrit : " <> (#)doc
 342                  Message_expect doc ->
 343                         "mais s’attend à : " <> (#)doc
 344                  Message_message doc ->
 345                         (#)doc
 346                  Message_sysunexpect_end_of_input ->
 347                         "fin de fichier inattendue"
 348                  Message_unknown ->
 349                         "inconnu"
 350                  Message_or ->
 351                         "ou"
 352                  Message_Balance ->
 353                         "Solde"
 354                  Message_Debit ->
 355                         "Débit"
 356                  Message_Credit ->
 357                         "Crédit"
 358                  Message_Running_debit ->
 359                         "Débit cumulé"
 360                  Message_Running_credit ->
 361                         "Crédit cumulé"
 362                  Message_Running_balance ->
 363                         "Solde cumulé"
 364                  Message_Account ->
 365                         "Compte"
 366                  Message_Date ->
 367                         "Date"
 368                  Message_Description ->
 369                         "Libellé"
 370                  Message_Balance_Description negate_transaction ->
 371                         case negate_transaction of
 372                          True  -> "Solde de fermeture"
 373                          False -> "Solde d’ouverture"
 374                  Message_Accounts -> "Comptes"
 375                  Message_Depths -> "Profondeurs"
 376                  Message_Transactions -> "Écritures"
 377                  Message_Units -> "Unités"
 378                  Message_Journals -> "Journaux"
 379                  Message_Tags -> "Tags"
 380                  Message_Distincts -> "Distincts"
 381
 382 data Equilibrium
 383  =   Equilibrium
 384 instance Translate Equilibrium Account where
 385         translate EN t =
 386                 case t of
 387                  Equilibrium -> Account.account "Equilibrium" []
 388         translate FR t =
 389                 case t of
 390                  Equilibrium -> Account.account "Équilibre" []
 391
 392 data Equilibrium_posting
 393  =   Equilibrium_posting
 394 instance Translate Equilibrium_posting Text where
 395         translate EN t =
 396                 case t of
 397                  Equilibrium_posting -> "Equilibrium posting"
 398         translate FR t =
 399                 case t of
 400                  Equilibrium_posting -> "Mouvement d’équilibre"
 401
 402 data Exercise_OC
 403  =   Exercise_Opening
 404  |   Exercise_Closing
 405
 406 type Sign = Ordering
 407
 408 instance Translate (Exercise_OC, Sign) Tag where
 409         translate EN (oc, sign) =
 410                 let oc_section =
 411                         case oc of
 412                          Exercise_Opening -> "Opening"
 413                          Exercise_Closing -> "Closing" in
 414                 ("Exercise":|[oc_section,"Equilibrium"],) $
 415                 case sign of
 416                  LT -> "Credit"
 417                  EQ -> "Null"
 418                  GT -> "Debit"
 419         translate FR (oc, sign) =
 420                 let oc_section =
 421                         case oc of
 422                          Exercise_Opening -> "Ouverture"
 423                          Exercise_Closing -> "Fermeture" in
 424                 ("Exercice":|[oc_section,"Équilibre"],) $
 425                 case sign of
 426                  LT -> "Crédit"
 427                  EQ -> "Nul"
 428                  GT -> "Débit"