]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Format/Ledger.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / CLI / Format / Ledger.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 module Hcompta.CLI.Format.Ledger where
10
11 import Data.Foldable (Foldable(..))
12 import Data.Function (($), (.))
13 import qualified Data.List as List
14 import qualified Data.Text as Text
15 import qualified Data.Text.Lazy as TL
16 import Text.Show (Show(..))
17 import Text.WalderLeijen.ANSI.Text (ToDoc(..))
18 import qualified Text.WalderLeijen.ANSI.Text as W
19
20 import qualified Hcompta as H
21 import qualified Hcompta.Ledger as Ledger
22
23 import qualified Hcompta.CLI.Lang as Lang
24 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
25
26 instance Lang.Translate Ledger.Error_Read W.Doc where
27 translate lang err =
28 case err of
29 Ledger.Error_Read_date date -> toDoc lang date
30 Ledger.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
31 i18n_transaction_not_equilibrated styles tr unit_sums
32 Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
33 Ledger.Error_Read_virtual_transaction_not_equilibrated styles tr unit_sums ->
34 i18n_transaction_not_equilibrated styles tr unit_sums
35 Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
36 Ledger.Error_Read_reading_file file_path exn ->
37 W.vsep $
38 [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
39 , W.text $ TL.pack $ show exn
40 ]
41 Ledger.Error_Read_including_file file_path errs ->
42 W.vsep $
43 [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
44 , Lang.translate lang errs
45 ]
46 where
47 i18n_transaction_not_equilibrated styles tr unit_sums msg =
48 W.vsep $
49 [ Lang.translate lang msg
50 , W.vsep $ List.map
51 (\(unit, H.Balance_by_Unit_Sum{..}) ->
52 Lang.translate lang $
53 Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
54 Ledger.amount_styled styles $
55 Ledger.Amount unit $
56 H.depolarize balance_by_unit_sum_quantity
57 ) unit_sums
58 , W.space
59 , Ledger.write_transaction styles tr
60 ]
61
62 instance Leijen.Table.Cell_of_forall_param Ledger.Journal H.Date where
63 cell_of_forall_param _ctx date =
64 Leijen.Table.cell
65 { Leijen.Table.cell_content = Ledger.write_date date
66 , Leijen.Table.cell_width = Ledger.write_date_length date
67 }
68 instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Account where
69 cell_of_forall_param _ctx account =
70 let posting_type = Ledger.Posting_Type_Regular in
71 Leijen.Table.cell
72 { Leijen.Table.cell_content = Ledger.write_account posting_type account
73 , Leijen.Table.cell_width = Ledger.write_account_length posting_type account
74 }
75 instance Leijen.Table.Cell_of_forall_param Ledger.Journal (Ledger.Unit, Ledger.Quantity) where
76 cell_of_forall_param j (unit, qty) =
77 let sty = Ledger.journal_amount_styles j in
78 let amt = Ledger.Amount unit qty in
79 let sa = Ledger.amount_styled sty amt in
80 Leijen.Table.cell
81 { Leijen.Table.cell_content = Ledger.write_amount sa
82 , Leijen.Table.cell_width = Ledger.write_amount_length sa
83 }
84 instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Wording where
85 cell_of_forall_param _j w =
86 Leijen.Table.cell
87 { Leijen.Table.cell_content = toDoc () w
88 , Leijen.Table.cell_width = Text.length w
89 }
90
91 instance Foldable f => W.ToDoc1 Ledger.Journal (f Ledger.Transaction) where
92 toDoc1 =
93 Ledger.write_transactions .
94 Ledger.journal_amount_styles