cli/Hcompta/CLI/Format/Ledger.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.CLI.Format.Ledger where
   8
   9 import           Prelude hiding (error)
  10 import           Control.Exception (tryJust)
  11 import           Control.Monad (guard)
  12 import qualified Data.List
  13 import qualified Data.Text.Lazy as TL
  14 import           System.Environment as Env (getEnv)
  15 import           System.IO.Error (isDoesNotExistError)
  16 import qualified Text.Parsec as Parsec
  17 import qualified Text.Parsec.Error as Parsec.Error
  18
  19 import qualified Hcompta.Lib.Leijen as W
  20 import           Hcompta.Lib.Leijen (ToDoc(..), (<>))
  21 import qualified Hcompta.Lib.Parsec as Lib.Parsec
  22 import qualified Hcompta.Calc.Balance as Calc.Balance
  23 import qualified Hcompta.CLI.Context as Context
  24 import           Hcompta.CLI.Context (Context)
  25 import qualified Hcompta.CLI.I18N as I18N
  26 import qualified Hcompta.CLI.Write as Write
  27 import qualified Hcompta.Model.Filter.Read as Filter.Read
  28 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  29 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  30 import qualified Hcompta.Model.Amount as Amount
  31
  32 -- | Return 'FilePath's containing 'Hcompta.Format.Ledger.Journal's:
  33 --
  34 -- * either those given if any,
  35 -- * or the one in LEDGER_FILE environment variable if any,
  36 -- * or the one in LEDGER environment variable if any.
  37 paths :: Context.Context -> [FilePath] -> IO [FilePath]
  38 paths context [] = do
  39         tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER_FILE"
  40         >>= \x -> case x of
  41          Right ok -> return [ok]
  42          Left  _ko -> do
  43                 tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER"
  44                 >>= \xx -> case xx of
  45                  Right ok -> return [ok]
  46                  Left  _ko -> do
  47                         let langs = Context.langs context
  48                         Write.fatal context $
  49                                 I18N.render langs
  50                                 I18N.Message_no_ledger_file_given
  51 paths _context ps = return ps
  52
  53 instance ToDoc Context Parsec.SourcePos where
  54         toDoc context pos = do
  55                 let langs = Context.langs context
  56                 I18N.render langs $ do
  57                 case Parsec.sourceName pos of
  58                  "" -> I18N.Message_at
  59                          (Parsec.sourceLine pos)
  60                          (Parsec.sourceColumn pos)
  61                  path -> I18N.Message_in_file path
  62                          (Parsec.sourceLine pos)
  63                          (Parsec.sourceColumn pos)
  64
  65 instance ToDoc Context e => ToDoc Context [Lib.Parsec.Error e] where
  66         toDoc context errors =
  67                 W.vsep $ do
  68                 (flip map) errors $ (\error ->
  69                         case error of
  70                          Lib.Parsec.Error_At pos errs -> W.vsep $
  71                                 [ toDoc context pos
  72                                 , toDoc context errs
  73                                 ]
  74                          Lib.Parsec.Error_Parser err ->
  75                                 W.vsep $
  76                                  [ toDoc context (Parsec.errorPos err)
  77                                  , showErrorMessages
  78                                          (Parsec.Error.errorMessages err)
  79                                  ]
  80                          Lib.Parsec.Error_Custom pos err -> W.vsep $
  81                                 [ toDoc context pos
  82                                 , toDoc context err
  83                                 ]
  84                  )
  85                 where
  86                         langs = Context.langs context
  87                         showErrorMessages :: [Parsec.Error.Message] -> W.Doc
  88                         showErrorMessages msgs
  89                                 | null msgs = i18n $ I18N.Message_unknown
  90                                 | otherwise = W.vsep $ -- clean $
  91                                         [showSysUnExpect, showUnExpect, showExpect, showMessages]
  92                                 where
  93                                         i18n = I18N.render langs
  94                                         (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
  95                                         (unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
  96                                         (expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
  97
  98                                         showExpect   = showMany (Just (i18n . I18N.Message_expect)) expect
  99                                         showUnExpect = showMany (Just (i18n . I18N.Message_unexpect)) unExpect
 100                                         showSysUnExpect
 101                                          | not (null unExpect) || null sysUnExpect = W.empty
 102                                          | null firstMsg = i18n $ I18N.Message_sysunexpect_end_of_input
 103                                          | otherwise     = i18n $ I18N.Message_sysunexpect firstMsg
 104                                                 where
 105                                                 firstMsg = Parsec.Error.messageString (head sysUnExpect)
 106
 107                                         showMessages = showMany Nothing messages
 108
 109                                         -- helpers
 110                                         showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
 111                                         showMany pre msgs_ =
 112                                                 case clean (map Parsec.Error.messageString msgs_) of
 113                                                  [] -> W.empty
 114                                                  ms ->
 115                                                         case pre of
 116                                                          Nothing -> commasOr ms
 117                                                          Just p -> p $ commasOr ms
 118
 119                                         commasOr :: [String] -> W.Doc
 120                                         commasOr []  = W.empty
 121                                         commasOr [m] = W.text $ TL.pack m
 122                                         commasOr ms  = commaSep (init ms)
 123                                                        <> (W.space <> i18n I18N.Message_or <> W.space)
 124                                                        <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
 125                                         commaSep = W.intercalate (W.comma <> W.space)
 126                                                    (W.bold . W.dullblack . W.text . TL.pack)
 127                                                    . clean
 128
 129                                         clean = Data.List.nub . filter (not . null)
 130
 131 instance ToDoc Context Ledger.Read.Error where
 132         toDoc context err =
 133                 case err of
 134                  Ledger.Read.Error_year_or_day_is_missing ->
 135                         I18N.render langs $ I18N.Message_year_or_day_is_missing
 136                  Ledger.Read.Error_invalid_date (y, m, d) ->
 137                         I18N.render langs $ I18N.Message_invalid_date y m d
 138                  Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
 139                         I18N.render langs $ I18N.Message_invalid_time_of_day h m s
 140                  Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
 141                         i18n_transaction_not_equilibrated tr unit_sums
 142                          I18N.Message_the_following_transaction_is_not_equilibrated_because
 143                  Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
 144                         i18n_transaction_not_equilibrated tr unit_sums
 145                          I18N.Message_the_following_virtual_transaction_is_not_equilibrated_because
 146                  Ledger.Read.Error_reading_file file_path exn -> W.vsep $
 147                          [ I18N.render langs $
 148                                 I18N.Message_failed_to_read_file file_path
 149                          , W.text $ TL.pack $ show exn
 150                          ]
 151                  Ledger.Read.Error_including_file file_path errs -> W.vsep $
 152                          [ I18N.render langs $
 153                                 I18N.Message_failed_to_include_file file_path
 154                          , toDoc context errs
 155                          ]
 156                 where
 157                         langs = Context.langs context
 158                         i18n_transaction_not_equilibrated tr unit_sums msg =
 159                                 W.vsep $
 160                                  [ I18N.render langs msg
 161                                  , W.vsep $ Data.List.map
 162                                          (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} ->
 163                                                 let amt = Calc.Balance.amount_sum_balance unit_sum_amount in
 164                                                 I18N.render langs $
 165                                                 I18N.Message_unit_sums_up_to_the_non_null_amount
 166                                                  (Amount.unit amt) amt
 167                                          ) unit_sums
 168                                  , W.space
 169                                  , Ledger.Write.transaction tr
 170                                  ]
 171
 172 instance ToDoc Context Filter.Read.Error where
 173         toDoc context err =
 174                 case err of
 175                  Filter.Read.Error_Unknown -> toDoc context ("error"::String)