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