1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Balance where
7 import Prelude hiding (foldr)
8 -- import Control.Monad ((>=>))
9 import Control.Monad.IO.Class (liftIO)
10 import Control.Monad.Trans.Except (runExceptT)
11 import qualified Data.Either
12 import qualified Data.Foldable
13 import Data.Foldable (foldr)
14 import qualified Data.List
15 import qualified Data.Map.Strict as Data.Map
16 import qualified Data.Text.Lazy as TL
17 import System.Console.GetOpt
22 import System.Environment as Env (getProgName)
23 import System.Exit (exitWith, ExitCode(..))
24 import qualified System.IO as IO
26 import Hcompta.Account (Account)
27 import Hcompta.Amount (Amount)
28 import qualified Hcompta.Amount as Amount
29 import qualified Hcompta.Amount.Write as Amount.Write
30 import Hcompta.Amount.Unit (Unit)
31 import qualified Hcompta.Balance as Balance
32 import qualified Hcompta.CLI.Args as Args
33 import qualified Hcompta.CLI.Context as Context
34 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
35 import qualified Hcompta.CLI.Lang as Lang
36 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
37 import qualified Hcompta.CLI.Write as Write
38 import qualified Hcompta.Filter as Filter
39 import qualified Hcompta.Filter.Read as Filter.Read
40 import qualified Hcompta.Format.Ledger as Ledger
41 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
42 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
43 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
44 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
45 import qualified Hcompta.Lib.Leijen as W
46 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
50 { ctx_input :: [FilePath]
51 , ctx_redundant :: Bool
52 , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
53 , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
60 , ctx_redundant = False
61 , ctx_transaction_filter = Filter.Any
62 , ctx_posting_filter = Filter.Any
67 bin <- Env.getProgName
70 , " "++bin++" balance [-t TRANSACTION_FILTER] [-p POSTING_FILTER] BALANCE_FILTER"
72 , usageInfo "OPTIONS" options
75 options :: Args.Options Ctx
78 (NoArg (\_context _ctx -> do
79 usage >>= IO.hPutStr IO.stderr
80 exitWith ExitSuccess))
82 , Option "i" ["input"]
83 (ReqArg (\s _context ctx -> do
84 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
85 "read data from given file, multiple uses merge the data as would a concatenation do"
86 , Option "p" ["posting-filter"]
87 (ReqArg (\s context ctx -> do
89 fmap (Filter.And $ ctx_posting_filter ctx) $
90 liftIO $ Filter.Read.read Filter.Read.test_posting s
92 Left ko -> Write.fatal context $ ko
94 return $ ctx{ctx_posting_filter}) "FILTER")
95 "filter at posting level, multiple uses are merged with a logical and"
96 , Option "" ["redundant"]
97 (OptArg (\arg context ctx -> do
98 ctx_redundant <- case arg of
99 Nothing -> return $ True
100 Just "yes" -> return $ True
101 Just "no" -> return $ False
102 Just _ -> Write.fatal context $
103 W.text "--redundant option expects \"yes\", or \"no\" as value"
104 return $ ctx{ctx_redundant})
106 "also print accounts with zero amount or the same amounts than its ascending account"
107 , Option "t" ["transaction-filter"]
108 (ReqArg (\s context ctx -> do
109 ctx_transaction_filter <-
110 fmap (Filter.And $ ctx_transaction_filter ctx) $
111 liftIO $ Filter.Read.read Filter.Read.test_transaction s
113 Left ko -> Write.fatal context $ ko
114 Right ok -> return ok
115 return $ ctx{ctx_transaction_filter}) "FILTER")
116 "filter at transaction level, multiple uses are merged with a logical and"
119 run :: Context.Context -> [String] -> IO ()
120 run context args = do
121 (ctx, text_filters) <- Args.parse context usage options (nil, args)
123 CLI.Ledger.paths context $ ctx_input ctx
126 liftIO $ runExceptT $ Ledger.Read.file path
128 Left ko -> return $ Left (path, ko)
129 Right ok -> return $ Right ok
130 >>= return . Data.Either.partitionEithers
131 case read_journals of
132 (errs@(_:_), _journals) ->
133 (flip mapM_) errs $ \(_path, err) -> do
134 Write.fatal context $ err
137 foldr Filter.And Filter.Any <$> do
138 (flip mapM) text_filters $ \s ->
139 liftIO $ Filter.Read.read Filter.Read.test_balance s
141 Left ko -> Write.fatal context $ ko
142 Right ok -> return ok
143 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
144 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
145 Write.debug context $ "balance_filter: " ++ show balance_filter
146 let (balance_by_account, balance_by_unit) =
148 (ctx_transaction_filter ctx)
149 (ctx_posting_filter ctx)
152 style_color <- Write.with_color context IO.stdout
153 W.displayIO IO.stdout $
154 W.renderPretty style_color 1.0 maxBound $ do
157 TL.toStrict . W.displayT .
158 W.renderCompact False .
159 toDoc (Context.lang context) in
161 [ Table.column (title Lang.Message_Debit) Table.Align_Right
162 , Table.column (title Lang.Message_Credit) Table.Align_Right
163 , Table.column (title Lang.Message_Balance) Table.Align_Right
164 , Table.column (title Lang.Message_Account) Table.Align_Left
166 write_by_accounts ctx balance_by_account $
168 [ Table.Cell_Line '=' 0
169 , Table.Cell_Line '=' 0
170 , Table.Cell_Line '=' 0
171 , Table.Cell_Line ' ' 0
173 flip write_by_amounts (repeat []) $
175 Balance.unit_sum_amount
180 -> Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
181 -> Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
182 -> Filter.Test_Bool (Filter.Test_Balance (Account, Amount.Sum Amount))
184 -> ( Balance.Expanded (Amount.Sum Amount)
185 , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
192 let balance_by_account =
198 case Filter.test transaction_filter tr of
201 let filter_postings =
202 Data.Foldable.concatMap $
204 (Filter.test posting_filter) in
206 flip (foldr Balance.by_account) .
208 ( Ledger.posting_account p
209 , Data.Map.map Amount.sum (Ledger.posting_amounts p)
213 balance (Ledger.transaction_postings tr) .
214 balance (Ledger.transaction_virtual_postings tr) .
215 balance (Ledger.transaction_balanced_virtual_postings tr)
217 . Ledger.journal_transactions))
218 (Balance.balance_by_account Balance.nil)
220 let balance_expanded =
221 Lib.TreeMap.filter_with_Path_and_Node
222 (\node acct balance ->
223 let descendants = Lib.TreeMap.nodes
224 (Lib.TreeMap.node_descendants node) in
227 -- NOTE: worth if no descendant
228 -- but account inclusive
229 -- has at least a non-zero amount
230 || (Data.Map.null descendants && not
233 (not . Amount.is_zero . Amount.sum_balance)
234 (Balance.inclusive balance))))
235 -- NOTE: worth if account exclusive
236 -- has at least a non-zero amount
237 || not (Data.Map.null
239 (not . Amount.is_zero . Amount.sum_balance)
240 (Balance.exclusive balance)))
241 -- NOTE: worth if account has at least more than
242 -- one descendant account whose inclusive
243 -- has at least a non-zero amount
247 ( not . Data.Foldable.all
249 . Amount.sum_balance )
250 . Balance.inclusive )
251 . Lib.TreeMap.node_value )
257 (Filter.test balance_filter . (acct,)) $
258 Balance.inclusive balance
261 Balance.expanded balance_by_account in
262 let balance_by_unit =
263 Balance.by_unit_of_expanded
265 (Balance.balance_by_unit Balance.nil) in
272 -> Balance.Expanded (Amount.Sum Amount)
275 write_by_accounts _ctx =
276 let posting_type = Ledger.Posting_Type_Regular in
277 flip $ Lib.TreeMap.foldr_with_Path
278 (\account balance rows ->
280 (\(amount_positive, amount_negative, amount) ->
283 { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive
284 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive
287 { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative
288 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative
291 { Table.cell_content = Amount.Write.amount $ amount
292 , Table.cell_width = Amount.Write.amount_length $ amount
295 { Table.cell_content = Ledger.Write.account posting_type account
296 , Table.cell_width = Ledger.Write.account_length posting_type account
301 let bal = Balance.inclusive balance in
302 Data.Map.foldrWithKey
304 ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
305 , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
306 , Amount.sum_balance amount
312 :: Data.Map.Map Unit (Amount.Sum Amount)
319 [ let amt = Amount.sum_positive amount_sum in
321 { Table.cell_content = maybe W.empty Amount.Write.amount amt
322 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
324 , let amt = Amount.sum_negative amount_sum in
326 { Table.cell_content = maybe W.empty Amount.Write.amount amt
327 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
329 , let amt = Amount.sum_balance amount_sum in
331 { Table.cell_content = Amount.Write.amount amt
332 , Table.cell_width = Amount.Write.amount_length amt
335 { Table.cell_content = W.empty
336 , Table.cell_width = 0