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