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