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           Prelude hiding (error)
   9 import           Control.Monad (liftM)
  10 import qualified Data.List
  11 import           Data.Maybe (catMaybes, fromMaybe)
  12 import qualified Data.Text
  13 import           Data.Text (Text)
  14 import qualified Data.Text.Lazy as TL
  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 qualified Hcompta.Format.Ledger.Write as Ledger.Write
  21 import           Hcompta.Model.Amount.Unit (Unit)
  22 import           Hcompta.Model.Amount (Amount)
  23 import qualified Hcompta.Model.Date.Read as Date.Read
  24 import qualified Hcompta.Model.Filter.Read as Filter.Read
  25 import qualified Hcompta.Lib.Leijen as W
  26 import           Hcompta.Lib.Leijen (ToDoc(..), (<>))
  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 _ = Ledger.Write.unit
  77 instance ToDoc m Amount where
  78         toDoc _ = Ledger.Write.amount
  79 instance ToDoc Lang Date.Read.Error where
  80         toDoc FR Date.Read.Error_year_or_day_is_missing =
  81                 "l’année ou le jour est manquant·e"
  82         toDoc FR (Date.Read.Error_invalid_date (year, month, day)) =
  83                 "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
  84         toDoc FR (Date.Read.Error_invalid_time_of_day (hour, minute, second)) =
  85                 "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
  86         toDoc EN Date.Read.Error_year_or_day_is_missing =
  87                 "year or day is missing"
  88         toDoc EN (Date.Read.Error_invalid_date (year, month, day)) =
  89                 "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
  90         toDoc EN (Date.Read.Error_invalid_time_of_day (hour, minute, second)) =
  91                 "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
  92 instance ToDoc Lang Parsec.SourcePos where
  93         toDoc EN pos = do
  94                 let line = Parsec.sourceLine   pos
  95                 let col  = Parsec.sourceColumn pos
  96                 case Parsec.sourceName pos of
  97                  ""   -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
  98                  path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
  99         toDoc FR pos = do
 100                 let line = Parsec.sourceLine   pos
 101                 let col  = Parsec.sourceColumn pos
 102                 case Parsec.sourceName pos of
 103                  ""   -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
 104                  path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
 105 instance ToDoc Lang e
 106  => ToDoc Lang [Lib.Parsec.Error e] where
 107         toDoc lang errors =
 108                 W.vsep $ do
 109                 (flip map) errors $ (\error ->
 110                         case error of
 111                          Lib.Parsec.Error_At pos errs -> W.vsep $
 112                                 [ toDoc lang pos
 113                                 , toDoc lang errs
 114                                 ]
 115                          Lib.Parsec.Error_Parser err ->
 116                                 W.vsep $
 117                                  [ toDoc lang (Parsec.errorPos err)
 118                                  , showErrorMessages
 119                                          (Parsec.Error.errorMessages err)
 120                                  ]
 121                          Lib.Parsec.Error_Custom pos err -> W.vsep $
 122                                 [ toDoc lang pos
 123                                 , toDoc lang err
 124                                 ]
 125                  )
 126                 where
 127                         showErrorMessages :: [Parsec.Error.Message] -> W.Doc
 128                         showErrorMessages msgs
 129                                 | null msgs = toDoc lang $ Message_unknown
 130                                 | otherwise = W.vsep $ -- clean $
 131                                         [showSysUnExpect, showUnExpect, showExpect, showMessages]
 132                                 where
 133                                         (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
 134                                         (unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
 135                                         (expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
 136
 137                                         showExpect   = showMany (Just (toDoc lang . Message_expect)) expect
 138                                         showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect
 139                                         showSysUnExpect
 140                                          | not (null unExpect) || null sysUnExpect = W.empty
 141                                          | null firstMsg = toDoc lang $ Message_sysunexpect_end_of_input
 142                                          | otherwise     = toDoc lang $ Message_sysunexpect firstMsg
 143                                                 where
 144                                                 firstMsg = Parsec.Error.messageString (head sysUnExpect)
 145
 146                                         showMessages = showMany Nothing messages
 147
 148                                         -- helpers
 149                                         showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
 150                                         showMany pre msgs_ =
 151                                                 case clean (map Parsec.Error.messageString msgs_) of
 152                                                  [] -> W.empty
 153                                                  ms ->
 154                                                         case pre of
 155                                                          Nothing -> commasOr ms
 156                                                          Just p -> p $ commasOr ms
 157
 158                                         commasOr :: [String] -> W.Doc
 159                                         commasOr []  = W.empty
 160                                         commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
 161                                         commasOr ms  = commaSep (init ms)
 162                                                        <> (W.space <> toDoc lang Message_or <> W.space)
 163                                                        <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
 164                                         commaSep = W.intercalate (W.comma <> W.space)
 165                                                    (W.bold . W.dullblack . W.text . TL.pack)
 166                                                    . clean
 167
 168                                         clean = Data.List.nub . filter (not . null)
 169 instance ToDoc Lang Filter.Read.Error where
 170         toDoc FR err =
 171                 case err of
 172                  Filter.Read.Error_Unknown -> "erreur"
 173         toDoc EN err =
 174                 case err of
 175                  Filter.Read.Error_Unknown -> "error"
 176
 177 data Message
 178  = Message_ERROR
 179  | Message_no_ledger_file_given
 180  | Message_failed_to_read_file
 181         {message_path :: FilePath}
 182  | Message_failed_to_include_file
 183         {message_path :: FilePath}
 184  | Message_the_following_transaction_is_not_equilibrated_because {}
 185  | Message_the_following_virtual_transaction_is_not_equilibrated_because {}
 186  | Message_unit_sums_up_to_the_non_null_amount
 187         {message_Unit   :: Unit
 188         ,message_Amount :: Amount}
 189  | Message_year_or_day_is_missing {}
 190  | Message_invalid_date
 191         {message_Year  :: Integer
 192         ,message_Month :: Int
 193         ,message_Day   :: Int
 194         }
 195  | Message_invalid_time_of_day
 196         { message_Hour   :: Int
 197         , message_Month  :: Int
 198         , message_Second :: Integer
 199         }
 200  | Message_unexpect {message_Doc :: W.Doc}
 201  | Message_sysunexpect {message_Msg :: String}
 202  | Message_expect {message_Doc :: W.Doc}
 203  | Message_message {message_Msg :: String}
 204  | Message_sysunexpect_end_of_input {}
 205  | Message_unknown {}
 206  | Message_or {}
 207  | Message_Balance_total {}
 208  | Message_Balance_debit {}
 209  | Message_Balance_credit {}
 210  | Message_Account {}
 211 instance ToDoc Lang Message where
 212         toDoc EN msg =
 213                 case msg of
 214                  Message_ERROR ->
 215                         "ERROR"
 216                  Message_no_ledger_file_given ->
 217                         "no ledger file given, please use:" <> W.line <>
 218                         "- either -i FILE parameter" <> W.line <>
 219                         "- or LEDGER_FILE environment variable."
 220                  Message_failed_to_read_file path ->
 221                         "failed to read file: " <> (#)path
 222                  Message_failed_to_include_file path ->
 223                         "failed to include file: " <> (#)path
 224                  Message_the_following_transaction_is_not_equilibrated_because ->
 225                         "the following transaction is not equilibrated, because:"
 226                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 227                         "the following virtual transaction is not equilibrated, because:"
 228                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 229                         " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount
 230                  Message_year_or_day_is_missing ->
 231                         "year or day is missing"
 232                  Message_invalid_date year month day ->
 233                         "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
 234                  Message_invalid_time_of_day hour minute second ->
 235                         "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
 236                  Message_unexpect doc ->
 237                         "found : " <> (#)doc
 238                  Message_sysunexpect doc ->
 239                         "is written : " <> (#)doc
 240                  Message_expect doc ->
 241                         "but expect : " <> (#)doc
 242                  Message_message doc ->
 243                         (#)doc
 244                  Message_sysunexpect_end_of_input ->
 245                         "end of file unexpected"
 246                  Message_unknown ->
 247                         "unkown"
 248                  Message_or ->
 249                         "or"
 250                  Message_Balance_total ->
 251                         "Balance"
 252                  Message_Balance_debit ->
 253                         "Debit"
 254                  Message_Balance_credit ->
 255                         "Credit"
 256                  Message_Account ->
 257                         "Account"
 258         toDoc FR msg =
 259                 case msg of
 260                  Message_ERROR ->
 261                         "ERREUR"
 262                  Message_no_ledger_file_given ->
 263                         "aucun fichier indiqué, veuillez utiliser :" <> W.line <>
 264                         " - soit le paramètre -i FICHIER," <> W.line <>
 265                         " - soit la variable d’environnement LEDGER_FILE."
 266                  Message_failed_to_read_file path ->
 267                         "échec de la lecture du fichier : " <> (#)path
 268                  Message_failed_to_include_file path ->
 269                         "échec à l’inclusion du fichier : " <> (#)path
 270                  Message_the_following_transaction_is_not_equilibrated_because ->
 271                         "la transaction suivante n’est pas équilibrée, car :"
 272                  Message_the_following_virtual_transaction_is_not_equilibrated_because ->
 273                         "la transaction virtuelle suivante n’est pas équilibrée, car :"
 274                  Message_unit_sums_up_to_the_non_null_amount unit amount ->
 275                         " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount
 276                  Message_year_or_day_is_missing ->
 277                         "l’année ou le jour est manquant-e"
 278                  Message_invalid_date year month day ->
 279                         "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
 280                  Message_invalid_time_of_day hour minute second ->
 281                         "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
 282                  Message_unexpect doc ->
 283                         "trouve : " <> (#)doc
 284                  Message_sysunexpect doc ->
 285                         "est écrit : " <> (#)doc
 286                  Message_expect doc ->
 287                         "mais s’attend à : " <> (#)doc
 288                  Message_message doc ->
 289                         (#)doc
 290                  Message_sysunexpect_end_of_input ->
 291                         "fin de fichier inattendue"
 292                  Message_unknown ->
 293                         "inconnu"
 294                  Message_or ->
 295                         "ou"
 296                  Message_Balance_total ->
 297                         "Solde"
 298                  Message_Balance_debit ->
 299                         "Débit"
 300                  Message_Balance_credit ->
 301                         "Crédit"
 302                  Message_Account ->
 303                         "Compte"