-
-
Notifications
You must be signed in to change notification settings - Fork 316
/
Journal.hs
1448 lines (1301 loc) · 63.2 KB
/
Journal.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
A 'Journal' is a set of transactions, plus optional related data. This is
hledger's primary data object. It is usually parsed from a journal file or
other data format (see "Hledger.Read").
-}
module Hledger.Data.Journal (
-- * Parsing helpers
addPriceDirective,
addTransactionModifier,
addPeriodicTransaction,
addTransaction,
journalBalanceTransactions,
journalApplyCommodityStyles,
commodityStylesFromAmounts,
journalCommodityStyles,
journalToCost,
journalReverse,
journalSetLastReadTime,
journalPivot,
-- * Filtering
filterJournalTransactions,
filterJournalPostings,
filterJournalAmounts,
filterTransactionAmounts,
filterTransactionPostings,
filterPostingAmount,
-- * Mapping
mapJournalTransactions,
mapJournalPostings,
mapTransactionPostings,
-- * Querying
journalAccountNamesUsed,
journalAccountNamesImplied,
journalAccountNamesDeclared,
journalAccountNamesDeclaredOrUsed,
journalAccountNamesDeclaredOrImplied,
journalAccountNames,
-- journalAmountAndPriceCommodities,
-- journalAmountStyles,
-- overJournalAmounts,
-- traverseJournalAmounts,
-- journalCanonicalCommodities,
journalDateSpan,
journalStartDate,
journalEndDate,
journalDescriptions,
journalFilePath,
journalFilePaths,
journalTransactionAt,
journalNextTransaction,
journalPrevTransaction,
journalPostings,
-- journalPrices,
-- * Standard account types
journalBalanceSheetAccountQuery,
journalProfitAndLossAccountQuery,
journalRevenueAccountQuery,
journalExpenseAccountQuery,
journalAssetAccountQuery,
journalLiabilityAccountQuery,
journalEquityAccountQuery,
journalCashAccountQuery,
-- * Misc
canonicalStyleFrom,
matchpats,
nulljournal,
journalCheckBalanceAssertions,
journalNumberAndTieTransactions,
journalUntieTransactions,
journalModifyTransactions,
-- * Tests
samplejournal,
tests_Journal,
)
where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Extra
import Control.Monad.Reader as R
import Control.Monad.ST
import Data.Array.ST
import Data.Function ((&))
import qualified Data.HashTable.ST.Cuckoo as H
import Data.List
import Data.List.Extra (groupSort, nubSort)
import qualified Data.Map as M
import Data.Maybe
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid
#endif
import qualified Data.Semigroup as Sem
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Safe (headMay, headDef)
import Data.Time.Calendar
import Data.Tree
import System.Time (ClockTime(TOD))
import Text.Printf
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.AccountName
import Hledger.Data.Amount
import Hledger.Data.Dates
import Hledger.Data.Transaction
import Hledger.Data.TransactionModifier
import Hledger.Data.Posting
import Hledger.Query
-- try to make Journal ppShow-compatible
-- instance Show ClockTime where
-- show t = "<ClockTime>"
-- deriving instance Show Journal
instance Show Journal where
show j
| debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts"
(journalFilePath j)
(length $ jtxns j)
(length accounts)
| debugLevel < 6 = printf "Journal %s with %d transactions, %d accounts: %s"
(journalFilePath j)
(length $ jtxns j)
(length accounts)
(show accounts)
| otherwise = printf "Journal %s with %d transactions, %d accounts: %s, commodity styles: %s"
(journalFilePath j)
(length $ jtxns j)
(length accounts)
(show accounts)
(show $ jinferredcommodities j)
-- ++ (show $ journalTransactions l)
where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j
-- showJournalDebug j = unlines [
-- show j
-- ,show (jtxns j)
-- ,show (jtxnmodifiers j)
-- ,show (jperiodictxns j)
-- ,show $ jparsetimeclockentries j
-- ,show $ jpricedirectives j
-- ,show $ jfinalcommentlines j
-- ,show $ jparsestate j
-- ,show $ map fst $ jfiles j
-- ]
-- The monoid instance for Journal is useful for two situations.
--
-- 1. concatenating finalised journals, eg with multiple -f options:
-- FIRST <> SECOND. The second's list fields are appended to the
-- first's, map fields are combined, transaction counts are summed,
-- the parse state of the second is kept.
--
-- 2. merging a child parsed journal, eg with the include directive:
-- CHILD <> PARENT. A parsed journal's data is in reverse order, so
-- this gives what we want.
--
instance Sem.Semigroup Journal where
j1 <> j2 = Journal {
jparsedefaultyear = jparsedefaultyear j2
,jparsedefaultcommodity = jparsedefaultcommodity j2
,jparseparentaccounts = jparseparentaccounts j2
,jparsealiases = jparsealiases j2
-- ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2
,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2
,jincludefilestack = jincludefilestack j2
,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2
,jdeclaredaccounttypes = jdeclaredaccounttypes j1 <> jdeclaredaccounttypes j2
,jcommodities = jcommodities j1 <> jcommodities j2
,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
,jpricedirectives = jpricedirectives j1 <> jpricedirectives j2
,jtxnmodifiers = jtxnmodifiers j1 <> jtxnmodifiers j2
,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2
,jtxns = jtxns j1 <> jtxns j2
,jfinalcommentlines = jfinalcommentlines j2 -- XXX discards j1's ?
,jfiles = jfiles j1 <> jfiles j2
,jlastreadtime = max (jlastreadtime j1) (jlastreadtime j2)
}
instance Monoid Journal where
mempty = nulljournal
#if !(MIN_VERSION_base(4,11,0))
-- This is redundant starting with base-4.11 / GHC 8.4.
mappend = (Sem.<>)
#endif
nulljournal :: Journal
nulljournal = Journal {
jparsedefaultyear = Nothing
,jparsedefaultcommodity = Nothing
,jparseparentaccounts = []
,jparsealiases = []
-- ,jparsetransactioncount = 0
,jparsetimeclockentries = []
,jincludefilestack = []
,jdeclaredaccounts = []
,jdeclaredaccounttypes = M.empty
,jcommodities = M.empty
,jinferredcommodities = M.empty
,jpricedirectives = []
,jtxnmodifiers = []
,jperiodictxns = []
,jtxns = []
,jfinalcommentlines = ""
,jfiles = []
,jlastreadtime = TOD 0 0
}
journalFilePath :: Journal -> FilePath
journalFilePath = fst . mainfile
journalFilePaths :: Journal -> [FilePath]
journalFilePaths = map fst . jfiles
mainfile :: Journal -> (FilePath, Text)
mainfile = headDef ("", "") . jfiles
addTransaction :: Transaction -> Journal -> Journal
addTransaction t j = j { jtxns = t : jtxns j }
addTransactionModifier :: TransactionModifier -> Journal -> Journal
addTransactionModifier mt j = j { jtxnmodifiers = mt : jtxnmodifiers j }
addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal
addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j }
addPriceDirective :: PriceDirective -> Journal -> Journal
addPriceDirective h j = j { jpricedirectives = h : jpricedirectives j } -- XXX #999 keep sorted
-- | Get the transaction with this index (its 1-based position in the input stream), if any.
journalTransactionAt :: Journal -> Integer -> Maybe Transaction
journalTransactionAt Journal{jtxns=ts} i =
-- it's probably ts !! (i+1), but we won't assume
headMay [t | t <- ts, tindex t == i]
-- | Get the transaction that appeared immediately after this one in the input stream, if any.
journalNextTransaction :: Journal -> Transaction -> Maybe Transaction
journalNextTransaction j t = journalTransactionAt j (tindex t + 1)
-- | Get the transaction that appeared immediately before this one in the input stream, if any.
journalPrevTransaction :: Journal -> Transaction -> Maybe Transaction
journalPrevTransaction j t = journalTransactionAt j (tindex t - 1)
-- | Unique transaction descriptions used in this journal.
journalDescriptions :: Journal -> [Text]
journalDescriptions = nubSort . map tdescription . jtxns
-- | All postings from this journal's transactions, in order.
journalPostings :: Journal -> [Posting]
journalPostings = concatMap tpostings . jtxns
-- | Sorted unique account names posted to by this journal's transactions.
journalAccountNamesUsed :: Journal -> [AccountName]
journalAccountNamesUsed = accountNamesFromPostings . journalPostings
-- | Sorted unique account names implied by this journal's transactions -
-- accounts posted to and all their implied parent accounts.
journalAccountNamesImplied :: Journal -> [AccountName]
journalAccountNamesImplied = expandAccountNames . journalAccountNamesUsed
-- | Sorted unique account names declared by account directives in this journal.
journalAccountNamesDeclared :: Journal -> [AccountName]
journalAccountNamesDeclared = nubSort . map fst . jdeclaredaccounts
-- | Sorted unique account names declared by account directives or posted to
-- by transactions in this journal.
journalAccountNamesDeclaredOrUsed :: Journal -> [AccountName]
journalAccountNamesDeclaredOrUsed j = nubSort $ journalAccountNamesDeclared j ++ journalAccountNamesUsed j
-- | Sorted unique account names declared by account directives, or posted to
-- or implied as parents by transactions in this journal.
journalAccountNamesDeclaredOrImplied :: Journal -> [AccountName]
journalAccountNamesDeclaredOrImplied j = nubSort $ journalAccountNamesDeclared j ++ journalAccountNamesImplied j
-- | Convenience/compatibility alias for journalAccountNamesDeclaredOrImplied.
journalAccountNames :: Journal -> [AccountName]
journalAccountNames = journalAccountNamesDeclaredOrImplied
journalAccountNameTree :: Journal -> Tree AccountName
journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-- queries for standard account types
-- | Get a query for accounts of a certain type (Asset, Liability..) in this journal.
-- The query will match all accounts which were declared as that type by account directives,
-- plus all their subaccounts which have not been declared as a different type.
-- If no accounts were declared as this type, the query will instead match accounts
-- with names matched by the provided case-insensitive regular expression.
journalAccountTypeQuery :: AccountType -> Regexp -> Journal -> Query
journalAccountTypeQuery atype fallbackregex j =
case M.lookup atype (jdeclaredaccounttypes j) of
Nothing -> Acct fallbackregex
Just as ->
-- XXX Query isn't able to match account type since that requires extra info from the journal.
-- So we do a hacky search by name instead.
And [
Or $ map (Acct . accountNameToAccountRegex) as
,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs
]
where
differentlytypedsubs = concat
[subs | (t,bs) <- M.toList (jdeclaredaccounttypes j)
, t /= atype
, let subs = [b | b <- bs, any (`isAccountNamePrefixOf` b) as]
]
-- | A query for accounts in this journal which have been
-- declared as Asset by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- @^assets?(:|$)@.
journalAssetAccountQuery :: Journal -> Query
journalAssetAccountQuery = journalAccountTypeQuery Asset "^assets?(:|$)"
-- | A query for accounts in this journal which have been
-- declared as Liability by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- @^(debts?|liabilit(y|ies))(:|$)@.
journalLiabilityAccountQuery :: Journal -> Query
journalLiabilityAccountQuery = journalAccountTypeQuery Liability "^(debts?|liabilit(y|ies))(:|$)"
-- | A query for accounts in this journal which have been
-- declared as Equity by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- @^equity(:|$)@.
journalEquityAccountQuery :: Journal -> Query
journalEquityAccountQuery = journalAccountTypeQuery Equity "^equity(:|$)"
-- | A query for accounts in this journal which have been
-- declared as Revenue by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@.
journalRevenueAccountQuery :: Journal -> Query
journalRevenueAccountQuery = journalAccountTypeQuery Revenue "^(income|revenue)s?(:|$)"
-- | A query for accounts in this journal which have been
-- declared as Expense by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@.
journalExpenseAccountQuery :: Journal -> Query
journalExpenseAccountQuery = journalAccountTypeQuery Expense "^expenses?(:|$)"
-- | A query for Asset, Liability & Equity accounts in this journal.
-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.
journalBalanceSheetAccountQuery :: Journal -> Query
journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j
,journalLiabilityAccountQuery j
,journalEquityAccountQuery j
]
-- | A query for Profit & Loss accounts in this journal.
-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Profit_.26_Loss_accounts>.
journalProfitAndLossAccountQuery :: Journal -> Query
journalProfitAndLossAccountQuery j = Or [journalRevenueAccountQuery j
,journalExpenseAccountQuery j
]
-- | A query for Cash (-equivalent) accounts in this journal (ie,
-- accounts which appear on the cashflow statement.) This is currently
-- hard-coded to be all the Asset accounts except for those with names
-- containing the case-insensitive regular expression @(receivable|:A/R|:fixed)@.
journalCashAccountQuery :: Journal -> Query
journalCashAccountQuery j = And [journalAssetAccountQuery j, Not $ Acct "(receivable|:A/R|:fixed)"]
-- Various kinds of filtering on journals. We do it differently depending
-- on the command.
-------------------------------------------------------------------------------
-- filtering V2
-- | Keep only transactions matching the query expression.
filterJournalTransactions :: Query -> Journal -> Journal
filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts}
-- | Keep only postings matching the query expression.
-- This can leave unbalanced transactions.
filterJournalPostings :: Query -> Journal -> Journal
filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostings q) ts}
-- | Within each posting's amount, keep only the parts matching the query.
-- This can leave unbalanced transactions.
filterJournalAmounts :: Query -> Journal -> Journal
filterJournalAmounts q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionAmounts q) ts}
-- | Filter out all parts of this transaction's amounts which do not match the query.
-- This can leave the transaction unbalanced.
filterTransactionAmounts :: Query -> Transaction -> Transaction
filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps}
-- | Filter out all parts of this posting's amount which do not match the query.
filterPostingAmount :: Query -> Posting -> Posting
filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as}
filterTransactionPostings :: Query -> Transaction -> Transaction
filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}
-- | Apply a transformation to a journal's transactions.
mapJournalTransactions :: (Transaction -> Transaction) -> Journal -> Journal
mapJournalTransactions f j@Journal{jtxns=ts} = j{jtxns=map f ts}
-- | Apply a transformation to a journal's postings.
mapJournalPostings :: (Posting -> Posting) -> Journal -> Journal
mapJournalPostings f j@Journal{jtxns=ts} = j{jtxns=map (mapTransactionPostings f) ts}
-- | Apply a transformation to a transaction's postings.
mapTransactionPostings :: (Posting -> Posting) -> Transaction -> Transaction
mapTransactionPostings f t@Transaction{tpostings=ps} = t{tpostings=map f ps}
{-
-------------------------------------------------------------------------------
-- filtering V1
-- | Keep only transactions we are interested in, as described by the
-- filter specification.
filterJournalTransactions :: FilterSpec -> Journal -> Journal
filterJournalTransactions FilterSpec{datespan=datespan
,cleared=cleared
-- ,real=real
-- ,empty=empty
,acctpats=apats
,descpats=dpats
,depth=depth
,fMetadata=md
} =
filterJournalTransactionsByStatus cleared .
filterJournalPostingsByDepth depth .
filterJournalTransactionsByAccount apats .
filterJournalTransactionsByMetadata md .
filterJournalTransactionsByDescription dpats .
filterJournalTransactionsByDate datespan
-- | Keep only postings we are interested in, as described by the filter
-- specification. This can leave unbalanced transactions.
filterJournalPostings :: FilterSpec -> Journal -> Journal
filterJournalPostings FilterSpec{datespan=datespan
,cleared=cleared
,real=real
,empty=empty
,acctpats=apats
,descpats=dpats
,depth=depth
,fMetadata=md
} =
filterJournalPostingsByRealness real .
filterJournalPostingsByStatus cleared .
filterJournalPostingsByEmpty empty .
filterJournalPostingsByDepth depth .
filterJournalPostingsByAccount apats .
filterJournalTransactionsByMetadata md .
filterJournalTransactionsByDescription dpats .
filterJournalTransactionsByDate datespan
-- | Keep only transactions whose metadata matches all metadata specifications.
filterJournalTransactionsByMetadata :: [(String,String)] -> Journal -> Journal
filterJournalTransactionsByMetadata pats j@Journal{jtxns=ts} = j{jtxns=filter matchmd ts}
where matchmd t = all (`elem` tmetadata t) pats
-- | Keep only transactions whose description matches the description patterns.
filterJournalTransactionsByDescription :: [String] -> Journal -> Journal
filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts}
where matchdesc = matchpats pats . tdescription
-- | Keep only transactions which fall between begin and end dates.
-- We include transactions on the begin date and exclude transactions on the end
-- date, like ledger. An empty date string means no restriction.
filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal
filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts}
where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end
-- | Keep only transactions which have the requested cleared/uncleared
-- status, if there is one.
filterJournalTransactionsByStatus :: Maybe Bool -> Journal -> Journal
filterJournalTransactionsByStatus Nothing j = j
filterJournalTransactionsByStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts}
where match = (==val).tstatus
-- | Keep only postings which have the requested cleared/uncleared status,
-- if there is one.
filterJournalPostingsByStatus :: Maybe Bool -> Journal -> Journal
filterJournalPostingsByStatus Nothing j = j
filterJournalPostingsByStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps}
-- | Strip out any virtual postings, if the flag is true, otherwise do
-- no filtering.
filterJournalPostingsByRealness :: Bool -> Journal -> Journal
filterJournalPostingsByRealness False j = j
filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps}
-- | Strip out any postings with zero amount, unless the flag is true.
filterJournalPostingsByEmpty :: Bool -> Journal -> Journal
filterJournalPostingsByEmpty True j = j
filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps}
-- -- | Keep only transactions which affect accounts deeper than the specified depth.
-- filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal
-- filterJournalTransactionsByDepth Nothing j = j
-- filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} =
-- j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)}
-- | Strip out any postings to accounts deeper than the specified depth
-- (and any transactions which have no postings as a result).
filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal
filterJournalPostingsByDepth Nothing j = j
filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} =
j{jtxns=filter (not . null . tpostings) $ map filtertxns ts}
where filtertxns t@Transaction{tpostings=ps} =
t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps}
-- | Keep only postings which affect accounts matched by the account patterns.
-- This can leave transactions unbalanced.
filterJournalPostingsByAccount :: [String] -> Journal -> Journal
filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}
where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps}
-- | Keep only transactions which affect accounts matched by the account patterns.
-- More precisely: each positive account pattern excludes transactions
-- which do not contain a posting to a matched account, and each negative
-- account pattern excludes transactions containing a posting to a matched
-- account.
filterJournalTransactionsByAccount :: [String] -> Journal -> Journal
filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter tmatch ts}
where
tmatch t = (null positives || any positivepmatch ps) && (null negatives || not (any negativepmatch ps)) where ps = tpostings t
positivepmatch p = any (`amatch` a) positives where a = paccount p
negativepmatch p = any (`amatch` a) negatives where a = paccount p
amatch pat a = regexMatchesCI (abspat pat) a
(negatives,positives) = partition isnegativepat apats
-}
-- | Reverse all lists of parsed items, which during parsing were
-- prepended to, so that the items are in parse order. Part of
-- post-parse finalisation.
journalReverse :: Journal -> Journal
journalReverse j =
j {jfiles = reverse $ jfiles j
,jdeclaredaccounts = reverse $ jdeclaredaccounts j
,jtxns = reverse $ jtxns j
,jtxnmodifiers = reverse $ jtxnmodifiers j
,jperiodictxns = reverse $ jperiodictxns j
,jpricedirectives = reverse $ jpricedirectives j
}
-- | Set this journal's last read time, ie when its files were last read.
journalSetLastReadTime :: ClockTime -> Journal -> Journal
journalSetLastReadTime t j = j{ jlastreadtime = t }
journalNumberAndTieTransactions = journalTieTransactions . journalNumberTransactions
-- | Number (set the tindex field) this journal's transactions, counting upward from 1.
journalNumberTransactions :: Journal -> Journal
journalNumberTransactions j@Journal{jtxns=ts} = j{jtxns=map (\(i,t) -> t{tindex=i}) $ zip [1..] ts}
-- | Tie the knot in all of this journal's transactions, ensuring their postings
-- refer to them. This should be done last, after any other transaction-modifying operations.
journalTieTransactions :: Journal -> Journal
journalTieTransactions j@Journal{jtxns=ts} = j{jtxns=map txnTieKnot ts}
-- | Untie all transaction-posting knots in this journal, so that eg
-- recursiveSize and GHCI's :sprint can work on it.
journalUntieTransactions :: Transaction -> Transaction
journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}
-- | Apply any transaction modifier rules in the journal
-- (adding automated postings to transactions, eg).
journalModifyTransactions :: Journal -> Journal
journalModifyTransactions j = j{ jtxns = modifyTransactions (jtxnmodifiers j) (jtxns j) }
-- | Check any balance assertions in the journal and return an error message
-- if any of them fail (or if the transaction balancing they require fails).
journalCheckBalanceAssertions :: Journal -> Maybe String
journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions True
-- "Transaction balancing" - inferring missing amounts and checking transaction balancedness and balance assertions
-- | Monad used for statefully balancing/amount-inferring/assertion-checking
-- a sequence of transactions.
-- Perhaps can be simplified, or would a different ordering of layers make sense ?
-- If you see a way, let us know.
type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s))
-- | The state used while balancing a sequence of transactions.
data BalancingState s = BalancingState {
-- read only
bsStyles :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used
,bsAssrt :: Bool -- ^ whether to check balance assertions
-- mutable
,bsBalances :: H.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty
,bsTransactions :: STArray s Integer Transaction -- ^ the transactions being balanced
}
-- | Access the current balancing state, and possibly modify the mutable bits,
-- lifting through the Except and Reader layers into the Balancing monad.
withB :: (BalancingState s -> ST s a) -> Balancing s a
withB f = ask >>= lift . lift . f
-- | Get an account's running balance so far.
getAmountB :: AccountName -> Balancing s MixedAmount
getAmountB acc = withB $ \BalancingState{bsBalances} -> do
fromMaybe 0 <$> H.lookup bsBalances acc
-- | Add an amount to an account's running balance, and return the new running balance.
addAmountB :: AccountName -> MixedAmount -> Balancing s MixedAmount
addAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc
let new = old + amt
H.insert bsBalances acc new
return new
-- | Set an account's running balance to this amount, and return the difference from the old.
setAmountB :: AccountName -> MixedAmount -> Balancing s MixedAmount
setAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
old <- fromMaybe 0 <$> H.lookup bsBalances acc
H.insert bsBalances acc amt
return $ amt - old
-- | Update (overwrite) this transaction with a new one.
storeTransactionB :: Transaction -> Balancing s ()
storeTransactionB t = withB $ \BalancingState{bsTransactions} ->
void $ writeArray bsTransactions (tindex t) t
-- | Infer any missing amounts (to satisfy balance assignments and
-- to balance transactions) and check that all transactions balance
-- and (optional) all balance assertions pass. Or return an error message
-- (just the first error encountered).
--
-- Assumes journalInferCommodityStyles has been called, since those affect transaction balancing.
--
-- This does multiple things because amount inferring, balance assignments,
-- balance assertions and posting dates are interdependent.
--
-- This can be simplified further. Overview as of 20190219:
-- @
-- ****** parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), budgetJournal (BudgetReport.hs), tests (BalanceReport.hs)
-- ******* journalBalanceTransactions
-- ******** runST
-- ********* runExceptT
-- ********** balanceTransaction (Transaction.hs)
-- *********** balanceTransactionHelper
-- ********** runReaderT
-- *********** balanceTransactionAndCheckAssertionsB
-- ************ addAmountAndCheckAssertionB
-- ************ addOrAssignAmountAndCheckAssertionB
-- ************ balanceTransactionHelper (Transaction.hs)
-- ****** uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} (ErrorScreen.hs)
-- ******* journalCheckBalanceAssertions
-- ******** journalBalanceTransactions
-- ****** transactionWizard, postingsBalanced (Add.hs), tests (Transaction.hs)
-- ******* balanceTransaction (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ?
-- @
journalBalanceTransactions :: Bool -> Journal -> Either String Journal
journalBalanceTransactions assrt j' =
let
-- ensure transactions are numbered, so we can store them by number
j@Journal{jtxns=ts} = journalNumberTransactions j'
-- display precisions used in balanced checking
styles = Just $ journalCommodityStyles j
-- balance assignments will not be allowed on these
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
in
runST $ do
-- We'll update a mutable array of transactions as we balance them,
-- not strictly necessary but avoids a sort at the end I think.
balancedtxns <- newListArray (1, genericLength ts) ts
-- Infer missing posting amounts, check transactions are balanced,
-- and check balance assertions. This is done in two passes:
runExceptT $ do
-- 1. Step through the transactions, balancing the ones which don't have balance assignments
-- and leaving the others for later. The balanced ones are split into their postings.
-- The postings and not-yet-balanced transactions remain in the same relative order.
psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case
t | null $ assignmentPostings t -> case balanceTransaction styles t of
Left e -> throwError e
Right t' -> do
lift $ writeArray balancedtxns (tindex t') t'
return $ map Left $ tpostings t'
t -> return [Right t]
-- 2. Sort these items by date, preserving the order of same-day items,
-- and step through them while keeping running account balances,
runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)
flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do
-- performing balance assignments in, and balancing, the remaining transactions,
-- and checking balance assertions as each posting is processed.
void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts
ts' <- lift $ getElems balancedtxns
return j{jtxns=ts'}
-- | This function is called statefully on each of a date-ordered sequence of
-- 1. fully explicit postings from already-balanced transactions and
-- 2. not-yet-balanced transactions containing balance assignments.
-- It executes balance assignments and finishes balancing the transactions,
-- and checks balance assertions on each posting as it goes.
-- An error will be thrown if a transaction can't be balanced
-- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment).
-- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments.
-- This stores the balanced transactions in case 2 but not in case 1.
balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s ()
balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
-- update the account's running balance and check the balance assertion if any
void $ addAmountAndCheckAssertionB $ removePrices p
balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do
-- make sure we can handle the balance assignments
mapM_ checkIllegalBalanceAssignmentB ps
-- for each posting, infer its amount from the balance assignment if applicable,
-- update the account's running balance and check the balance assertion if any
ps' <- forM ps $ \p -> pure (removePrices p) >>= addOrAssignAmountAndCheckAssertionB
-- infer any remaining missing amounts, and make sure the transaction is now fully balanced
styles <- R.reader bsStyles
case balanceTransactionHelper styles t{tpostings=ps'} of
Left err -> throwError err
Right (t', inferredacctsandamts) -> do
-- for each amount just inferred, update the running balance
mapM_ (uncurry addAmountB) inferredacctsandamts
-- and save the balanced transaction.
storeTransactionB t'
-- | If this posting has an explicit amount, add it to the account's running balance.
-- If it has a missing amount and a balance assignment, infer the amount from, and
-- reset the running balance to, the assigned balance.
-- If it has a missing amount and no balance assignment, leave it for later.
-- Then test the balance assertion if any.
addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}
| hasAmount p = do
newbal <- addAmountB acc amt
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
return p
| Just BalanceAssertion{baamount,batotal} <- mba = do
(diff,newbal) <- case batotal of
True -> do
-- a total balance assignment
let newbal = Mixed [baamount]
diff <- setAmountB acc newbal
return (diff,newbal)
False -> do
-- a partial balance assignment
oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getAmountB acc
let assignedbalthiscommodity = Mixed [baamount]
newbal = oldbalothercommodities + assignedbalthiscommodity
diff <- setAmountB acc newbal
return (diff,newbal)
let p' = p{pamount=diff, poriginal=Just $ originalPosting p}
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal
return p'
-- no amount, no balance assertion (GHC 7 doesn't like Nothing <- mba here)
| otherwise = return p
-- | Add the posting's amount to its account's running balance, and
-- optionally check the posting's balance assertion if any.
-- The posting is expected to have an explicit amount (otherwise this does nothing).
-- Adding and checking balance assertions are tightly paired because we
-- need to see the balance as it stands after each individual posting.
addAmountAndCheckAssertionB :: Posting -> Balancing s Posting
addAmountAndCheckAssertionB p | hasAmount p = do
newbal <- addAmountB (paccount p) (pamount p)
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
return p
addAmountAndCheckAssertionB p = return p
-- | Check a posting's balance assertion against the given actual balance, and
-- return an error if the assertion is not satisfied.
-- If the assertion is partial, unasserted commodities in the actual balance
-- are ignored; if it is total, they will cause the assertion to fail.
checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s ()
checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal =
forM_ assertedamts $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal
where
assertedamts = baamount : otheramts
where
assertedcomm = acommodity baamount
otheramts | batotal = map (\a -> a{aquantity=0}) $ amounts $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal
| otherwise = []
checkBalanceAssertionB _ _ = return ()
-- | Does this (single commodity) expected balance match the amount of that
-- commodity in the given (multicommodity) actual balance ? If not, returns a
-- balance assertion failure message based on the provided posting. To match,
-- the amounts must be exactly equal (display precision is ignored here).
-- If the assertion is inclusive, the expected amount is compared with the account's
-- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance.
checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s ()
checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do
let isinclusive = maybe False bainclusive $ pbalanceassertion p
actualbal' <-
if isinclusive
then
-- sum the running balances of this account and any of its subaccounts seen so far
withB $ \BalancingState{bsBalances} ->
H.foldM
(\ibal (acc, amt) -> return $ ibal +
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0)
0
bsBalances
else return actualbal
let
assertedcomm = acommodity assertedamt
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal'
pass =
aquantity
-- traceWith (("asserted:"++).showAmountDebug)
assertedamt ==
aquantity
-- traceWith (("actual:"++).showAmountDebug)
actualbalincomm
errmsg = printf (unlines
[ "balance assertion: %s",
"\nassertion details:",
"date: %s",
"account: %s%s",
"commodity: %s",
-- "display precision: %d",
"calculated: %s", -- (at display precision: %s)",
"asserted: %s", -- (at display precision: %s)",
"difference: %s"
])
(case ptransaction p of
Nothing -> "?" -- shouldn't happen
Just t -> printf "%s\ntransaction:\n%s"
(showGenericSourcePos pos)
(chomp $ showTransaction t)
:: String
where
pos = baposition $ fromJust $ pbalanceassertion p
)
(showDate $ postingDate p)
(T.unpack $ paccount p) -- XXX pack
(if isinclusive then " (and subs)" else "" :: String)
assertedcomm
-- (asprecision $ astyle actualbalincommodity) -- should be the standard display precision I think
(show $ aquantity actualbalincomm)
-- (showAmount actualbalincommodity)
(show $ aquantity assertedamt)
-- (showAmount assertedamt)
(show $ aquantity assertedamt - aquantity actualbalincomm)
when (not pass) $ throwError errmsg
-- | Throw an error if this posting is trying to do an illegal balance assignment.
checkIllegalBalanceAssignmentB :: Posting -> Balancing s ()
checkIllegalBalanceAssignmentB p = do
checkBalanceAssignmentPostingDateB p
checkBalanceAssignmentUnassignableAccountB p
-- XXX these should show position. annotateErrorWithTransaction t ?
-- | Throw an error if this posting is trying to do a balance assignment and
-- has a custom posting date (which makes amount inference too hard/impossible).
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
checkBalanceAssignmentPostingDateB p =
when (hasBalanceAssignment p && isJust (pdate p)) $
throwError $ unlines $
["postings which are balance assignments may not have a custom date."
,"Please write the posting amount explicitly, or remove the posting date:"
,""
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
]
-- | Throw an error if this posting is trying to do a balance assignment and
-- the account does not allow balance assignments (eg because it is referenced
-- by a transaction modifier, which might generate additional postings to it).
checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s ()
checkBalanceAssignmentUnassignableAccountB p = do
unassignable <- R.asks bsUnassignable
when (hasBalanceAssignment p && paccount p `S.member` unassignable) $
throwError $ unlines $
["balance assignments cannot be used with accounts which are"
,"posted to by transaction modifier rules (auto postings)."
,"Please write the posting amount explicitly, or remove the rule."
,""
,"account: "++T.unpack (paccount p)
,""
,"transaction:"
,""
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
]
--
-- | Choose and apply a consistent display format to the posting
-- amounts in each commodity. Each commodity's format is specified by
-- a commodity format directive, or otherwise inferred from posting
-- amounts as in hledger < 0.28. Can return an error message
-- eg if inconsistent number formats are found.
journalApplyCommodityStyles :: Journal -> Either String Journal
journalApplyCommodityStyles j@Journal{jtxns=ts, jpricedirectives=pds} =
case journalInferCommodityStyles j of
Left e -> Left e
Right j' -> Right j''
where
styles = journalCommodityStyles j'
j'' = j'{jtxns=map fixtransaction ts
,jpricedirectives=map fixpricedirective pds
}
fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p = p{pamount=styleMixedAmount styles $ pamount p
,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p}
fixbalanceassertion ba = ba{baamount=styleAmount styles $ baamount ba}
fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmountExceptPrecision styles a}
-- | Get the canonical amount styles for this journal, whether
-- declared by commodity directives, by the last default commodity (D)
-- directive, or inferred from posting amounts, as a map from symbol
-- to style. Styles declared by directives take precedence (and
-- commodity takes precedence over D). Styles from directives are
-- guaranteed to specify the decimal mark character.
journalCommodityStyles :: Journal -> M.Map CommoditySymbol AmountStyle
journalCommodityStyles j =
-- XXX could be some redundancy here, cf journalStyleInfluencingAmounts
commoditystyles <> defaultcommoditystyle <> inferredstyles
where
commoditystyles = M.mapMaybe cformat $ jcommodities j
defaultcommoditystyle = M.fromList $ catMaybes [jparsedefaultcommodity j]
inferredstyles = jinferredcommodities j
-- | Collect and save inferred amount styles for each commodity based on
-- the posting amounts in that commodity (excluding price amounts), ie:
-- "the format of the first amount, adjusted to the highest precision of all amounts".
-- Can return an error message eg if inconsistent number formats are found.
journalInferCommodityStyles :: Journal -> Either String Journal
journalInferCommodityStyles j =
case
commodityStylesFromAmounts $
dbg8 "journalInferCommodityStyles using amounts" $
journalStyleInfluencingAmounts j
of
Left e -> Left e
Right cs -> Right j{jinferredcommodities = cs}
-- | Given a list of amounts, in parse order (roughly speaking; see journalStyleInfluencingAmounts),
-- build a map from their commodity names to standard commodity
-- display formats. Can return an error message eg if inconsistent
-- number formats are found.
--
-- Though, these amounts may have come from multiple files, so we
-- shouldn't assume they use consistent number formats.
-- Currently we don't enforce that even within a single file,
-- and this function never reports an error.
--
commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle)
commodityStylesFromAmounts amts =
Right $ M.fromList commstyles
where
commamts = groupSort [(acommodity as, as) | as <- amts]
commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]
-- TODO: should probably detect and report inconsistencies here
-- | Given a list of amount styles (assumed to be from parsed amounts
-- in a single commodity), in parse order, choose a canonical style.
-- Traditionally it's "the style of the first, with the maximum precision of all".
--
canonicalStyleFrom :: [AmountStyle] -> AmountStyle
canonicalStyleFrom [] = amountstyle
canonicalStyleFrom ss@(s:_) =
s{asprecision=prec, asdecimalpoint=Just decmark, asdigitgroups=mgrps}
where
-- precision is maximum of all precisions
prec = maximumStrict $ map asprecision ss
-- identify the digit group mark (& group sizes)
mgrps = headMay $ mapMaybe asdigitgroups ss
-- if a digit group mark was identified above, we can rely on that;
-- make sure the decimal mark is different. If not, default to period.
defdecmark =
case mgrps of
Just (DigitGroups '.' _) -> ','
_ -> '.'
-- identify the decimal mark: the first one used, or the above default,
-- but never the same character as the digit group mark.
-- urgh.. refactor..
decmark = case mgrps of
Just _ -> defdecmark
_ -> headDef defdecmark $ mapMaybe asdecimalpoint ss
-- -- | Apply this journal's historical price records to unpriced amounts where possible.
-- journalApplyPriceDirectives :: Journal -> Journal
-- journalApplyPriceDirectives j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}
-- where