cli/Hcompta/CLI/Format/Ledger.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE DataKinds #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Hcompta.CLI.Format.Ledger where
  10
  11 -- import           Control.Monad.Trans.Except (ExceptT(..))
  12 import           Data.Foldable (Foldable(..))
  13 import           Data.Function ((.))
  14 import qualified Data.List as List
  15 import qualified Data.Text as Text
  16 import qualified Data.Text.Lazy as TL
  17 -- import           Control.DeepSeq (NFData)
  18 import           Prelude (($))
  19 -- import           System.IO (IO)
  20 import           Text.Show (Show(..))
  21
  22 import           Hcompta.Date (Date)
  23 import qualified Hcompta.Balance as Balance
  24 -- import qualified Hcompta.CLI.Format as CLI.Format
  25 -- import           Hcompta.CLI.Lang (Lang)
  26 import qualified Hcompta.CLI.Lang as Lang
  27 import qualified Hcompta.Format.Ledger       as Ledger
  28 import qualified Hcompta.Format.Ledger.Read  as Ledger
  29 import qualified Hcompta.Format.Ledger.Write as Ledger
  30 -- import           Hcompta.Lib.Consable (Consable)
  31 import           Hcompta.Lib.Leijen (ToDoc(..))
  32 import qualified Hcompta.Lib.Leijen as W
  33 -- import qualified Hcompta.Lib.Parsec as Parsec
  34 import qualified Hcompta.Polarize as Polarize
  35 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
  36
  37 instance Lang.Translate Ledger.Read_Error W.Doc where
  38         translate lang err =
  39                 case err of
  40                  Ledger.Read_Error_date date -> toDoc lang date
  41                  Ledger.Read_Error_transaction_not_equilibrated styles tr unit_sums ->
  42                         i18n_transaction_not_equilibrated styles tr unit_sums
  43                          Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
  44                  Ledger.Read_Error_virtual_transaction_not_equilibrated styles tr unit_sums ->
  45                         i18n_transaction_not_equilibrated styles tr unit_sums
  46                          Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
  47                  Ledger.Read_Error_reading_file file_path exn ->
  48                         W.vsep $
  49                          [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
  50                          , W.text $ TL.pack $ show exn
  51                          ]
  52                  Ledger.Read_Error_including_file file_path errs ->
  53                         W.vsep $
  54                          [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
  55                          , Lang.translate lang errs
  56                          ]
  57                 where
  58                         i18n_transaction_not_equilibrated styles tr unit_sums msg =
  59                                 W.vsep $
  60                                  [ Lang.translate lang msg
  61                                  , W.vsep $ List.map
  62                                          (\(unit, Balance.Unit_Sum{Balance.unit_sum_quantity}) ->
  63                                                 Lang.translate lang $
  64                                                 Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
  65                                                 Ledger.amount_styled styles $
  66                                                 Ledger.Amount unit $
  67                                                 Polarize.depolarize unit_sum_quantity
  68                                          ) unit_sums
  69                                  , W.space
  70                                  , Ledger.write_transaction styles tr
  71                                  ]
  72
  73 instance Leijen.Table.Cell_of_forall_param Ledger.Journal Date where
  74         cell_of_forall_param _ctx date =
  75                 Leijen.Table.cell
  76                  { Leijen.Table.cell_content = Ledger.write_date        date
  77                  , Leijen.Table.cell_width   = Ledger.write_date_length date
  78                  }
  79 instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Account where
  80         cell_of_forall_param _ctx account =
  81                 let posting_type = Ledger.Posting_Type_Regular in
  82                 Leijen.Table.cell
  83                  { Leijen.Table.cell_content = Ledger.write_account        posting_type account
  84                  , Leijen.Table.cell_width   = Ledger.write_account_length posting_type account
  85                  }
  86 instance Leijen.Table.Cell_of_forall_param Ledger.Journal (Ledger.Unit, Ledger.Quantity) where
  87         cell_of_forall_param j (unit, qty) =
  88                 let sty = Ledger.journal_amount_styles j in
  89                 let amt = Ledger.Amount unit qty in
  90                 let sa  = Ledger.amount_styled sty amt in
  91                 Leijen.Table.cell
  92                  { Leijen.Table.cell_content = Ledger.write_amount        sa
  93                  , Leijen.Table.cell_width   = Ledger.write_amount_length sa
  94                  }
  95 instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Wording where
  96         cell_of_forall_param _j w =
  97                 Leijen.Table.cell
  98                  { Leijen.Table.cell_content = toDoc ()    w
  99                  , Leijen.Table.cell_width   = Text.length w
 100                  }
 101
 102 instance Foldable f => W.Leijen_of_forall_param Ledger.Journal (f Ledger.Transaction) where
 103         leijen_of_forall_param =
 104                 Ledger.write_transactions .
 105                 Ledger.journal_amount_styles