]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Command/Balance.hs
Refactor hcompta-lib.
[comptalang.git] / cli / Hcompta / CLI / Command / Balance.hs
1 {-# LANGUAGE ExistentialQuantification #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE NamedFieldPuns #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE Rank2Types #-}
8 {-# LANGUAGE RecordWildCards #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TupleSections #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13 module Hcompta.CLI.Command.Balance where
14
15 import Control.Applicative ((<*), Const(..), Applicative(..))
16 import Control.Arrow (first, (+++), (&&&), (***))
17 import Control.DeepSeq (NFData)
18 import Control.Monad (Monad(..), liftM, mapM)
19 import Control.Monad.IO.Class (liftIO)
20 import Data.Bool
21 import Data.Data
22 import Data.Decimal (Decimal)
23 import Data.Either (Either(..), partitionEithers)
24 import Data.Eq (Eq(..))
25 import Data.Foldable (Foldable)
26 import qualified Data.Foldable as Foldable
27 import Data.Function (($), (.), const, on)
28 import Data.Functor (Functor(..), (<$>))
29 import qualified Data.List as List
30 -- import Data.List.NonEmpty (NonEmpty(..))
31 import Data.Map.Strict (Map)
32 import qualified Data.Map.Strict as Map
33 import Data.Maybe (Maybe(..))
34 import Data.Monoid (Monoid(..), (<>))
35 import Data.Ord (Ord(..), Ordering(..))
36 import qualified Data.Strict.Maybe as Strict
37 import Data.String (String)
38 import Data.Text (Text)
39 import qualified Data.Time.Clock as Time
40 import Data.TreeMap.Strict (TreeMap)
41 import qualified Data.TreeMap.Strict as TreeMap
42 import Data.Tuple (fst, snd)
43 import Prelude (Bounded(..), Num(..), unlines, zipWith)
44 import Data.Function (id, flip)
45 import System.Console.GetOpt
46 ( ArgDescr(..)
47 , OptDescr(..)
48 , usageInfo
49 )
50 import qualified System.Environment as Env
51 import System.Exit (exitSuccess)
52 import System.IO (IO, FilePath)
53 import qualified System.IO as IO
54 import qualified Text.Parsec
55 import Text.Show (Show(..))
56 import Text.WalderLeijen.ANSI.Text (ToDoc(..))
57 import qualified Text.WalderLeijen.ANSI.Text as W
58
59 import qualified Hcompta as H
60 import qualified Hcompta.Lib.Strict as Strict
61
62 import qualified Hcompta.CLI.Args as Args
63 import qualified Hcompta.CLI.Context as C
64 import qualified Hcompta.CLI.Env as CLI.Env
65 import Hcompta.CLI.Format (Format(..), Formats)
66 import qualified Hcompta.CLI.Format as Format
67 import Hcompta.CLI.Format.JCC ()
68 import Hcompta.CLI.Format.Ledger ()
69 import qualified Hcompta.CLI.Lang as Lang
70 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
71 import qualified Hcompta.CLI.Write as Write
72 import qualified Hcompta.JCC as JCC
73 import qualified Hcompta.Ledger as Ledger
74
75 import qualified Text.Parsec.Error.Custom as R
76
77 -- type Sum = (Ledger.Unit, H.Polarized Ledger.Quantity)
78
79 data Context
80 = Context
81 { {-ctx_filter_transaction :: forall t.
82 ( Filter.Transaction t
83 , Filter.Amount_Quantity
84 (Posting.Posting_Amount
85 (Filter.Transaction_Posting t))
86 ~ Filter.Amount.Quantity
87 ) => Filter.Simplified
88 (Filter.Filter_Bool
89 (Filter.Filter_Transaction t))
90 , ctx_filter_balance :: forall b.
91 ( Filter.Balance b
92 , Filter.Amount_Quantity
93 (Filter.Balance_Amount b)
94 ~ Filter.Amount.Quantity
95 ) => Filter.Simplified
96 (Filter.Filter_Bool
97 (Filter.Filter_Balance b))
98 -- , ctx_filter_posting :: CLI.Format.Filter_Posting
99 ,-} ctx_heritage :: Bool
100 , ctx_input :: [FilePath]
101 , ctx_input_format :: Formats
102 , ctx_output :: [(Write.Mode, FilePath)]
103 , ctx_output_format :: (Maybe Formats, Output_Format)
104 , ctx_reduce_date :: Bool
105 , ctx_redundant :: Bool
106 , ctx_total_by_unit :: Bool
107 , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
108 } -- deriving (Show)
109
110 data Output_Format
111 = Output_Format_Table
112 | Output_Format_Transaction Lang.Exercise_OC
113 deriving (Eq, Show)
114
115 context :: C.Context -> Context
116 context c =
117 Context
118 { -- ctx_filter_transaction = Filter.Simplified $ Right True
119 -- , ctx_filter_balance = Filter.Simplified $ Right True
120 -- , ctx_filter_posting = mempty
121 ctx_heritage = True
122 , ctx_input = []
123 , ctx_input_format = mempty
124 , ctx_output = []
125 , ctx_output_format = (Nothing, Output_Format_Table)
126 , ctx_reduce_date = True
127 , ctx_redundant = False
128 , ctx_total_by_unit = True
129 , ctx_account_equilibrium =
130 let e = C.translate c Lang.Account_Equilibrium
131 in (e, e)
132 }
133
134 usage :: C.Context -> IO String
135 usage c = do
136 bin <- Env.getProgName
137 return $ unlines $
138 [ C.translate c Lang.Section_Description
139 , " "<>C.translate c Lang.Help_Command_Balance
140 , ""
141 , C.translate c Lang.Section_Syntax
142 , " "<>bin<>" balance ["<>C.translate c Lang.Type_Option<>"] [...]"<>
143 " ["<>C.translate c Lang.Type_File_Journal<>"] [...]"
144 , ""
145 , usageInfo (C.translate c Lang.Section_Options) (options c)
146 ]
147
148 options :: C.Context -> Args.Options Context
149 options c =
150 [ {-Option "b" ["filter-balance"]
151 (ReqArg (\s ctx -> do
152 filter <-
153 R.runParserT_with_Error
154 Filter.Read.filter_balance
155 Filter.Read.context "" s
156 case filter of
157 Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
158 Right flt ->
159 return $
160 ctx{ctx_filter_balance =
161 Filter.and (ctx_filter_balance ctx) $
162 (Filter.simplify $
163 Filter.Read.get_Forall_Filter_Balance_Decimal <$> flt)
164 }) $
165 C.translate c Lang.Type_Filter_Balance) $
166 C.translate c Lang.Help_Option_Filter_Balance
167 -}
168 {-, Option "p" ["filter-posting"]
169 (ReqArg (\s ctx -> do
170 read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
171 case read of
172 Left ko -> Write.fatal c ko
173 Right filter -> return $
174 ctx{ctx_filter_posting =
175 (ctx_filter_posting ctx <>) $
176 CLI.Format.All
177 (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
178 (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
179 }) $
180 C.translate c Lang.Type_Filter_Posting) $
181 C.translate c Lang.Help_Option_Filter_Posting
182 -}
183 {-, Option "t" ["filter-transaction"]
184 (ReqArg (\s ctx -> do
185 filter <-
186 R.runParserT_with_Error
187 Filter.Read.filter_transaction
188 Filter.Read.context "" s
189 case filter of
190 Left ko -> Write.fatal c ko
191 Right flt ->
192 return $
193 ctx{ctx_filter_transaction =
194 Filter.and (ctx_filter_transaction ctx) $
195 (Filter.simplify $
196 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
197 }) $
198 C.translate c Lang.Type_Filter_Transaction) $
199 C.translate c Lang.Help_Option_Filter_Transaction
200 ,-} Option "h" ["help"]
201 (NoArg (\_ctx -> do
202 usage c >>= IO.hPutStr IO.stderr
203 exitSuccess)) $
204 C.translate c Lang.Help_Option_Help
205 , Option "i" ["input"]
206 (ReqArg (\s ctx -> do
207 return $ ctx{ctx_input=s:ctx_input ctx}) $
208 C.translate c Lang.Type_File_Journal) $
209 C.translate c Lang.Help_Option_Input
210 , Option "f" ["input-format"]
211 (OptArg (\arg ctx -> do
212 ctx_input_format <- case arg of
213 Nothing -> return $ Format_JCC ()
214 Just "jcc" -> return $ Format_JCC ()
215 Just "ledger" -> return $ Format_Ledger ()
216 Just _ -> Write.fatal c $
217 W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
218 return $ ctx{ctx_input_format})
219 "[jcc|ledger]")
220 "input format"
221 , Option "o" ["output"]
222 (ReqArg (\s ctx -> do
223 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
224 C.translate c Lang.Type_File) $
225 C.translate c Lang.Help_Option_Output
226 , Option "O" ["overwrite"]
227 (ReqArg (\s ctx -> do
228 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
229 C.translate c Lang.Type_File) $
230 C.translate c Lang.Help_Option_Overwrite
231 {- NOTE: not used so far.
232 , Option "" ["reduce-date"]
233 (OptArg (\arg ctx -> do
234 ctx_reduce_date <- case arg of
235 Nothing -> return $ True
236 Just "yes" -> return $ True
237 Just "no" -> return $ False
238 Just _ -> Write.fatal c $
239 W.text "--reduce-date option expects \"yes\", or \"no\" as value"
240 return $ ctx{ctx_reduce_date})
241 "[yes|no]")
242 "use advanced date reducer to speed up filtering"
243 -}
244 , Option "" ["redundant"]
245 (OptArg (\arg ctx -> do
246 ctx_redundant <- case arg of
247 Nothing -> return $ True
248 Just "yes" -> return $ True
249 Just "no" -> return $ False
250 Just _ -> Write.fatal c Lang.Error_Option_Balance_Redundant
251 return $ ctx{ctx_redundant})
252 "[no|yes]") $
253 C.translate c Lang.Help_Option_Balance_Redundant
254 , Option "" ["heritage"]
255 (OptArg (\arg ctx -> do
256 ctx_heritage <- case arg of
257 Nothing -> return $ True
258 Just "yes" -> return $ True
259 Just "no" -> return $ False
260 Just _ -> Write.fatal c Lang.Error_Option_Balance_Heritage
261 return $ ctx{ctx_heritage})
262 "[yes|no]") $
263 C.translate c Lang.Help_Option_Balance_Heritage
264 , Option "" ["total"]
265 (OptArg (\arg ctx -> do
266 ctx_total_by_unit <- case arg of
267 Nothing -> return $ True
268 Just "yes" -> return $ True
269 Just "no" -> return $ False
270 Just _ -> Write.fatal c Lang.Error_Option_Balance_Total
271 return $ ctx{ctx_total_by_unit})
272 "[yes|no]") $
273 C.translate c Lang.Help_Option_Balance_Total
274 , Option "F" ["output-format"]
275 (ReqArg (\arg ctx -> do
276 ctx_output_format <- case arg of
277 "table" -> return $ (Nothing , Output_Format_Table)
278 "table.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Table)
279 "table.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Table)
280 "open" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Opening)
281 "open.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Opening)
282 "open.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Opening)
283 "close" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Closing)
284 "close.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Closing)
285 "close.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Closing)
286 _ -> Write.fatal c Lang.Error_Option_Balance_Format
287 return $ ctx{ctx_output_format})
288 "[table|close|open][.jcc|.ledger]") $
289 C.translate c Lang.Help_Option_Balance_Format
290 , Option "" ["eq"]
291 (ReqArg (\arg ctx -> do
292 ctx_account_equilibrium <-
293 fmap (\e -> (e, e)) $
294 case Text.Parsec.runParser
295 (Ledger.read_account <* Text.Parsec.eof)
296 () "" arg of
297 Right acct -> return acct
298 _ -> Write.fatal c Lang.Error_Option_Equilibrium
299 return $ ctx{ctx_account_equilibrium}) $
300 C.translate c Lang.Type_Account) $
301 C.translate c Lang.Help_Option_Equilibrium
302 , Option "" ["eq-credit"]
303 (ReqArg (\arg ctx -> do
304 ctx_account_equilibrium <-
305 fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
306 case Text.Parsec.runParser
307 (Ledger.read_account <* Text.Parsec.eof)
308 () "" arg of
309 Right acct -> return acct
310 _ -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
311 return $ ctx{ctx_account_equilibrium}) $
312 C.translate c Lang.Type_Account) $
313 C.translate c Lang.Help_Option_Equilibrium_Credit
314 , Option "" ["eq-debit"]
315 (ReqArg (\arg ctx -> do
316 ctx_account_equilibrium <-
317 fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
318 case Text.Parsec.runParser
319 (Ledger.read_account <* Text.Parsec.eof)
320 () "" arg of
321 Right acct -> return acct
322 _ -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
323 return $ ctx{ctx_account_equilibrium}) $
324 C.translate c Lang.Type_Account) $
325 C.translate c Lang.Help_Option_Equilibrium_Debit
326 ]
327
328 run :: C.Context -> [String] -> IO ()
329 run c args = do
330 (ctx, inputs) <-
331 first (\x ->
332 case ctx_output x of
333 [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
334 _ -> x) <$>
335 Args.parse c usage options (context c, args)
336 input_paths <- CLI.Env.paths c $ ctx_input ctx <> inputs
337 read_journals <- mapM (liftIO . journal_read ctx) input_paths
338 case partitionEithers read_journals of
339 (errs@(_:_), _journals) -> Write.fatals c errs
340 ([], (journals::[Forall_Journal_Balance_by_Account])) -> do
341 let bal_by_account =
342 mconcat $
343 fmap Format.journal_flatten $
344 case fst $ ctx_output_format ctx of
345 Just f -> Format.journal_empty f:journals
346 Nothing -> journals
347 now <- H.date_epoch
348 with_color <- Write.with_color c IO.stdout
349 W.displayIO IO.stdout $
350 W.renderPretty with_color 1.0 maxBound $
351 case snd $ ctx_output_format ctx of
352 Output_Format_Table ->
353 toDoc () $ Leijen.Table.table_of (c, ctx) bal_by_account
354 Output_Format_Transaction oc ->
355 journal_equilibrium_transaction
356 (Const bal_by_account::Const Forall_Journal_Balance_by_Account ())
357 c ctx oc now
358 {-
359 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
360 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
361 Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
362 let sty = Write.style { Write.style_pretty = True }
363 -}
364
365 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
366 table_of (c, ctx) bal_by_account =
367 let lang = C.lang c in
368 let (rows_by_account, rows_by_unit) =
369 case ctx_heritage ctx of
370 True -> rows_of_balance_by_account $ expand bal_by_account
371 False -> rows_of_balance_by_account bal_by_account in
372 zipWith id
373 [ Leijen.Table.column (Lang.translate lang Lang.Title_Debit) Leijen.Table.Align_Right
374 , Leijen.Table.column (Lang.translate lang Lang.Title_Credit) Leijen.Table.Align_Right
375 , Leijen.Table.column (Lang.translate lang Lang.Title_Balance) Leijen.Table.Align_Right
376 , Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
377 ] $
378 rows_by_account $
379 (if ctx_total_by_unit ctx
380 then zipWith (:)
381 [ Leijen.Table.Cell_Line '=' 0
382 , Leijen.Table.Cell_Line '=' 0
383 , Leijen.Table.Cell_Line '=' 0
384 , Leijen.Table.Cell_Line ' ' 0
385 ] . rows_by_unit
386 else id) $
387 List.repeat []
388 where
389 expand
390 :: Forall_Journal_Balance_by_Account
391 -> Forall_Journal_Balance_by_Account_Expanded
392 expand = Format.journal_wrap
393 rows_of_balance_by_account
394 :: ( Format.Journal_Filter Context (Const bal_by_account) ()
395 , Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
396 , Format.Journal_Leijen_Table_Cells (Const bal_by_account) ()
397 )
398 => bal_by_account
399 -> ( [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]]
400 , [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]] )
401 rows_of_balance_by_account =
402 (***) Format.journal_leijen_table_cells
403 Format.journal_leijen_table_cells .
404 (&&&) id sum_by_unit .
405 Format.journal_filter ctx .
406 Const
407 where
408 sum_by_unit
409 :: Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
410 => Const bal_by_account ()
411 -> Const Forall_Journal_Balance_by_Unit ()
412 sum_by_unit = Const . Format.journal_wrap . getConst
413
414
415
416
417
418
419
420
421
422
423 -- * 'H.Balance_by_Account'
424
425 -- ** Type 'Format_Balance_by_Account'
426
427 type Format_Journal_Balance_by_Account
428 = Format
429 ( JCC.Journal Balance_by_Account_JCC)
430 (Ledger.Journal Balance_by_Account_Ledger)
431
432 -- JCC
433 type Balance_by_Account_JCC
434 = H.Balance_by_Account JCC.Account_Section
435 JCC.Unit
436 (H.Polarized JCC.Quantity)
437 instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
438 type Journal_Format (JCC.Journal Balance_by_Account_JCC)
439 = Format_Journal_Balance_by_Account
440 journal_format = Format_JCC
441
442 -- Ledger
443 type Balance_by_Account_Ledger
444 = H.Balance_by_Account Ledger.Account_Section
445 Ledger.Unit
446 (H.Polarized Ledger.Quantity)
447 instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
448 type Journal_Format (Ledger.Journal Balance_by_Account_Ledger)
449 = Format_Journal_Balance_by_Account
450 journal_format = Format_Ledger
451
452 -- ** Class 'Journal_Balance_by_Account'
453
454 class
455 ( Format.Journal (j m)
456 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
457 , Format.Journal_Read j
458 , Format.Journal_Monoid (j m)
459 , Format.Journal_Leijen_Table_Cells j m
460 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
461 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
462 , Format.Journal_Filter Context j m
463 , Journal_Equilibrium_Transaction j m
464 ) => Journal_Balance_by_Account j m
465
466 instance Journal_Balance_by_Account JCC.Journal Balance_by_Account_JCC
467 instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
468
469 -- ** Type 'Forall_Journal_Balance_by_Account'
470
471 data Forall_Journal_Balance_by_Account
472 = forall j m. Journal_Balance_by_Account j m
473 => Forall_Journal_Balance_by_Account (j m)
474
475 instance Format.Journal Forall_Journal_Balance_by_Account where
476 type Journal_Format Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
477 journal_format
478 (Forall_Journal_Balance_by_Account j) =
479 Format.journal_format j
480 instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
481 journal_empty f =
482 case f of
483 Format_JCC () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
484 Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
485 instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
486 journal_flatten
487 (Forall_Journal_Balance_by_Account j) =
488 Forall_Journal_Balance_by_Account $
489 Format.journal_flatten j
490 journal_fold f (Forall_Journal_Balance_by_Account j) =
491 Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
492 instance Monoid Forall_Journal_Balance_by_Account where
493 mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
494 mappend x y =
495 case (mappend `on` Format.journal_format) x y of
496 Format_JCC j -> Forall_Journal_Balance_by_Account j
497 Format_Ledger j -> Forall_Journal_Balance_by_Account j
498 mconcat js =
499 case js of
500 [] -> mempty
501 j:jn -> List.foldl' mappend j jn
502
503 -- ** 'journal_read'
504
505 type Journal_Filter_Simplified transaction
506 = Filter.Simplified
507 (Filter.Filter_Bool
508 (Filter.Filter_Transaction transaction))
509 type Journal_Read_Cons txn
510 = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
511 journal_read
512 :: Context -> FilePath
513 -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
514 journal_read ctx =
515 case ctx_input_format ctx of
516 Format_JCC () ->
517 let wrap (j::JCC.Journal Balance_by_Account_JCC)
518 = Forall_Journal_Balance_by_Account j in
519 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
520 = Filter.Filtered (ctx_filter_transaction ctx) in
521 liftM ((+++) Format.Message wrap) .
522 Format.journal_read cons
523 Format_Ledger () ->
524 let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
525 = Forall_Journal_Balance_by_Account j in
526 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
527 = Filter.Filtered (ctx_filter_transaction ctx) in
528 liftM ((+++) Format.Message wrap) .
529 Format.journal_read cons
530
531 {-
532 -- ** Type family 'Balance_by_Account'
533
534 type family Balance_by_Account (j:: * -> *) m
535 type instance Balance_by_Account
536 j (Balance.Expanded as u (Polarized q))
537 = j (Balance.Balance_by_Account as u (Polarized q))
538 type instance Balance_by_Account
539 (Const Forall_Journal_Balance_by_Account_Expanded) ()
540 = (Const Forall_Journal_Balance_by_Account ) ()
541 -}
542
543 -- Instances 'Format.Journal_Filter'
544
545 instance
546 ( Functor j
547 , Format.Journal_Chart j
548
549 , as ~ Format.Journal_Account_Section j
550 , Data as
551 {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
552 , NFData as
553 , Ord as
554 , Show as
555
556 , q ~ Format.Journal_Quantity j
557 , Format.Journal_Quantity j ~ Decimal
558 , H.Addable q
559 , H.Zero q
560
561 , H.Unit u
562 ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
563 journal_filter ctx j =
564 case Filter.simplified $ ctx_filter_balance ctx of
565 Right True | ctx_redundant ctx -> j
566 Right True ->
567 TreeMap.filter_with_Path_and_Node
568 (\n _p -> is_worth n) <$> j
569 Right False -> const mempty <$> j
570 Left flt ->
571 (<$> j) $
572 TreeMap.map_Maybe_with_Path_and_Node
573 (\node account (H.Balance_by_Account_Sum bal) ->
574 (if is_worth node bal then id else const Strict.Nothing) $
575 case Map.mapMaybeWithKey
576 (\unit qty ->
577 if Filter.test flt
578 ( (H.chart_account_tags account (Format.journal_chart j), account)
579 , (unit, qty)
580 )
581 then Just qty
582 else Nothing
583 ) bal of
584 m | Map.null m -> Strict.Nothing
585 m -> Strict.Just $ H.Balance_by_Account_Sum m
586 )
587 where
588 is_worth
589 :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
590 => TreeMap.Node k0 x0
591 -> t0 (H.Polarized a0)
592 -> Bool
593 is_worth _node bal =
594 ctx_redundant ctx
595 -- NOTE: worth if no descendant
596 -- but Account's exclusive
597 -- has at least a non-zero Amount
598 || Foldable.any
599 (not . H.quantity_null . H.depolarize)
600 bal
601 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
602 journal_filter ctx
603 (Const (Forall_Journal_Balance_by_Account j)) =
604 Const $ Forall_Journal_Balance_by_Account $
605 Format.journal_filter ctx j
606
607 -- Instances 'Format.Journal_Leijen_Table_Cells'
608
609 instance
610 ( Format.Journal_Content j
611 , Journal j
612
613 , as ~ Format.Journal_Account_Section j
614 , Ord as
615 , H.Addable (Format.Journal_Quantity j)
616
617 , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
618
619 , Balance_by_Account_Sum amt
620 , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
621 , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
622 ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
623 journal_leijen_table_cells jnl =
624 flip (TreeMap.foldr_with_Path
625 (\account balance rows ->
626 let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
627 Map.foldrWithKey
628 (\unit qty ->
629 zipWith (:)
630 [ cell_of $ (unit,) <$> H.polarized_positive qty
631 , cell_of $ (unit,) <$> H.polarized_negative qty
632 , cell_of (unit, H.depolarize qty)
633 , cell_of account
634 ]
635 )
636 rows bal
637 ))
638 (Format.journal_content jnl)
639 where
640 cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
641 cell_of = Leijen.Table.cell_of_forall_param jnl
642 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
643 journal_leijen_table_cells
644 (Const (Forall_Journal_Balance_by_Account j)) =
645 Format.journal_leijen_table_cells j
646
647 -- ** Class 'Balance_by_Account_Sum'
648
649 -- | A class to get a 'H.Balance_Account_Sum'
650 -- when operating on 'H.Balance_by_Account'
651 -- or 'H.Balance_Expanded' 'Strict.inclusive' field.
652 class Balance_by_Account_Sum amt where
653 type Balance_by_Account_Sum_Unit amt
654 type Balance_by_Account_Sum_Quantity amt
655 balance_by_account_sum
656 :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
657 (Balance_by_Account_Sum_Quantity amt)
658 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
659 type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum u q) = u
660 type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
661 balance_by_account_sum = id
662 instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
663 type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum_Expanded u q) = u
664 type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
665 balance_by_account_sum = Strict.inclusive
666
667 -- * 'H.Balance_Expanded'
668
669 -- ** Type 'Format_Journal_Balance_by_Account_Expanded'
670
671 type Format_Journal_Balance_by_Account_Expanded
672 = Format
673 ( JCC.Journal Balance_by_Account_Expanded_JCC)
674 (Ledger.Journal Balance_by_Account_Expanded_Ledger)
675
676 -- JCC
677 type Balance_by_Account_Expanded_JCC
678 = H.Balance_Expanded JCC.Account_Section
679 JCC.Unit
680 (H.Polarized JCC.Quantity)
681 instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
682 type Journal_Format (JCC.Journal Balance_by_Account_Expanded_JCC)
683 = Format_Journal_Balance_by_Account_Expanded
684 journal_format = Format_JCC
685
686 -- Ledger
687 type Balance_by_Account_Expanded_Ledger
688 = H.Balance_Expanded Ledger.Account_Section
689 Ledger.Unit
690 (H.Polarized Ledger.Quantity)
691 instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
692 type Journal_Format (Ledger.Journal Balance_by_Account_Expanded_Ledger)
693 = Format_Journal_Balance_by_Account_Expanded
694 journal_format = Format_Ledger
695
696 -- ** Class 'Journal_Balance_by_Account_Expanded'
697
698 class
699 ( Format.Journal (j m)
700 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
701 , Format.Journal_Leijen_Table_Cells j m
702 , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
703 , Format.Journal_Filter Context j m
704 ) => Journal_Balance_by_Account_Expanded j m
705
706 instance Journal_Balance_by_Account_Expanded JCC.Journal Balance_by_Account_Expanded_JCC
707 instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
708
709 -- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
710
711 data Forall_Journal_Balance_by_Account_Expanded
712 = forall j m. Journal_Balance_by_Account_Expanded j m
713 => Forall_Journal_Balance_by_Account_Expanded (j m)
714
715 instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
716 type Journal_Format Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
717 journal_format
718 (Forall_Journal_Balance_by_Account_Expanded j) =
719 Format.journal_format j
720
721 -- Instances 'Format.Journal_Filter'
722
723 instance
724 ( Functor j
725 , Format.Journal_Chart j
726 , as ~ Format.Journal_Account_Section j
727 , Data as
728 {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
729 , NFData as
730 , Ord as
731 , Show as
732 , q ~ Format.Journal_Quantity j
733 , Format.Journal_Quantity j ~ Decimal
734 , H.Addable q
735 , H.Zero q
736 , H.Unit u
737 ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
738 journal_filter ctx j =
739 case Filter.simplified $ ctx_filter_balance ctx of
740 Right True | ctx_redundant ctx -> j
741 Right True ->
742 TreeMap.filter_with_Path_and_Node
743 (const . is_worth) <$> j
744 Right False -> const mempty <$> j
745 Left flt ->
746 (<$> j) $
747 TreeMap.map_Maybe_with_Path_and_Node
748 (\node account bal ->
749 (if is_worth node bal then id else const Strict.Nothing) $
750 case Map.mapMaybeWithKey
751 (\unit qty ->
752 if Filter.test flt
753 ( (H.chart_account_tags account (Format.journal_chart j), account)
754 , (unit, qty)
755 )
756 then Just qty
757 else Nothing
758 ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
759 m | Map.null m -> Strict.Nothing
760 m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
761 )
762 where
763 is_worth node bal =
764 let descendants = TreeMap.nodes
765 (TreeMap.node_descendants node) in
766 ctx_redundant ctx
767 -- NOTE: worth if no descendant
768 -- but Account's inclusive
769 -- has at least a non-zero Amount
770 || (Map.null descendants &&
771 Foldable.any
772 (not . H.quantity_null . H.depolarize)
773 (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
774 -- NOTE: worth if Account's exclusive
775 -- has at least a non-zero Amount
776 || (Foldable.any
777 (not . H.quantity_null . H.depolarize)
778 (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
779 -- NOTE: worth if Account has at least more than
780 -- one descendant Account whose inclusive
781 -- has at least a non-zero Amount
782 || Map.size
783 ( Map.filter
784 ( Strict.maybe False
785 ( Foldable.any
786 (not . H.quantity_null . H.depolarize)
787 . H.unBalance_by_Account_Sum
788 . Strict.inclusive )
789 . TreeMap.node_value )
790 descendants
791 ) > 1
792 instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
793 journal_filter ctx
794 (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
795 Const $ Forall_Journal_Balance_by_Account_Expanded $
796 Format.journal_filter ctx j
797
798 -- Instances 'Format.Journal_Leijen_Table_Cells'
799
800 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
801 journal_leijen_table_cells
802 (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
803 Format.journal_leijen_table_cells j
804
805 -- Instances H.Balance_by_Account -> H.Balance_Expanded
806
807 instance
808 ( Functor j
809 , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
810
811 -- NOTE: constraints from H.balance_expanded
812 , Ord as
813 , Ord u
814 , H.Addable q
815 ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
816 Forall_Journal_Balance_by_Account_Expanded where
817 journal_wrap =
818 Forall_Journal_Balance_by_Account_Expanded .
819 fmap H.balance_expanded
820
821 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
822 Forall_Journal_Balance_by_Account_Expanded where
823 journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
824
825
826
827
828
829
830
831
832
833
834
835 -- * 'H.Balance_by_Unit'
836
837 type Format_Journal_Balance_by_Unit
838 = Format
839 ( JCC.Journal Balance_by_Unit_JCC)
840 (Ledger.Journal Balance_by_Unit_Ledger)
841
842 -- JCC
843 type Balance_by_Unit_JCC
844 = H.Balance_by_Unit JCC.Account
845 JCC.Unit
846 (H.Polarized JCC.Quantity)
847 instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
848 type Journal_Format (JCC.Journal Balance_by_Unit_JCC)
849 = Format_Journal_Balance_by_Unit
850 journal_format = Format_JCC
851
852 -- Ledger
853 type Balance_by_Unit_Ledger
854 = H.Balance_by_Unit Ledger.Account
855 Ledger.Unit
856 (H.Polarized Ledger.Quantity)
857 instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
858 type Journal_Format (Ledger.Journal Balance_by_Unit_Ledger)
859 = Format_Journal_Balance_by_Unit
860 journal_format = Format_Ledger
861
862 -- ** Class 'Journal_Balance_by_Unit'
863
864 class
865 ( Format.Journal (j m)
866 , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
867 , Format.Journal_Leijen_Table_Cells j m
868 -- , Journal_Equilibrium_Postings j m
869 )
870 => Journal_Balance_by_Unit j m
871
872 instance Journal_Balance_by_Unit JCC.Journal Balance_by_Unit_JCC
873 instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
874
875 -- ** Type 'Forall_Journal_Balance_by_Unit'
876
877 data Forall_Journal_Balance_by_Unit
878 = forall j m. Journal_Balance_by_Unit j m
879 => Forall_Journal_Balance_by_Unit (j m)
880
881 instance Format.Journal Forall_Journal_Balance_by_Unit where
882 type Journal_Format Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
883 journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
884
885 -- Instances H.Balance_by_Account -> H.Balance_by_Unit
886
887 instance
888 ( Functor j
889 , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
890
891 -- NOTE: constraints from H.balance_by_unit_of_by_account
892 , H.Account (H.Account_Path as)
893 , Ord as
894 , Ord u
895 , H.Addable q
896 ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
897 Forall_Journal_Balance_by_Unit where
898 journal_wrap =
899 Forall_Journal_Balance_by_Unit .
900 fmap (flip H.balance_by_unit_of_by_account mempty)
901
902 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
903 Forall_Journal_Balance_by_Unit where
904 journal_wrap
905 (Forall_Journal_Balance_by_Account j) =
906 Format.journal_wrap j
907
908 -- Instances H.Balance_Expanded -> H.Balance_by_Unit
909
910 instance
911 ( Functor j
912 , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
913
914 -- NOTE: constraints from H.balance_by_unit_of_expanded
915 , H.Account (H.Account_Path as)
916 , Ord as
917 , Ord u
918 , H.Addable q
919 ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
920 Forall_Journal_Balance_by_Unit where
921 journal_wrap =
922 Forall_Journal_Balance_by_Unit .
923 fmap (flip H.balance_by_unit_of_expanded mempty)
924
925 instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
926 Forall_Journal_Balance_by_Unit where
927 journal_wrap
928 (Forall_Journal_Balance_by_Account_Expanded j) =
929 Format.journal_wrap j
930
931 -- Instances 'Format.Journal_Leijen_Table_Cells'
932
933 instance
934 ( Format.Journal_Content j
935 , Journal j
936
937 , a ~ Format.Journal_Account j
938 , H.Account a
939 , u ~ Format.Journal_Unit j
940 , Ord u
941 , q ~ Format.Journal_Quantity j
942 , H.Addable (Format.Journal_Quantity j)
943 ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
944 journal_leijen_table_cells jnl acc =
945 let H.Balance_by_Unit bal = Format.journal_content jnl in
946 Map.foldrWithKey
947 (\unit amt ->
948 let qty = H.balance_by_unit_sum_quantity amt in
949 zipWith (:)
950 [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
951 , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
952 , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
953 , Leijen.Table.cell
954 ]
955 ) acc bal
956 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
957 journal_leijen_table_cells
958 (Const (Forall_Journal_Balance_by_Unit j)) =
959 Format.journal_leijen_table_cells j
960
961
962
963
964
965
966
967
968
969 -- * Class 'Journal'
970
971 class
972 ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
973 , W.ToDoc1 j [Format.Journal_Transaction j]
974 ) => Journal (j:: * -> *) where
975 journal_posting
976 :: forall m. j m
977 -> H.Account_Path (Format.Journal_Account_Section j)
978 -> Map (Format.Journal_Unit j)
979 (Format.Journal_Quantity j)
980 -> [Text] -- ^ Comments
981 -> Format.Journal_Posting j
982 journal_transaction
983 :: forall m. j m
984 -> Text -- ^ Wording
985 -> (H.Date, [H.Date])
986 -> Map (H.Account_Path (Format.Journal_Account_Section j))
987 [Format.Journal_Posting j]
988 -> Format.Journal_Transaction j
989
990 instance Journal JCC.Journal where
991 journal_posting _j acct
992 posting_amounts
993 posting_comments =
994 (JCC.posting acct)
995 { JCC.posting_amounts
996 , JCC.posting_comments
997 }
998 journal_transaction _j
999 transaction_wording
1000 transaction_dates
1001 transaction_postings =
1002 JCC.transaction
1003 { JCC.transaction_wording
1004 , JCC.transaction_dates
1005 , JCC.transaction_postings
1006 }
1007 instance Journal Ledger.Journal where
1008 journal_posting _j acct
1009 posting_amounts
1010 posting_comments =
1011 (Ledger.posting acct)
1012 { Ledger.posting_amounts
1013 , Ledger.posting_comments
1014 }
1015 journal_transaction _j
1016 transaction_wording
1017 transaction_dates
1018 transaction_postings =
1019 Ledger.transaction
1020 { Ledger.transaction_wording
1021 , Ledger.transaction_dates
1022 , Ledger.transaction_postings
1023 }
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037 -- * Class 'Journal_Equilibrium_Transaction'
1038
1039 class Journal_Equilibrium_Transaction j m where
1040 journal_equilibrium_transaction
1041 :: j m
1042 -> C.Context
1043 -> Context
1044 -> Lang.Exercise_OC
1045 -> H.Date
1046 -> W.Doc
1047
1048 instance
1049 ( Format.Journal_Content j
1050 , Journal j
1051
1052 , as ~ Format.Journal_Account_Section j
1053 , Format.Journal_Account_Section j ~ Text
1054 , Format.Journal_Account j ~ TreeMap.Path Text
1055 , Num quantity
1056 , quantity ~ Format.Journal_Quantity j
1057 , Ord unit
1058 , Ord quantity
1059 , H.Zero (Format.Journal_Quantity j)
1060 , H.Addable (Format.Journal_Quantity j)
1061 , unit ~ Format.Journal_Unit j
1062 ) => Journal_Equilibrium_Transaction
1063 j (H.Balance_by_Account as unit (H.Polarized quantity)) where
1064 journal_equilibrium_transaction
1065 j c ctx oc now =
1066 let bal_by_account = Format.journal_content j in
1067 let H.Balance_by_Unit bal_by_unit =
1068 H.balance_by_unit_of_by_account bal_by_account mempty in
1069 let postings =
1070 Map.foldlWithKey
1071 (\acc unit H.Balance_by_Unit_Sum{..} ->
1072 let qty =
1073 (case oc of
1074 Lang.Exercise_Closing -> id
1075 Lang.Exercise_Opening -> negate) $
1076 H.depolarize balance_by_unit_sum_quantity in
1077 case H.quantity_sign qty of
1078 LT ->
1079 let account = snd $ ctx_account_equilibrium ctx in
1080 Map.insertWith mappend account
1081 [journal_posting j account
1082 (Map.singleton unit qty)
1083 [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
1084 acc
1085 EQ -> acc
1086 GT ->
1087 let account = fst $ ctx_account_equilibrium ctx in
1088 Map.insertWith mappend account
1089 [journal_posting j account
1090 (Map.singleton unit qty)
1091 [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
1092 acc
1093 )
1094 Map.empty
1095 bal_by_unit
1096 in
1097 W.toDoc1 j [
1098 journal_transaction j
1099 (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
1100 (now{Time.utctDayTime=0}, []) $
1101 Map.unionWith mappend postings $
1102 TreeMap.flatten_with_Path
1103 (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
1104 [ journal_posting j posting_account
1105 (flip fmap amount_by_unit $
1106 (case oc of
1107 Lang.Exercise_Closing -> negate
1108 Lang.Exercise_Opening -> id)
1109 . H.depolarize)
1110 []
1111 ]
1112 )
1113 bal_by_account
1114 ]
1115
1116 instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
1117 journal_equilibrium_transaction
1118 (Const (Forall_Journal_Balance_by_Account j)) =
1119 journal_equilibrium_transaction j
1120
1121 {-
1122 instance
1123 ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
1124 ( Forall_Journal_Balance_by_Account
1125 , Forall_Journal_Balance_by_Unit ) where
1126 toDoc c
1127 ( Forall_Journal_Balance_by_Account bal_by_account
1128 , Forall_Journal_Balance_by_Unit bal_by_unit
1129 ) =
1130 toDoc c (bal_by_account, bal_by_unit)
1131 -}