cli/Hcompta/CLI/Format/Ledger.hs

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