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           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
  16 import qualified Hcompta.Lib.Leijen as W
  17 import           Hcompta.Lib.Leijen (ToDoc(..))
  18 import qualified Hcompta.Balance as Balance
  19 import qualified Hcompta.CLI.Context as Context
  20 import qualified Hcompta.CLI.Lang as Lang
  21 import           Hcompta.CLI.Lang (Lang)
  22 import qualified Hcompta.CLI.Write as Write
  23 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  24 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  25 import qualified Hcompta.Amount as Amount
  26
  27 -- | Return 'FilePath's containing 'Hcompta.Format.Ledger.Journal's:
  28 --
  29 -- * either those given if any,
  30 -- * or the one in LEDGER_FILE environment variable if any,
  31 -- * or the one in LEDGER environment variable if any.
  32 paths :: Context.Context -> [FilePath] -> IO [FilePath]
  33 paths context [] = do
  34         tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER_FILE"
  35         >>= \x -> case x of
  36          Right ok -> return [ok]
  37          Left  _ko -> do
  38                 tryJust (guard . isDoesNotExistError) $ Env.getEnv "LEDGER"
  39                 >>= \xx -> case xx of
  40                  Right ok -> return [ok]
  41                  Left  _ko -> do
  42                         let lang = Context.lang context
  43                         Write.fatal context $
  44                                 toDoc lang $ Lang.Message_no_ledger_file_given
  45 paths _context ps = return ps
  46
  47 instance ToDoc Lang Ledger.Read.Error where
  48         toDoc lang err =
  49                 case err of
  50                  Ledger.Read.Error_date date -> toDoc lang date
  51                  Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
  52                         i18n_transaction_not_equilibrated tr unit_sums
  53                          Lang.Message_the_following_transaction_is_not_equilibrated_because
  54                  Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
  55                         i18n_transaction_not_equilibrated tr unit_sums
  56                          Lang.Message_the_following_virtual_transaction_is_not_equilibrated_because
  57                  Ledger.Read.Error_reading_file file_path exn ->
  58                         W.vsep $
  59                          [ toDoc lang $ Lang.Message_failed_to_read_file file_path
  60                          , W.text $ TL.pack $ show exn
  61                          ]
  62                  Ledger.Read.Error_including_file file_path errs ->
  63                         W.vsep $
  64                          [ toDoc lang $ Lang.Message_failed_to_include_file file_path
  65                          , toDoc lang errs
  66                          ]
  67                 where
  68                         i18n_transaction_not_equilibrated tr unit_sums msg =
  69                                 W.vsep $
  70                                  [ toDoc lang msg
  71                                  , W.vsep $ Data.List.map
  72                                          (\Balance.Unit_Sum{Balance.unit_sum_amount} ->
  73                                                 let amt = Balance.amount_sum_balance unit_sum_amount in
  74                                                 toDoc lang $
  75                                                 Lang.Message_unit_sums_up_to_the_non_null_amount
  76                                                  (Amount.unit amt) amt
  77                                          ) unit_sums
  78                                  , W.space
  79                                  , Ledger.Write.transaction tr
  80                                  ]