]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Balance.hs
Ajout : Filter : simplify et context.
[comptalang.git] / cli / Hcompta / CLI / Command / Balance.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 module Hcompta.CLI.Command.Balance where
8
9 import Control.Applicative (Const(..))
10 import Prelude hiding (foldr)
11 import Control.Monad (liftM)
12 import Control.Monad.IO.Class (liftIO)
13 import Control.Monad.Trans.Except (runExceptT)
14 import qualified Data.Either
15 import qualified Data.Foldable
16 import Data.Foldable (foldr)
17 import qualified Data.Map.Strict as Data.Map
18 import Data.Monoid ((<>))
19 import qualified Data.Strict.Maybe as Strict
20 import qualified Data.Text.Lazy as TL
21 import System.Console.GetOpt
22 ( ArgDescr(..)
23 , OptDescr(..)
24 , usageInfo
25 )
26 import System.Environment as Env (getProgName)
27 import System.Exit (exitWith, ExitCode(..))
28 import qualified System.IO as IO
29
30 import Hcompta.Account (Account)
31 import Hcompta.Amount (Amount)
32 import qualified Hcompta.Amount as Amount
33 import qualified Hcompta.Amount.Write as Amount.Write
34 import Hcompta.Amount.Unit (Unit)
35 import qualified Hcompta.Balance as Balance
36 import qualified Hcompta.CLI.Args as Args
37 import qualified Hcompta.CLI.Context as Context
38 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
39 import qualified Hcompta.CLI.Lang as Lang
40 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
41 import qualified Hcompta.CLI.Write as Write
42 import qualified Hcompta.Filter as Filter
43 import qualified Hcompta.Filter.Read as Filter.Read
44 import qualified Hcompta.Format.Ledger as Ledger
45 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
46 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
47 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
48 import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
49 import qualified Hcompta.Lib.Leijen as W
50 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
51
52 data Ctx
53 = Ctx
54 { ctx_filter_balance :: Filter.Simplified
55 (Filter.Filter_Bool
56 (Filter.Filter_Balance
57 (Account, Amount.Sum Amount)))
58 , ctx_filter_posting :: Filter.Simplified
59 (Filter.Filter_Bool
60 (Filter.Filter_Posting
61 Ledger.Posting))
62 , ctx_filter_transaction :: Filter.Simplified
63 (Filter.Filter_Bool
64 (Filter.Filter_Transaction
65 Ledger.Transaction))
66 , ctx_input :: [FilePath]
67 , ctx_reduce_date :: Bool
68 , ctx_redundant :: Bool
69 } deriving (Show)
70
71 nil :: Ctx
72 nil =
73 Ctx
74 { ctx_filter_balance = mempty
75 , ctx_filter_posting = mempty
76 , ctx_filter_transaction = mempty
77 , ctx_input = []
78 , ctx_reduce_date = True
79 , ctx_redundant = False
80 }
81
82 usage :: IO String
83 usage = do
84 bin <- Env.getProgName
85 return $ unlines $
86 [ "SYNTAX "
87 , " "++bin++" balance"
88 , " [-i JOURNAL_FILE]"
89 , " [-b BALANCE_FILTER]"
90 , " [-p POSTING_FILTER]"
91 , " [-t TRANSACTION_FILTER]"
92 , " [JOURNAL_FILE] [...]"
93 , ""
94 , usageInfo "OPTIONS" options
95 ]
96
97 options :: Args.Options Ctx
98 options =
99 [ Option "b" ["filter-balance"]
100 (ReqArg (\s context ctx -> do
101 ctx_filter_balance <-
102 liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
103 liftIO $ Filter.Read.read Filter.Read.filter_balance s
104 >>= \f -> case f of
105 Left ko -> Write.fatal context $ ko
106 Right ok -> return ok
107 return $ ctx{ctx_filter_balance}) "FILTER")
108 "filter at balance level, multiple uses are merged with a logical AND"
109 , Option "p" ["filter-posting"]
110 (ReqArg (\s context ctx -> do
111 ctx_filter_posting <-
112 liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
113 liftIO $ Filter.Read.read Filter.Read.filter_posting s
114 >>= \f -> case f of
115 Left ko -> Write.fatal context $ ko
116 Right ok -> return ok
117 return $ ctx{ctx_filter_posting}) "FILTER")
118 "filter at posting level, multiple uses are merged with a logical AND"
119 , Option "t" ["filter-transaction"]
120 (ReqArg (\s context ctx -> do
121 ctx_filter_transaction <-
122 liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
123 liftIO $ Filter.Read.read Filter.Read.filter_transaction s
124 >>= \f -> case f of
125 Left ko -> Write.fatal context $ ko
126 Right ok -> return ok
127 return $ ctx{ctx_filter_transaction}) "FILTER")
128 "filter at transaction level, multiple uses are merged with a logical AND"
129 , Option "h" ["help"]
130 (NoArg (\_context _ctx -> do
131 usage >>= IO.hPutStr IO.stderr
132 exitWith ExitSuccess))
133 "show this help"
134 , Option "i" ["input"]
135 (ReqArg (\s _context ctx -> do
136 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
137 "read data from given file, multiple uses merge the data as would a concatenation do"
138 {- NOTE: not used so far.
139 , Option "" ["reduce-date"]
140 (OptArg (\arg context ctx -> do
141 ctx_reduce_date <- case arg of
142 Nothing -> return $ True
143 Just "yes" -> return $ True
144 Just "no" -> return $ False
145 Just _ -> Write.fatal context $
146 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
147 return $ ctx{ctx_reduce_date})
148 "[yes|no]")
149 "use advanced date reducer to speed up filtering"
150 -}
151 , Option "" ["redundant"]
152 (OptArg (\arg context ctx -> do
153 ctx_redundant <- case arg of
154 Nothing -> return $ True
155 Just "yes" -> return $ True
156 Just "no" -> return $ False
157 Just _ -> Write.fatal context $
158 W.text "--redundant option expects \"yes\", or \"no\" as value"
159 return $ ctx{ctx_redundant})
160 "[yes|no]")
161 "also print accounts with zero amount or the same amounts than its ascending account"
162 ]
163
164 run :: Context.Context -> [String] -> IO ()
165 run context args = do
166 (ctx, inputs) <- Args.parse context usage options (nil, args)
167 read_journals <- do
168 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
169 >>= do
170 mapM $ \path -> do
171 liftIO $ runExceptT $ Ledger.Read.file
172 (Ledger.Read.context ( ctx_filter_transaction ctx
173 , ctx_filter_posting ctx )
174 Ledger.journal)
175 path
176 >>= \x -> case x of
177 Left ko -> return $ Left (path, ko)
178 Right ok -> return $ Right ok
179 >>= return . Data.Either.partitionEithers
180 case read_journals of
181 (errs@(_:_), _journals) ->
182 (flip mapM_) errs $ \(_path, err) -> do
183 Write.fatal context $ err
184 ([], journals) -> do
185 Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
186 Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
187 Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
188 let (balance_by_account, Balance.Balance_by_Unit balance_by_unit) =
189 ledger_balances ctx journals
190 style_color <- Write.with_color context IO.stdout
191 W.displayIO IO.stdout $
192 W.renderPretty style_color 1.0 maxBound $ do
193 toDoc () $
194 let title =
195 TL.toStrict . W.displayT .
196 W.renderCompact False .
197 toDoc (Context.lang context) in
198 zipWith id
199 [ Table.column (title Lang.Message_Debit) Table.Align_Right
200 , Table.column (title Lang.Message_Credit) Table.Align_Right
201 , Table.column (title Lang.Message_Balance) Table.Align_Right
202 , Table.column (title Lang.Message_Account) Table.Align_Left
203 ] $
204 write_by_accounts ctx balance_by_account $
205 zipWith (:)
206 [ Table.Cell_Line '=' 0
207 , Table.Cell_Line '=' 0
208 , Table.Cell_Line '=' 0
209 , Table.Cell_Line ' ' 0
210 ] $
211 flip write_by_amounts (repeat []) $
212 Data.Map.map
213 Balance.unit_sum_amount
214 balance_by_unit
215
216 ledger_balances
217 :: Ctx
218 -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) Ledger.Transaction) ]
219 -> ( Balance.Expanded (Amount.Sum Amount)
220 , Balance.Balance_by_Unit (Amount.Sum Amount) )
221 ledger_balances ctx journals =
222 let balance_by_account =
223 Data.Foldable.foldl'
224 (flip $ Ledger.Journal.fold
225 (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
226 mappend b))
227 mempty journals in
228 let balance_expanded =
229 Lib.TreeMap.filter_with_Path_and_Node
230 (\node acct balance ->
231 let descendants = Lib.TreeMap.nodes
232 (Lib.TreeMap.node_descendants node) in
233 let is_worth =
234 ctx_redundant ctx
235 -- NOTE: worth if no descendant
236 -- but account inclusive
237 -- has at least a non-zero amount
238 || (Data.Map.null descendants && not
239 (Data.Map.null
240 (Data.Map.filter
241 (not . Amount.is_zero . Amount.sum_balance)
242 (Balance.get_Account_Sum $ Balance.inclusive balance))))
243 -- NOTE: worth if account exclusive
244 -- has at least a non-zero amount
245 || not (Data.Map.null
246 (Data.Map.filter
247 (not . Amount.is_zero . Amount.sum_balance)
248 (Balance.get_Account_Sum $ Balance.exclusive balance)))
249 -- NOTE: worth if account has at least more than
250 -- one descendant account whose inclusive
251 -- has at least a non-zero amount
252 || Data.Map.size
253 (Data.Map.filter
254 ( Strict.maybe False
255 ( not . Data.Foldable.all
256 ( Amount.is_zero
257 . Amount.sum_balance )
258 . Balance.get_Account_Sum
259 . Balance.inclusive )
260 . Lib.TreeMap.node_value )
261 descendants) > 1
262 in
263 if is_worth
264 then
265 Data.Foldable.any
266 (Filter.test (ctx_filter_balance ctx) . (acct,)) $
267 Balance.get_Account_Sum $
268 Balance.inclusive balance
269 else False
270 ) $
271 Balance.expanded balance_by_account in
272 let balance_by_unit =
273 Balance.by_unit_of_expanded
274 balance_expanded
275 mempty in
276 ( balance_expanded
277 , balance_by_unit
278 )
279
280 write_by_accounts
281 :: Ctx
282 -> Balance.Expanded (Amount.Sum Amount)
283 -> [[Table.Cell]]
284 -> [[Table.Cell]]
285 write_by_accounts _ctx =
286 let posting_type = Ledger.Posting_Type_Regular in
287 flip $ Lib.TreeMap.foldr_with_Path
288 (\account balance rows ->
289 foldr
290 (\(amount_positive, amount_negative, amount) ->
291 zipWith (:)
292 [ Table.cell
293 { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive
294 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive
295 }
296 , Table.cell
297 { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative
298 , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative
299 }
300 , Table.cell
301 { Table.cell_content = Amount.Write.amount $ amount
302 , Table.cell_width = Amount.Write.amount_length $ amount
303 }
304 , Table.cell
305 { Table.cell_content = Ledger.Write.account posting_type account
306 , Table.cell_width = Ledger.Write.account_length posting_type account
307 }
308 ]
309 )
310 rows $
311 let bal = Balance.get_Account_Sum $ Balance.inclusive balance in
312 Data.Map.foldrWithKey
313 (\unit amount acc ->
314 ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
315 , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
316 , Amount.sum_balance amount
317 ) : acc
318 ) [] $ bal
319 )
320
321 write_by_amounts
322 :: Data.Map.Map Unit (Amount.Sum Amount)
323 -> [[Table.Cell]]
324 -> [[Table.Cell]]
325 write_by_amounts =
326 flip $ foldr
327 (\amount_sum ->
328 zipWith (:)
329 [ let amt = Amount.sum_positive amount_sum in
330 Table.cell
331 { Table.cell_content = maybe W.empty Amount.Write.amount amt
332 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
333 }
334 , let amt = Amount.sum_negative amount_sum in
335 Table.cell
336 { Table.cell_content = maybe W.empty Amount.Write.amount amt
337 , Table.cell_width = maybe 0 Amount.Write.amount_length amt
338 }
339 , let amt = Amount.sum_balance amount_sum in
340 Table.cell
341 { Table.cell_content = Amount.Write.amount amt
342 , Table.cell_width = Amount.Write.amount_length amt
343 }
344 , Table.cell
345 { Table.cell_content = W.empty
346 , Table.cell_width = 0
347 }
348 ]
349 )