]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Balance.hs
Correction : CLI.Command.Balance : détermine is_worth avant d’appliquer balance_filter.
[comptalang.git] / cli / Hcompta / CLI / Command / Balance.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TupleSections #-}
5 module Hcompta.CLI.Command.Balance where
6
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
18 ( ArgDescr(..)
19 , OptDescr(..)
20 , usageInfo
21 )
22 import System.Environment as Env (getProgName)
23 import System.Exit (exitWith, ExitCode(..))
24 import qualified System.IO as IO
25
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
47
48 data Ctx
49 = Ctx
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)
54 } deriving (Show)
55
56 nil :: Ctx
57 nil =
58 Ctx
59 { ctx_input = []
60 , ctx_redundant = False
61 , ctx_transaction_filter = Filter.Any
62 , ctx_posting_filter = Filter.Any
63 }
64
65 usage :: IO String
66 usage = do
67 bin <- Env.getProgName
68 return $ unlines $
69 [ "SYNTAX "
70 , " "++bin++" balance [-t TRANSACTION_FILTER] [-p POSTING_FILTER] BALANCE_FILTER"
71 , ""
72 , usageInfo "OPTIONS" options
73 ]
74
75 options :: Args.Options Ctx
76 options =
77 [ Option "h" ["help"]
78 (NoArg (\_context _ctx -> do
79 usage >>= IO.hPutStr IO.stderr
80 exitWith ExitSuccess))
81 "show this help"
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
88 ctx_posting_filter <-
89 fmap (Filter.And $ ctx_posting_filter ctx) $
90 liftIO $ Filter.Read.read Filter.Read.test_posting s
91 >>= \f -> case f of
92 Left ko -> Write.fatal context $ ko
93 Right ok -> return ok
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})
105 "[yes|no]")
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
112 >>= \f -> case f of
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"
117 ]
118
119 run :: Context.Context -> [String] -> IO ()
120 run context args = do
121 (ctx, text_filters) <- Args.parse context usage options (nil, args)
122 read_journals <- do
123 CLI.Ledger.paths context $ ctx_input ctx
124 >>= do
125 mapM $ \path -> do
126 liftIO $ runExceptT $ Ledger.Read.file path
127 >>= \x -> case x of
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
135 ([], journals) -> do
136 balance_filter <-
137 foldr Filter.And Filter.Any <$> do
138 (flip mapM) text_filters $ \s ->
139 liftIO $ Filter.Read.read Filter.Read.test_balance s
140 >>= \f -> case f of
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) =
147 ledger_balances ctx
148 (ctx_transaction_filter ctx)
149 (ctx_posting_filter ctx)
150 balance_filter
151 journals
152 style_color <- Write.with_color context IO.stdout
153 W.displayIO IO.stdout $
154 W.renderPretty style_color 1.0 maxBound $ do
155 toDoc () $
156 let title =
157 TL.toStrict . W.displayT .
158 W.renderCompact False .
159 toDoc (Context.lang context) in
160 zipWith id
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
165 ] $
166 write_by_accounts ctx balance_by_account $
167 zipWith (:)
168 [ Table.Cell_Line '=' 0
169 , Table.Cell_Line '=' 0
170 , Table.Cell_Line '=' 0
171 , Table.Cell_Line ' ' 0
172 ] $
173 flip write_by_amounts (repeat []) $
174 Data.Map.map
175 Balance.unit_sum_amount
176 balance_by_unit
177
178 ledger_balances
179 :: Ctx
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))
183 -> [Ledger.Journal]
184 -> ( Balance.Expanded (Amount.Sum Amount)
185 , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
186 ledger_balances
187 ctx
188 transaction_filter
189 posting_filter
190 balance_filter
191 journals =
192 let balance_by_account =
193 foldr
194 (Ledger.Journal.fold
195 (flip (foldr
196 (flip (foldr
197 (\tr ->
198 case Filter.test transaction_filter tr of
199 False -> id
200 True ->
201 let filter_postings =
202 Data.Foldable.concatMap $
203 Data.List.filter $
204 (Filter.test posting_filter) in
205 let balance =
206 flip (foldr Balance.by_account) .
207 map (\p ->
208 ( Ledger.posting_account p
209 , Data.Map.map Amount.sum (Ledger.posting_amounts p)
210 )
211 ) .
212 filter_postings in
213 balance (Ledger.transaction_postings tr) .
214 balance (Ledger.transaction_virtual_postings tr) .
215 balance (Ledger.transaction_balanced_virtual_postings tr)
216 ))))
217 . Ledger.journal_transactions))
218 (Balance.balance_by_account Balance.nil)
219 journals in
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
225 let is_worth =
226 ctx_redundant ctx
227 -- NOTE: worth if no descendant
228 -- but account inclusive
229 -- has at least a non-zero amount
230 || (Data.Map.null descendants && not
231 (Data.Map.null
232 (Data.Map.filter
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
238 (Data.Map.filter
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
244 || Data.Map.size
245 (Data.Map.filter
246 ( maybe False
247 ( not . Data.Foldable.all
248 ( Amount.is_zero
249 . Amount.sum_balance )
250 . Balance.inclusive )
251 . Lib.TreeMap.node_value )
252 descendants) > 1
253 in
254 if is_worth
255 then
256 Data.Foldable.any
257 (Filter.test balance_filter . (acct,)) $
258 Balance.inclusive balance
259 else False
260 ) $
261 Balance.expanded balance_by_account in
262 let balance_by_unit =
263 Balance.by_unit_of_expanded
264 balance_expanded
265 (Balance.balance_by_unit Balance.nil) in
266 ( balance_expanded
267 , balance_by_unit
268 )
269
270 write_by_accounts
271 :: Ctx
272 -> Balance.Expanded (Amount.Sum Amount)
273 -> [[Table.Cell]]
274 -> [[Table.Cell]]
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 ->
279 foldr
280 (\(amount_positive, amount_negative, amount) ->
281 zipWith (:)
282 [ Table.cell
283 { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive
284 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive
285 }
286 , Table.cell
287 { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative
288 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative
289 }
290 , Table.cell
291 { Table.cell_content = Amount.Write.amount $ amount
292 , Table.cell_width = Amount.Write.amount_length $ amount
293 }
294 , Table.cell
295 { Table.cell_content = Ledger.Write.account posting_type account
296 , Table.cell_width = Ledger.Write.account_length posting_type account
297 }
298 ]
299 )
300 rows $
301 let bal = Balance.inclusive balance in
302 Data.Map.foldrWithKey
303 (\unit amount acc ->
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
307 ) : acc
308 ) [] $ bal
309 )
310
311 write_by_amounts
312 :: Data.Map.Map Unit (Amount.Sum Amount)
313 -> [[Table.Cell]]
314 -> [[Table.Cell]]
315 write_by_amounts =
316 flip $ foldr
317 (\amount_sum ->
318 zipWith (:)
319 [ let amt = Amount.sum_positive amount_sum in
320 Table.cell
321 { Table.cell_content = maybe W.empty Amount.Write.amount amt
322 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
323 }
324 , let amt = Amount.sum_negative amount_sum in
325 Table.cell
326 { Table.cell_content = maybe W.empty Amount.Write.amount amt
327 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
328 }
329 , let amt = Amount.sum_balance amount_sum in
330 Table.cell
331 { Table.cell_content = Amount.Write.amount amt
332 , Table.cell_width = Amount.Write.amount_length amt
333 }
334 , Table.cell
335 { Table.cell_content = W.empty
336 , Table.cell_width = 0
337 }
338 ]
339 )