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.Applicative ((<$>))
10 import Control.Monad.IO.Class (liftIO)
11 import Control.Monad.Trans.Except (runExceptT)
12 import qualified Data.Either
13 import qualified Data.Foldable
14 import Data.Foldable (foldr)
15 import qualified Data.List
16 import qualified Data.Map.Strict as Data.Map
17 import qualified Data.Text.Lazy as TL
18 import System.Console.GetOpt
23 import System.Environment as Env (getProgName)
24 import System.Exit (exitWith, ExitCode(..))
25 import qualified System.IO as IO
27 import Hcompta.Account (Account)
28 import Hcompta.Amount (Amount)
29 import qualified Hcompta.Amount as Amount
30 import qualified Hcompta.Amount.Write as Amount.Write
31 import Hcompta.Amount.Unit (Unit)
32 import qualified Hcompta.Balance as Balance
33 import qualified Hcompta.CLI.Args as Args
34 import qualified Hcompta.CLI.Context as Context
35 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
36 import qualified Hcompta.CLI.Lang as Lang
37 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
38 import qualified Hcompta.CLI.Write as Write
39 import qualified Hcompta.Filter as Filter
40 import qualified Hcompta.Filter.Read as Filter.Read
41 import qualified Hcompta.Format.Ledger as Ledger
42 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
43 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
44 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
45 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
46 import qualified Hcompta.Lib.Leijen as W
47 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
51 { ctx_input :: [FilePath]
52 , ctx_redundant :: Bool
53 , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
54 , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
61 , ctx_redundant = False
62 , ctx_transaction_filter = Filter.Any
63 , ctx_posting_filter = Filter.Any
68 bin <- Env.getProgName
71 , " "++bin++" balance [-t TRANSACTION_FILTER] [-p POSTING_FILTER] BALANCE_FILTER"
73 , usageInfo "OPTIONS" options
76 options :: Args.Options Ctx
79 (NoArg (\_context _ctx -> do
80 usage >>= IO.hPutStr IO.stderr
81 exitWith ExitSuccess))
83 , Option "i" ["input"]
84 (ReqArg (\s _context ctx -> do
85 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
86 "read data from given file, multiple uses merge the data as would a concatenation do"
87 , Option "p" ["posting-filter"]
88 (ReqArg (\s context ctx -> do
90 fmap (Filter.And $ ctx_posting_filter ctx) $
91 liftIO $ Filter.Read.read Filter.Read.test_posting s
93 Left ko -> Write.fatal context $ ko
95 return $ ctx{ctx_posting_filter}) "FILTER")
96 "filter at posting level, multiple uses are merged with a logical and"
97 , Option "" ["redundant"]
98 (OptArg (\arg context ctx -> do
99 ctx_redundant <- case arg of
100 Nothing -> return $ True
101 Just "yes" -> return $ True
102 Just "no" -> return $ False
103 Just _ -> Write.fatal context $
104 W.text "--redundant option expects \"yes\", or \"no\" as value"
105 return $ ctx{ctx_redundant})
107 "also print accounts with zero amount or the same amounts than its ascending account"
108 , Option "t" ["transaction-filter"]
109 (ReqArg (\s context ctx -> do
110 ctx_transaction_filter <-
111 fmap (Filter.And $ ctx_transaction_filter ctx) $
112 liftIO $ Filter.Read.read Filter.Read.test_transaction s
114 Left ko -> Write.fatal context $ ko
115 Right ok -> return ok
116 return $ ctx{ctx_transaction_filter}) "FILTER")
117 "filter at transaction level, multiple uses are merged with a logical and"
120 run :: Context.Context -> [String] -> IO ()
121 run context args = do
122 (ctx, text_filters) <- Args.parse context usage options (nil, args)
124 CLI.Ledger.paths context $ ctx_input ctx
127 liftIO $ runExceptT $ Ledger.Read.file path
129 Left ko -> return $ Left (path, ko)
130 Right ok -> return $ Right ok
131 >>= return . Data.Either.partitionEithers
132 case read_journals of
133 (errs@(_:_), _journals) ->
134 (flip mapM_) errs $ \(_path, err) -> do
135 Write.fatal context $ err
138 foldr Filter.And Filter.Any <$> do
139 (flip mapM) text_filters $ \s ->
140 liftIO $ Filter.Read.read Filter.Read.test_balance s
142 Left ko -> Write.fatal context $ ko
143 Right ok -> return ok
144 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
145 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
146 Write.debug context $ "balance_filter: " ++ show balance_filter
147 let (balance_by_account, balance_by_unit) =
149 (ctx_transaction_filter ctx)
150 (ctx_posting_filter ctx)
153 style_color <- Write.with_color context IO.stdout
154 W.displayIO IO.stdout $
155 W.renderPretty style_color 1.0 maxBound $ do
158 TL.toStrict . W.displayT .
159 W.renderCompact False .
160 toDoc (Context.lang context) in
162 [ Table.column (title Lang.Message_Debit) Table.Align_Right
163 , Table.column (title Lang.Message_Credit) Table.Align_Right
164 , Table.column (title Lang.Message_Balance) Table.Align_Right
165 , Table.column (title Lang.Message_Account) Table.Align_Left
167 write_by_accounts ctx balance_by_account $
169 [ Table.Cell_Line '=' 0
170 , Table.Cell_Line '=' 0
171 , Table.Cell_Line '=' 0
172 , Table.Cell_Line ' ' 0
174 flip write_by_amounts (repeat []) $
176 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 )
191 let balance_by_account =
197 case Filter.test transaction_filter tr of
200 let filter_postings =
201 Data.Foldable.concatMap $
203 (Filter.test posting_filter) in
205 flip (foldr Balance.by_account) .
207 ( Ledger.posting_account p
208 , Data.Map.map Amount.sum (Ledger.posting_amounts p)
212 balance (Ledger.transaction_postings tr) .
213 balance (Ledger.transaction_virtual_postings tr) .
214 balance (Ledger.transaction_balanced_virtual_postings tr)
216 . Ledger.journal_transactions))
217 (Balance.balance_by_account Balance.nil)
219 let balance_expanded =
220 Lib.TreeMap.filter_with_Path (\acct ->
222 (Filter.test balance_filter . (acct,)) .
224 Balance.expanded balance_by_account in
225 let balance_by_unit =
226 Balance.by_unit_of_expanded
228 (Balance.balance_by_unit Balance.nil) in
235 -> Balance.Expanded (Amount.Sum Amount)
238 write_by_accounts ctx =
239 let posting_type = Ledger.Posting_Type_Regular in
240 flip $ Lib.TreeMap.foldr_with_Path_and_Node
241 (\account node balance rows -> do
242 let descendants = Lib.TreeMap.nodes
243 (Lib.TreeMap.node_descendants node)
246 -- NOTE: worth if no descendant
247 -- but account inclusive
248 -- has at least a non-zero amount
249 || (Data.Map.null descendants && not
252 (not . Amount.is_zero . Amount.sum_balance)
253 (Balance.inclusive balance))))
254 -- NOTE: worth if account exclusive
255 -- has at least a non-zero amount
256 || not (Data.Map.null
258 (not . Amount.is_zero . Amount.sum_balance)
259 (Balance.exclusive balance)))
260 -- NOTE: worth if account has at least more than
261 -- one descendant account whose inclusive
262 -- has at least a non-zero amount
266 ( not . Data.Foldable.all
268 . Amount.sum_balance )
269 . Balance.inclusive )
270 . Lib.TreeMap.node_value )
276 (\(amount_positive, amount_negative, amount) ->
279 { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive
280 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive
283 { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative
284 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative
287 { Table.cell_content = Amount.Write.amount $ amount
288 , Table.cell_width = Amount.Write.amount_length $ amount
291 { Table.cell_content = Ledger.Write.account posting_type account
292 , Table.cell_width = Ledger.Write.account_length posting_type account
297 let bal = Balance.inclusive balance in
298 Data.Map.foldrWithKey
300 ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
301 , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
302 , Amount.sum_balance amount
308 :: Data.Map.Map Unit (Amount.Sum Amount)
315 [ let amt = Amount.sum_positive amount_sum in
317 { Table.cell_content = maybe W.empty Amount.Write.amount amt
318 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
320 , let amt = Amount.sum_negative amount_sum in
322 { Table.cell_content = maybe W.empty Amount.Write.amount amt
323 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
325 , let amt = Amount.sum_balance amount_sum in
327 { Table.cell_content = Amount.Write.amount amt
328 , Table.cell_width = Amount.Write.amount_length amt
331 { Table.cell_content = W.empty
332 , Table.cell_width = 0