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