1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 module Hcompta.CLI.Command.Balance where
5 import Control.Monad.IO.Class (liftIO)
6 import Control.Monad.Trans.Except (runExceptT)
7 import qualified Data.Either
8 import qualified Data.Foldable
9 import qualified Data.List
10 import qualified Data.Map.Strict as Data.Map
11 import qualified Data.Text.Lazy as TL
12 import System.Console.GetOpt
17 import System.Environment as Env (getProgName)
18 import System.Exit (exitWith, ExitCode(..))
19 import qualified System.IO as IO
20 -- import Text.Show.Pretty (ppShow)
22 import qualified Hcompta.Calc.Balance as Balance
23 import qualified Hcompta.CLI.Args as Args
24 import qualified Hcompta.CLI.Context as Context
25 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
26 import qualified Hcompta.CLI.I18N as I18N
27 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
28 import qualified Hcompta.CLI.Write as Write
29 import qualified Hcompta.Format.Ledger as Ledger
30 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
31 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
32 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
33 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
34 import qualified Hcompta.Lib.Leijen as W
35 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
36 import qualified Hcompta.Model.Amount as Amount
37 import Hcompta.Model.Amount (Amount, Unit)
41 { ctx_input :: [FilePath]
42 , ctx_redundant :: Bool
49 , ctx_redundant = False
54 bin <- Env.getProgName
57 , " "++bin++" balance [option..]"
59 , usageInfo "OPTIONS" options
62 options :: Args.Options Ctx
65 (NoArg (\_context _ctx -> do
66 usage >>= IO.hPutStr IO.stderr
67 exitWith ExitSuccess))
69 , Option "i" ["input"]
70 (ReqArg (\s _context ctx -> do
71 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
72 "read data from given file, can be use multiple times"
73 , Option "" ["redundant"]
74 (OptArg (\arg context ctx -> do
75 redundant <- case arg of
76 Nothing -> return $ True
77 Just "yes" -> return $ True
78 Just "no" -> return $ False
79 Just _ -> Write.fatal context $
80 W.text "--redundant option expects \"yes\", or \"no\" as value"
81 return $ ctx{ctx_redundant=redundant})
83 "also print accounts with zero amount or the same amounts than its ascending account"
86 run :: Context.Context -> [String] -> IO ()
88 (ctx, _) <- Args.parse context usage options (nil, args)
90 CLI.Ledger.paths context $ ctx_input ctx
91 >>= do mapM $ \path -> do
95 Left ko -> return $ Left (path, ko)
96 Right ok -> return $ Right ok
97 >>= return . Data.Either.partitionEithers
100 (flip mapM_) kos $ \(_path, ko) -> do
101 Write.debug context $ show $ ko
102 Write.fatal context $ toDoc context ko
107 (flip (Data.Foldable.foldr
108 (flip (Data.Foldable.foldr
111 (Data.Foldable.foldr Balance.postings
112 (Ledger.transaction_balanced_virtual_postings_balance tr)
113 (Ledger.transaction_virtual_postings tr)) .
114 Balance.union (Ledger.transaction_postings_balance tr)
116 . Ledger.journal_transactions))
119 let expanded = Balance.expanded $ Balance.balance_by_account balance
120 style_color <- Write.with_color context IO.stdout
121 Ledger.Write.put Ledger.Write.Style
122 { Ledger.Write.style_align = True
123 , Ledger.Write.style_color
126 let title = TL.toStrict . W.displayT . W.renderCompact False .
127 I18N.render (Context.langs context) in
129 [ Table.column (title I18N.Message_Balance_debit) Table.Align_Right
130 , Table.column (title I18N.Message_Balance_credit) Table.Align_Right
131 , Table.column (title I18N.Message_Balance_total) Table.Align_Right
132 , Table.column (title I18N.Message_Account) Table.Align_Left
134 flip (write_by_accounts ctx) expanded $
136 [ Table.Cell_Line '=' 0
137 , Table.Cell_Line '=' 0
138 , Table.Cell_Line '=' 0
139 , Table.Cell_Line ' ' 0
141 write_by_amounts (repeat []) $
143 Balance.unit_sum_amount
144 (Balance.balance_by_unit balance)
148 -> Balance.Expanded Amount Unit
150 write_by_accounts ctx =
151 let posting_type = Ledger.Posting_Type_Regular in
152 Lib.TreeMap.foldr_with_Path_and_Node
153 (\account node balance rows -> do
154 let descendants = Lib.TreeMap.nodes
155 (Lib.TreeMap.node_descendants node)
160 (not . Amount.is_zero)
161 (Balance.exclusive balance)) > 0
164 ( maybe False (not . Amount.are_zero . Balance.amount_sum_balance . Balance.inclusive)
165 . Lib.TreeMap.node_value )
171 (\(amount_positive, amount_negative, amount) ->
174 { Table.cell_content = maybe W.empty Ledger.Write.amount amount_positive
175 , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_positive
178 { Table.cell_content = maybe W.empty Ledger.Write.amount amount_negative
179 , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_negative
182 { Table.cell_content = Ledger.Write.amount $ amount
183 , Table.cell_width = Ledger.Write.amount_length $ amount
186 { Table.cell_content = Ledger.Write.account posting_type account
187 , Table.cell_width = Ledger.Write.account_length posting_type account
192 let bal = Balance.inclusive balance in
193 Data.Map.foldrWithKey
195 ( Data.Map.lookup unit $ Balance.amount_sum_positive bal
196 , Data.Map.lookup unit $ Balance.amount_sum_negative bal
199 ) [] $ Balance.amount_sum_balance bal
204 -> Data.Map.Map Unit (Balance.Amount_Sum Amount ())
210 [ let amt = Data.Map.lookup () $ Balance.amount_sum_positive amount_sum in
212 { Table.cell_content = maybe W.empty Ledger.Write.amount amt
213 , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
215 , let amt = Data.Map.lookup () $ Balance.amount_sum_negative amount_sum in
217 { Table.cell_content = maybe W.empty Ledger.Write.amount amt
218 , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
220 , let amt = Data.Map.lookup () $ Balance.amount_sum_balance amount_sum in
222 { Table.cell_content = maybe W.empty Ledger.Write.amount amt
223 , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
226 { Table.cell_content = W.empty
227 , Table.cell_width = 0