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_Test_Date         d -> toDoc lang d
 178         toDoc lang@EN err =
 179                 case err of
 180                  Filter.Read.Error_Unknown -> "error"
 181                  Filter.Read.Error_Test_Date         d -> toDoc lang d
 182
 183 data Message
 184  = Message_ERROR
 185  | Message_no_ledger_file_given
 186  | Message_failed_to_read_file
 187         {message_path :: FilePath}
 188  | Message_failed_to_include_file
 189         {message_path :: FilePath}
 190  | Message_the_following_transaction_is_not_equilibrated_because {}
 191  | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
 192  | Message_unit_sums_up_to_the_non_null_amount
 193         {message_Unit   :: Unit
 194         ,message_Amount :: Amount}
 195  | Message_year_or_day_is_missing {}
 196  | Message_invalid_date
 197         {message_Year  :: Integer
 198         ,message_Month :: Int
 199         ,message_Day   :: Int
 200         }
 201  | Message_invalid_time_of_day
 202         { message_Hour   :: Int
 203         , message_Month  :: Int
 204         , message_Second :: Integer
 205         }
 206  | Message_unexpect {message_Doc :: W.Doc}
 207  | Message_sysunexpect {message_Msg :: String}
 208  | Message_expect {message_Doc :: W.Doc}
 209  | Message_message {message_Msg :: String}
 210  | Message_sysunexpect_end_of_input {}
 211  | Message_unknown {}
 212  | Message_or {}
 213  | Message_Balance {}
 214  | Message_Debit {}
 215  | Message_Credit {}
 216  | Message_Running_debit {}
 217  | Message_Running_credit {}
 218  | Message_Running_balance {}
 219  | Message_Account {}
 220  | Message_Date {}
 221  | Message_Description {}
 222 instance ToDoc Lang Message where
 223         toDoc EN msg =
 224                 case msg of
 225                  Message_ERROR ->
 226                         "ERROR"
 227                  Message_no_ledger_file_given ->
 228                         "no ledger file given, please use:" <> W.line <>
 229                         "- either -i FILE parameter" <> W.line <>
 230                         "- or LEDGER_FILE environment variable."
 231                  Message_failed_to_read_file path ->
 232                         "failed to read file: " <> (#)path
 233                  Message_failed_to_include_file path ->
 234                         "failed to include file: " <> (#)path
 235                  Message_the_following_transaction_is_not_equilibrated_because ->
 236                         "the following transaction is not equilibrated, because:"
 237                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 238                         "the following virtual transaction is not equilibrated, because:"
 239                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 240                         " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
 241                  Message_year_or_day_is_missing ->
 242                         "year or day is missing"
 243                  Message_invalid_date year month day ->
 244                         "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
 245                  Message_invalid_time_of_day hour minute second ->
 246                         "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
 247                  Message_unexpect doc ->
 248                         "found : " <> (#)doc
 249                  Message_sysunexpect doc ->
 250                         "is written : " <> (#)doc
 251                  Message_expect doc ->
 252                         "but expect : " <> (#)doc
 253                  Message_message doc ->
 254                         (#)doc
 255                  Message_sysunexpect_end_of_input ->
 256                         "end of file unexpected"
 257                  Message_unknown ->
 258                         "unkown"
 259                  Message_or ->
 260                         "or"
 261                  Message_Balance ->
 262                         "Balance"
 263                  Message_Debit ->
 264                         "Debit"
 265                  Message_Credit ->
 266                         "Credit"
 267                  Message_Running_debit ->
 268                         "Running debit"
 269                  Message_Running_credit ->
 270                         "Running credit"
 271                  Message_Running_balance ->
 272                         "Running balance"
 273                  Message_Account ->
 274                         "Account"
 275                  Message_Date ->
 276                         "Date"
 277                  Message_Description ->
 278                         "Description"
 279         toDoc FR msg =
 280                 case msg of
 281                  Message_ERROR ->
 282                         "ERREUR"
 283                  Message_no_ledger_file_given ->
 284                         "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
 285                         " - soit le paramètre -i FICHIER," <> W.line <>
 286                         " - soit la variable d’environnement LEDGER_FILE."
 287                  Message_failed_to_read_file path ->
 288                         "échec de la lecture du fichier : " <> (#)path
 289                  Message_failed_to_include_file path ->
 290                         "échec à l’inclusion du fichier : " <> (#)path
 291                  Message_the_following_transaction_is_not_equilibrated_because ->
 292                         "la transaction suivante n’est pas équilibrée, car :"
 293                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 294                         "la transaction virtuelle suivante n’est pas équilibrée, car :"
 295                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 296                         " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
 297                  Message_year_or_day_is_missing ->
 298                         "l’année ou le jour est manquant-e"
 299                  Message_invalid_date year month day ->
 300                         "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
 301                  Message_invalid_time_of_day hour minute second ->
 302                         "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
 303                  Message_unexpect doc ->
 304                         "trouve : " <> (#)doc
 305                  Message_sysunexpect doc ->
 306                         "est écrit : " <> (#)doc
 307                  Message_expect doc ->
 308                         "mais s’attend à : " <> (#)doc
 309                  Message_message doc ->
 310                         (#)doc
 311                  Message_sysunexpect_end_of_input ->
 312                         "fin de fichier inattendue"
 313                  Message_unknown ->
 314                         "inconnu"
 315                  Message_or ->
 316                         "ou"
 317                  Message_Balance ->
 318                         "Solde"
 319                  Message_Debit ->
 320                         "Débit"
 321                  Message_Credit ->
 322                         "Crédit"
 323                  Message_Running_debit ->
 324                         "Débit cumulé"
 325                  Message_Running_credit ->
 326                         "Crédit cumulé"
 327                  Message_Running_balance ->
 328                         "Solde cumulé"
 329                  Message_Account ->
 330                         "Compte"
 331                  Message_Date ->
 332                         "Date"
 333                  Message_Description ->
 334                         "Libellé"