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 Context
  22 import           Hcompta.CLI.Lang (Lang)
  23 import qualified Hcompta.CLI.Lang as Lang
  24 import qualified Hcompta.CLI.Write as Write
  25 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  26 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  27 import           Hcompta.Lib.Leijen (ToDoc(..))
  28 import qualified Hcompta.Lib.Leijen as W
  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 lang = Context.lang context
  46                         Write.fatal context $
  47                                 toDoc lang $ Lang.Message_no_ledger_file_given
  48 paths _context ps = return ps
  49
  50 instance ToDoc Lang Ledger.Read.Error where
  51         toDoc lang err =
  52                 case err of
  53                  Ledger.Read.Error_date date -> toDoc lang date
  54                  Ledger.Read.Error_transaction_not_equilibrated tr unit_sums ->
  55                         i18n_transaction_not_equilibrated tr unit_sums
  56                          Lang.Message_the_following_transaction_is_not_equilibrated_because
  57                  Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums ->
  58                         i18n_transaction_not_equilibrated tr unit_sums
  59                          Lang.Message_the_following_virtual_transaction_is_not_equilibrated_because
  60                  Ledger.Read.Error_reading_file file_path exn ->
  61                         W.vsep $
  62                          [ toDoc lang $ Lang.Message_failed_to_read_file file_path
  63                          , W.text $ TL.pack $ show exn
  64                          ]
  65                  Ledger.Read.Error_including_file file_path errs ->
  66                         W.vsep $
  67                          [ toDoc lang $ Lang.Message_failed_to_include_file file_path
  68                          , toDoc lang errs
  69                          ]
  70                 where
  71                         i18n_transaction_not_equilibrated tr unit_sums msg =
  72                                 W.vsep $
  73                                  [ toDoc lang msg
  74                                  , W.vsep $ Data.List.map
  75                                          (\Balance.Unit_Sum{Balance.unit_sum_amount} ->
  76                                                 let amt = Amount.sum_balance unit_sum_amount in
  77                                                 toDoc lang $
  78                                                 Lang.Message_unit_sums_up_to_the_non_null_amount
  79                                                  (Amount.unit amt) amt
  80                                          ) unit_sums
  81                                  , W.space
  82                                  , Ledger.Write.transaction tr
  83                                  ]