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.Lib.Shakespeare.Leijen 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.renderMessage Context.App langs
  49                                 Write.I18N_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.renderMessage Context.App langs $ do
  56                 case Parsec.sourceName pos of
  57                  "" -> Write.I18N_at
  58                          (Parsec.sourceLine pos)
  59                          (Parsec.sourceColumn pos)
  60                  path -> Write.I18N_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                                  {-
  80                                  : (flip Data.List.map)
  81                                          (uniq $ Parsec.Error.errorMessages err)
  82                                          (\e ->
  83                                                 I18N.renderMessage Context.App langs $
  84                                                 case e of
  85                                                  Parsec.Error.SysUnExpect msg -> Write.I18N_sysunexpect msg
  86                                                  Parsec.Error.UnExpect    msg -> Write.I18N_unexpect    msg
  87                                                  Parsec.Error.Expect      msg -> Write.I18N_expect      msg
  88                                                  Parsec.Error.Message     msg -> Write.I18N_message     msg
  89                                          )
  90                                  )
  91                                  -}
  92                          Lib.Parsec.Error_Custom pos err -> W.vsep $
  93                                 [ toDoc context pos
  94                                 , case err of
  95                                  Ledger.Read.Error_year_or_day_is_missing ->
  96                                         I18N.renderMessage Context.App langs $
  97                                          Write.I18N_year_or_day_is_missing
  98                                  Ledger.Read.Error_invalid_date (y, m, d) ->
  99                                         I18N.renderMessage Context.App langs $
 100                                          Write.I18N_invalid_date y m d
 101                                  Ledger.Read.Error_invalid_time_of_day (h, m, s) ->
 102                                         I18N.renderMessage Context.App langs $
 103                                          Write.I18N_invalid_time_of_day h m s
 104                                  Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
 105                                         i18n_transaction_not_equilibrated tr unit_sums
 106                                          Write.I18N_the_following_transaction_is_not_equilibrated_because
 107                                  Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
 108                                         i18n_transaction_not_equilibrated tr unit_sums
 109                                          Write.I18N_the_following_virtual_transaction_is_not_equilibrated_because
 110                                  Ledger.Read.Error_reading_file file_path exn -> W.vsep $
 111                                          [ I18N.renderMessage Context.App langs $
 112                                                 Write.I18N_failed_to_read_file file_path
 113                                          , W.text $ TL.pack $ show exn
 114                                          ]
 115                                  Ledger.Read.Error_including_file file_path errs -> W.vsep $
 116                                          [ I18N.renderMessage Context.App langs $
 117                                                 Write.I18N_failed_to_include_file file_path
 118                                          , toDoc context errs
 119                                          ]
 120                                 ]
 121                  )
 122                 where
 123                         langs = Context.langs context
 124                         i18n_transaction_not_equilibrated tr unit_sums msg =
 125                                 W.vsep $
 126                                  [ I18N.renderMessage Context.App langs msg
 127                                  , W.vsep $ Data.List.map
 128                                          (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} ->
 129                                                 let amt = Calc.Balance.amount_sum_balance unit_sum_amount Data.Map.! () in
 130                                                 I18N.renderMessage Context.App langs $
 131                                                 Write.I18N_unit_sums_up_to_the_non_null_amount
 132                                                  (Amount.unit amt) amt
 133                                          ) unit_sums
 134                                  , W.space
 135                                  , Ledger.Write.transaction tr
 136                                  ]
 137                         showErrorMessages :: [Parsec.Error.Message] -> W.Doc
 138                         showErrorMessages msgs
 139                                 | null msgs = i18n $ Write.I18N_unknown
 140                                 | otherwise = W.vsep $ -- clean $
 141                                         [showSysUnExpect, showUnExpect, showExpect, showMessages]
 142                                 where
 143                                         i18n = I18N.renderMessage Context.App langs
 144                                         (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
 145                                         (unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
 146                                         (expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
 147
 148                                         showExpect   = showMany (Just (i18n . Write.I18N_expect)) expect
 149                                         showUnExpect = showMany (Just (i18n . Write.I18N_unexpect)) unExpect
 150                                         showSysUnExpect
 151                                          | not (null unExpect) || null sysUnExpect = W.empty
 152                                          | null firstMsg = i18n $ Write.I18N_sysunexpect_end_of_input
 153                                          | otherwise     = i18n $ Write.I18N_sysunexpect firstMsg
 154                                                 where
 155                                                 firstMsg = Parsec.Error.messageString (head sysUnExpect)
 156
 157                                         showMessages = showMany Nothing messages
 158
 159                                         -- helpers
 160                                         showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
 161                                         showMany pre msgs_ =
 162                                                 case clean (map Parsec.Error.messageString msgs_) of
 163                                                  [] -> W.empty
 164                                                  ms ->
 165                                                         case pre of
 166                                                          Nothing -> commasOr ms
 167                                                          Just p -> p $ commasOr ms
 168
 169                                         commasOr :: [String] -> W.Doc
 170                                         commasOr []  = W.empty
 171                                         commasOr [m] = W.text $ TL.pack m
 172                                         commasOr ms  = commaSep (init ms)
 173                                                        <> (W.space <> i18n Write.I18N_or <> W.space)
 174                                                        <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
 175                                         commaSep = W.intercalate (W.comma <> W.space)
 176                                                    (W.bold . W.dullblack . W.text . TL.pack)
 177                                                    . clean
 178
 179                                         clean = Data.List.nub . filter (not . null)