-
-
Notifications
You must be signed in to change notification settings - Fork 326
/
Copy pathCommon.hs
1621 lines (1436 loc) · 67 KB
/
Common.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
--- * -*- outline-regexp:"--- \\*"; -*-
--- ** doc
-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.
{-|
File reading/parsing utilities used by multiple readers, and a good
amount of the parsers for journal format, to avoid import cycles
when JournalReader imports other readers.
Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.
-}
--- ** language
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
--- ** exports
module Hledger.Read.Common (
Reader (..),
InputOpts(..),
HasInputOpts(..),
definputopts,
rawOptsToInputOpts,
-- * parsing utilities
parseAndFinaliseJournal,
initialiseAndParseJournal,
journalFinalise,
journalAddForecast,
journalAddAutoPostings,
setYear,
getYear,
setDefaultCommodityAndStyle,
getDefaultCommodityAndStyle,
getDefaultAmountStyle,
getAmountStyle,
addDeclaredAccountTags,
addDeclaredAccountType,
pushParentAccount,
popParentAccount,
getParentAccount,
addAccountAlias,
getAccountAliases,
clearAccountAliases,
journalAddFile,
-- * parsers
-- ** transaction bits
statusp,
codep,
descriptionp,
-- ** dates
datep,
datetimep,
secondarydatep,
-- ** account names
modifiedaccountnamep,
accountnamep,
-- ** account aliases
accountaliasp,
-- ** amounts
spaceandamountormissingp,
amountp,
amountp',
commoditysymbolp,
costp,
balanceassertionp,
lotcostp,
numberp,
fromRawNumber,
rawnumberp,
parseamount,
parseamount',
parsemixedamount,
parsemixedamount',
-- ** comments
isLineCommentStart,
isSameLineCommentStart,
multilinecommentp,
emptyorcommentlinep,
followingcommentp,
transactioncommentp,
postingcommentp,
-- ** bracketed dates
bracketeddatetagsp,
-- ** misc
noncommenttextp,
noncommenttext1p,
singlespacedtext1p,
singlespacednoncommenttext1p,
singlespacedtextsatisfying1p,
singlespacep,
skipNonNewlineSpaces,
skipNonNewlineSpaces1,
aliasesFromOpts,
-- * tests
tests_Common,
)
where
--- ** imports
import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
import qualified Control.Monad.Fail as Fail (fail)
import Control.Monad.Except (ExceptT(..), liftEither, withExceptT)
import Control.Monad.State.Strict hiding (fail)
import Data.Bifunctor (bimap, second)
import Data.Char (digitToInt, isDigit, isSpace)
import Data.Decimal (DecimalRaw (Decimal), Decimal)
import Data.Either (lefts, rights)
import Data.Function ((&))
import Data.Functor ((<&>), ($>))
import Data.List (find, genericReplicate, union)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
import qualified Data.Map as M
import qualified Data.Semigroup as Sem
import Data.Text (Text, stripEnd)
import qualified Data.Text as T
import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
import Data.Word (Word8)
import System.FilePath (takeFileName)
import Text.Megaparsec
import Text.Megaparsec.Char (char, char', digitChar, newline, string)
import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom
(FinalParseError, attachSource, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
-- import Text.Megaparsec.Debug (dbg) -- from megaparsec 9.3+
import Hledger.Data
import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery)
import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts)
import Hledger.Utils
import Hledger.Read.InputOptions
--- ** doctest setup
-- $setup
-- >>> :set -XOverloadedStrings
--- ** types
-- main types; a few more below
-- | A hledger journal reader is a triple of storage format name, a
-- detector of that format, and a parser from that format to Journal.
-- The type variable m appears here so that rParserr can hold a
-- journal parser, which depends on it.
data Reader m = Reader {
-- The canonical name of the format handled by this reader
rFormat :: StorageFormat
-- The file extensions recognised as containing this format
,rExtensions :: [String]
-- The entry point for reading this format, accepting input options, file
-- path for error messages and file contents, producing an exception-raising IO
-- action that produces a journal or error message.
,rReadFn :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
-- The actual megaparsec parser called by the above, in case
-- another parser (includedirectivep) wants to use it directly.
,rParser :: MonadIO m => ErroringJournalParser m ParsedJournal
}
instance Show (Reader m) where show r = rFormat r ++ " reader"
-- | Parse an InputOpts from a RawOpts and a provided date.
-- This will fail with a usage error if the forecast period expression cannot be parsed.
rawOptsToInputOpts :: Day -> RawOpts -> InputOpts
rawOptsToInputOpts day rawopts =
let noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion"
-- Do we really need to do all this work just to get the requested end date? This is duplicating
-- much of reportOptsToSpec.
ropts = rawOptsToReportOpts day rawopts
argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts
datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery
styles = either err id $ commodityStyleFromRawOpts rawopts
where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'" -- PARTIAL:
in definputopts{
-- files_ = listofstringopt "file" rawopts
mformat_ = Nothing
,mrules_file_ = maybestringopt "rules-file" rawopts
,aliases_ = listofstringopt "alias" rawopts
,anon_ = boolopt "anon" rawopts
,new_ = boolopt "new" rawopts
,new_save_ = True
,pivot_ = stringopt "pivot" rawopts
,forecast_ = forecastPeriodFromRawOpts day rawopts
,reportspan_ = DateSpan (queryStartDate False datequery) (queryEndDate False datequery)
,auto_ = boolopt "auto" rawopts
,infer_equity_ = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost
,infer_costs_ = boolopt "infer-costs" rawopts
,balancingopts_ = defbalancingopts{
ignore_assertions_ = boolopt "ignore-assertions" rawopts
, infer_transaction_prices_ = not noinferprice
, commodity_styles_ = Just styles
}
,strict_ = boolopt "strict" rawopts
,_ioDay = day
}
-- | Get the date span from --forecast's PERIODEXPR argument, if any.
-- This will fail with a usage error if the period expression cannot be parsed,
-- or if it contains a report interval.
forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan
forecastPeriodFromRawOpts d rawopts = do
arg <- maybestringopt "forecast" rawopts
let period = parsePeriodExpr d . stripquotes $ T.pack arg
return $ if null arg then nulldatespan else either badParse (getSpan arg) period
where
badParse e = usageError $ "could not parse forecast period : "++customErrorBundlePretty e
getSpan arg (interval, requestedspan) = case interval of
NoInterval -> requestedspan
_ -> usageError $ "--forecast's argument should not contain a report interval ("
++ show interval ++ " in \"" ++ arg ++ "\")"
-- | Given the name of the option and the raw options, returns either
-- | * a map of successfully parsed commodity styles, if all options where successfully parsed
-- | * the first option which failed to parse, if one or more options failed to parse
commodityStyleFromRawOpts :: RawOpts -> Either String (M.Map CommoditySymbol AmountStyle)
commodityStyleFromRawOpts rawOpts =
foldM (\r -> fmap (\(c,a) -> M.insert c a r) . parseCommodity) mempty optList
where
optList = listofstringopt "commodity-style" rawOpts
parseCommodity optStr = case parseamount optStr of
Left _ -> Left optStr
Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle)
-- | Given a parser to ParsedJournal, input options, file path and
-- content: run the parser on the content, and finalise the result to
-- get a Journal; or throw an error.
parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal parser iopts f txt =
initialiseAndParseJournal parser iopts f txt >>= journalFinalise iopts f txt
-- | Given a parser to ParsedJournal, input options, file path and
-- content: run the parser on the content. This is all steps of
-- 'parseAndFinaliseJournal' without the finalisation step, and is used when
-- you need to perform other actions before finalisation, as in parsing
-- Timeclock and Timedot files.
initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal
initialiseAndParseJournal parser iopts f txt =
prettyParseErrors $ runParserT (evalStateT parser initJournal) f txt
where
y = first3 . toGregorian $ _ioDay iopts
initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]}
-- Flatten parse errors and final parse errors, and output each as a pretty String.
prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ExceptT String IO a
prettyParseErrors = withExceptT customErrorBundlePretty . liftEither
<=< withExceptT (finalErrorBundlePretty . attachSource f txt)
{- HLINT ignore journalFinalise "Redundant <&>" -} -- silence this warning, the code is clearer as is
-- NB activates TH, may slow compilation ? https://github.com/ndmitchell/hlint/blob/master/README.md#customizing-the-hints
-- | Post-process a Journal that has just been parsed or generated, in this order:
--
-- - add misc info (file path, read time)
--
-- - reverse transactions into their original parse order
--
-- - apply canonical commodity styles
--
-- - add tags from account directives to postings' tags
--
-- - add forecast transactions if enabled
--
-- - add tags from account directives to postings' tags (again to affect forecast transactions)
--
-- - add auto postings if enabled
--
-- - add tags from account directives to postings' tags (again to affect auto postings)
--
-- - evaluate balance assignments and balance each transaction
--
-- - check balance assertions if enabled
--
-- - infer equity postings in conversion transactions if enabled
--
-- - infer market prices from costs if enabled
--
-- - check all accounts have been declared if in strict mode
--
-- - check all commodities have been declared if in strict mode
--
journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal
journalFinalise iopts@InputOpts{..} f txt pj = do
t <- liftIO getPOSIXTime
liftEither $ do
j <- pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_}
& journalSetLastReadTime t -- save the last read time
& journalAddFile (f, txt) -- save the main file's info
& journalReverse -- convert all lists to the order they were parsed
& journalAddAccountTypes -- build a map of all known account types
& journalApplyCommodityStyles -- Infer and apply commodity styles - should be done early
<&> journalAddForecast (forecastPeriod iopts pj) -- Add forecast transactions if enabled
<&> journalPostingsAddAccountTags -- Add account tags to postings, so they can be matched by auto postings.
>>= (if auto_ && not (null $ jtxnmodifiers pj)
then journalAddAutoPostings _ioDay balancingopts_ -- Add auto postings if enabled, and account tags if needed
else pure)
>>= (if infer_costs_ then journalAddPricesFromEquity else pure) -- Add inferred transaction prices from equity postings, if present
>>= journalBalanceTransactions balancingopts_ -- Balance all transactions and maybe check balance assertions.
<&> (if infer_equity_ then journalAddInferredEquityPostings else id) -- Add inferred equity postings, after balancing and generating auto postings
<&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions
<&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f) -- debug logging
<&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> " acct decls : ")
<&> journalRenumberAccountDeclarations
<&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> " acct decls renumbered: ")
when strict_ $ do
journalCheckAccounts j -- If in strict mode, check all postings are to declared accounts
journalCheckCommodities j -- and using declared commodities
return j
-- | Apply any auto posting rules to generate extra postings on this journal's transactions.
journalAddAutoPostings :: Day -> BalancingOpts -> Journal -> Either String Journal
journalAddAutoPostings d bopts =
-- Balance all transactions without checking balance assertions,
journalBalanceTransactions bopts{ignore_assertions_=True}
-- then add the auto postings
-- (Note adding auto postings after balancing means #893b fails;
-- adding them before balancing probably means #893a, #928, #938 fail.)
>=> journalModifyTransactions d
-- | Generate periodic transactions from all periodic transaction rules in the journal.
-- These transactions are added to the in-memory Journal (but not the on-disk file).
--
-- The start & end date for generated periodic transactions are determined in
-- a somewhat complicated way; see the hledger manual -> Periodic transactions.
journalAddForecast :: Maybe DateSpan -> Journal -> Journal
journalAddForecast Nothing j = j
journalAddForecast (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns}
where
forecasttxns =
map (txnTieKnot . transactionTransformPostings (postingApplyCommodityStyles $ journalCommodityStyles j))
. filter (spanContainsDate forecastspan . tdate)
. concatMap (`runPeriodicTransaction` forecastspan)
$ jperiodictxns j
setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
getYear :: JournalParser m (Maybe Year)
getYear = fmap jparsedefaultyear get
-- | Get the decimal mark that has been specified for parsing, if any
-- (eg by the CSV decimal-mark rule, or possibly a future journal directive).
-- Return it as an AmountStyle that amount parsers can use.
getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle = do
Journal{jparsedecimalmark} <- get
let mdecmarkStyle = (\c -> Just $ amountstyle{asdecimalpoint=Just c}) =<< jparsedecimalmark
return mdecmarkStyle
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
-- | Get amount style associated with default currency.
--
-- Returns 'AmountStyle' used to defined by a latest default commodity directive
-- prior to current position within this file or its parents.
getDefaultAmountStyle :: JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle = fmap snd <$> getDefaultCommodityAndStyle
-- | Get the 'AmountStyle' declared by the most recently parsed (in the current or parent files,
-- prior to the current position) commodity directive for the given commodity, if any.
getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle)
getAmountStyle commodity = do
Journal{jcommodities} <- get
let mspecificStyle = M.lookup commodity jcommodities >>= cformat
mdefaultStyle <- fmap snd <$> getDefaultCommodityAndStyle
return $ listToMaybe $ catMaybes [mspecificStyle, mdefaultStyle]
addDeclaredAccountTags :: AccountName -> [Tag] -> JournalParser m ()
addDeclaredAccountTags acct atags =
modify' (\j -> j{jdeclaredaccounttags = M.insertWith (flip union) acct atags (jdeclaredaccounttags j)})
addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m ()
addDeclaredAccountType acct atype =
modify' (\j -> j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)})
pushParentAccount :: AccountName -> JournalParser m ()
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: JournalParser m ()
popParentAccount = do
j <- get
case jparseparentaccounts j of
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: JournalParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases = fmap jparsealiases get
clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases = modify' (\j -> j{jparsealiases=[]})
-- getTransactionCount :: MonadState Journal m => m Integer
-- getTransactionCount = fmap jparsetransactioncount get
--
-- setTransactionCount :: MonadState Journal m => Integer -> m ()
-- setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})
--
-- -- | Increment the transaction index by one and return the new value.
-- incrementTransactionCount :: MonadState Journal m => m Integer
-- incrementTransactionCount = do
-- modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
-- getTransactionCount
journalAddFile :: (FilePath,Text) -> Journal -> Journal
journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
-- append, unlike the other fields, even though we do a final reverse,
-- to compensate for additional reversal due to including/monoid-concatting
-- A version of `match` that is strict in the returned text
match' :: TextParser m a -> TextParser m (Text, a)
match' p = do
(!txt, p') <- match p
pure (txt, p')
--- ** parsers
--- *** transaction bits
statusp :: TextParser m Status
statusp =
choice'
[ skipNonNewlineSpaces >> char '*' >> return Cleared
, skipNonNewlineSpaces >> char '!' >> return Pending
, return Unmarked
]
codep :: TextParser m Text
codep = option "" $ do
try $ do
skipNonNewlineSpaces1
char '('
code <- takeWhileP Nothing $ \c -> c /= ')' && c /= '\n'
char ')' <?> "closing bracket ')' for transaction code"
pure code
-- | Parse possibly empty text until a semicolon or newline.
-- Whitespace is preserved (for now - perhaps helps preserve alignment
-- of same-line comments ?).
descriptionp :: TextParser m Text
descriptionp = noncommenttextp <?> "description"
--- *** dates
-- | Parse a date in YYYY-MM-DD format.
-- Slash (/) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted.
datep :: JournalParser m Day
datep = do
mYear <- getYear
lift $ datep' mYear
datep' :: Maybe Year -> TextParser m Day
datep' mYear = do
startOffset <- getOffset
d1 <- yearorintp <?> "year or month"
sep <- datesepchar <?> "date separator"
d2 <- decimal <?> "month or day"
case d1 of
Left y -> fullDate startOffset y sep d2
Right m -> partialDate startOffset mYear m sep d2
<?> "full or partial date"
where
fullDate :: Int -> Year -> Char -> Month -> TextParser m Day
fullDate startOffset year sep1 month = do
sep2 <- satisfy isDateSepChar <?> "date separator"
day <- decimal <?> "day"
endOffset <- getOffset
let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day
when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $
"This date is malformed because the separators are different.\n"
++"Please use consistent separators."
case fromGregorianValid year month day of
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"This date is invalid, please correct it: " ++ dateStr
Just date -> pure $! date
partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day
partialDate startOffset myr month sep day = do
endOffset <- getOffset
case myr of
Just year ->
case fromGregorianValid year month day of
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"This date is invalid, please correct it: " ++ dateStr
Just date -> pure $! date
where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $
"The partial date "++dateStr++" can not be parsed because the current year is unknown.\n"
++"Consider making it a full date, or add a default year directive.\n"
where dateStr = show month ++ [sep] ++ show day
{-# INLINABLE datep' #-}
-- | Parse a date and time in YYYY-MM-DD HH:MM[:SS][+-ZZZZ] format.
-- Slash (/) and period (.) are also allowed as date separators.
-- The year may be omitted if a default year has been set.
-- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone).
datetimep :: JournalParser m LocalTime
datetimep = do
mYear <- getYear
lift $ datetimep' mYear
datetimep' :: Maybe Year -> TextParser m LocalTime
datetimep' mYear = do
day <- datep' mYear
skipNonNewlineSpaces1
time <- timeOfDay
optional timeZone -- ignoring time zones
pure $ LocalTime day time
where
timeOfDay :: TextParser m TimeOfDay
timeOfDay = do
off1 <- getOffset
h' <- twoDigitDecimal <?> "hour"
off2 <- getOffset
unless (h' >= 0 && h' <= 23) $ customFailure $
parseErrorAtRegion off1 off2 "invalid time (bad hour)"
char ':' <?> "':' (hour-minute separator)"
off3 <- getOffset
m' <- twoDigitDecimal <?> "minute"
off4 <- getOffset
unless (m' >= 0 && m' <= 59) $ customFailure $
parseErrorAtRegion off3 off4 "invalid time (bad minute)"
s' <- option 0 $ do
char ':' <?> "':' (minute-second separator)"
off5 <- getOffset
s' <- twoDigitDecimal <?> "second"
off6 <- getOffset
unless (s' >= 0 && s' <= 59) $ customFailure $
parseErrorAtRegion off5 off6 "invalid time (bad second)"
-- we do not support leap seconds
pure s'
pure $ TimeOfDay h' m' (fromIntegral s')
twoDigitDecimal :: TextParser m Int
twoDigitDecimal = do
d1 <- digitToInt <$> digitChar
d2 <- digitToInt <$> (digitChar <?> "a second digit")
pure $ d1*10 + d2
timeZone :: TextParser m String
timeZone = do
plusminus <- satisfy $ \c -> c == '-' || c == '+'
fourDigits <- count 4 (digitChar <?> "a digit (for a time zone)")
pure $ plusminus:fourDigits
secondarydatep :: Day -> TextParser m Day
secondarydatep primaryDate = char '=' *> datep' (Just primaryYear)
where primaryYear = first3 $ toGregorian primaryDate
-- | Parse a year number or an Int. Years must contain at least four
-- digits.
yearorintp :: TextParser m (Either Year Int)
yearorintp = do
yearOrMonth <- takeWhile1P (Just "digit") isDigit
let n = readDecimal yearOrMonth
return $ if T.length yearOrMonth >= 4 then Left n else Right (fromInteger n)
--- *** account names
-- | Parse an account name (plus one following space if present),
-- then apply any parent account prefix and/or account aliases currently in effect,
-- in that order. (Ie first add the parent account prefix, then rewrite with aliases).
-- This calls error if any account alias with an invalid regular expression exists.
modifiedaccountnamep :: JournalParser m AccountName
modifiedaccountnamep = do
parent <- getParentAccount
als <- getAccountAliases
-- off1 <- getOffset
a <- lift accountnamep
-- off2 <- getOffset
-- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)
case accountNameApplyAliases als $ joinAccountNames parent a of
Right a' -> return $! a'
-- should not happen, regexaliasp will have displayed a better error already:
-- (XXX why does customFailure cause error to be displayed there, but not here ?)
-- Left e -> customFailure $! parseErrorAtRegion off1 off2 err
Left e -> error' err -- PARTIAL:
where
err = "problem in account alias applied to "++T.unpack a++": "++e
-- | Parse an account name, plus one following space if present.
-- Account names have one or more parts separated by the account separator character,
-- and are terminated by two or more spaces (or end of input).
-- Each part is at least one character long, may have single spaces inside it,
-- and starts with a non-whitespace.
-- Note, this means "{account}", "%^!" and ";comment" are all accepted
-- (parent parsers usually prevent/consume the last).
-- It should have required parts to start with an alphanumeric;
-- for now it remains as-is for backwards compatibility.
accountnamep :: TextParser m AccountName
accountnamep = singlespacedtext1p
-- | Parse possibly empty text, including whitespace,
-- until a comment start (semicolon) or newline.
noncommenttextp :: TextParser m T.Text
noncommenttextp = takeWhileP Nothing (\c -> not $ isSameLineCommentStart c || isNewline c)
-- | Parse non-empty text, including whitespace,
-- until a comment start (semicolon) or newline.
noncommenttext1p :: TextParser m T.Text
noncommenttext1p = takeWhile1P Nothing (\c -> not $ isSameLineCommentStart c || isNewline c)
-- | Parse non-empty, single-spaced text starting and ending with non-whitespace,
-- until a double space or newline.
singlespacedtext1p :: TextParser m T.Text
singlespacedtext1p = singlespacedtextsatisfying1p (const True)
-- | Parse non-empty, single-spaced text starting and ending with non-whitespace,
-- until a comment start (semicolon), double space, or newline.
singlespacednoncommenttext1p :: TextParser m T.Text
singlespacednoncommenttext1p = singlespacedtextsatisfying1p (not . isSameLineCommentStart)
-- | Parse non-empty, single-spaced text starting and ending with non-whitespace,
-- where all characters satisfy the given predicate.
singlespacedtextsatisfying1p :: (Char -> Bool) -> TextParser m T.Text
singlespacedtextsatisfying1p f = do
firstPart <- partp
otherParts <- many $ try $ singlespacep *> partp
pure $! T.unwords $ firstPart : otherParts
where
partp = takeWhile1P Nothing (\c -> f c && not (isSpace c))
-- | Parse one non-newline whitespace character that is not followed by another one.
singlespacep :: TextParser m ()
singlespacep = spacenonewline *> notFollowedBy spacenonewline
--- *** amounts
-- | Parse whitespace then an amount, or return the special "missing" marker amount.
spaceandamountormissingp :: JournalParser m MixedAmount
spaceandamountormissingp =
option missingmixedamt $ try $ do
lift $ skipNonNewlineSpaces1
mixedAmount <$> amountp
-- | Parse a single-commodity amount, applying the default commodity if there is no commodity symbol;
-- optionally followed by, in any order:
-- a Ledger-style cost, Ledger-style valuation expression, and/or Ledger-style cost basis, which is one or more of
-- lot cost, lot date, and/or lot note (we loosely call this triple the lot's cost basis).
-- The cost basis makes it a lot rather than just an amount. Both cost basis info and valuation expression
-- are discarded for now.
-- The main amount's sign is significant; here are the possibilities and their interpretation.
-- Also imagine an optional VALUATIONEXPR added to any of these (omitted for clarity):
-- @
--
-- AMT -- acquiring an amount
-- AMT COST -- acquiring an amount at some cost
-- AMT COST COSTBASIS -- acquiring a lot at some cost, saving its cost basis
-- AMT COSTBASIS COST -- like the above
-- AMT COSTBASIS -- like the above with cost same as the cost basis
--
-- -AMT -- releasing an amount
-- -AMT SELLPRICE -- releasing an amount at some selling price
-- -AMT SELLPRICE COSTBASISSEL -- releasing a lot at some selling price, selecting it by its cost basis
-- -AMT COSTBASISSEL SELLPRICE -- like the above
-- -AMT COSTBASISSEL -- like the above with selling price same as the selected lot's cost basis amount
--
-- COST/SELLPRICE can be @ UNITAMT, @@ TOTALAMT, (@) UNITAMT, or (@@) TOTALAMT. The () are ignored.
-- COSTBASIS is one or more of {LOTCOST}, [LOTDATE], (LOTNOTE), in any order, with LOTCOST defaulting to COST.
-- COSTBASISSEL is one or more of {LOTCOST}, [LOTDATE], (LOTNOTE), in any order.
-- {LOTCOST} can be {UNITAMT}, {{TOTALAMT}}, {=UNITAMT}, or {{=TOTALAMT}}. The = is ignored.
-- VALUATIONEXPR can be ((VALUE AMOUNT)) or ((VALUE FUNCTION)).
--
-- @
-- Ledger amount syntax is really complex.
-- Rule of thumb: curly braces, parentheses, and/or square brackets
-- in an amount means a Ledger-style cost basis is involved.
--
-- To parse an amount's numeric quantity we need to know which character
-- represents a decimal mark. We find it in one of three ways:
--
-- 1. If a decimal mark has been set explicitly in the journal parse state,
-- we use that
--
-- 2. Or if the journal has a commodity declaration for the amount's commodity,
-- we get the decimal mark from that
--
-- 3. Otherwise we will parse any valid decimal mark appearing in the
-- number, as long as the number appears well formed.
-- (This means we handle files with any supported decimal mark without configuration,
-- but it also allows different decimal marks in different amounts,
-- which is a bit too loose. There's an open issue.)
--
amountp :: JournalParser m Amount
amountp = amountp' False
-- An amount with optional cost, valuation, and/or cost basis, as described above.
-- A flag indicates whether we are parsing a multiplier amount;
-- if not, a commodity-less amount will have the default commodity applied to it.
amountp' :: Bool -> JournalParser m Amount
amountp' mult =
-- dbg "amountp'" $
label "amount" $ do
let spaces = lift $ skipNonNewlineSpaces
amt <- simpleamountp mult <* spaces
(mcost, _valuationexpr, _mlotcost, _mlotdate, _mlotnote) <- runPermutation $
-- costp, valuationexprp, lotnotep all parse things beginning with parenthesis, try needed
(,,,,) <$> toPermutationWithDefault Nothing (Just <$> try (costp amt) <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> valuationexprp <* spaces) -- XXX no try needed here ?
<*> toPermutationWithDefault Nothing (Just <$> lotcostp <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces)
pure $ amt { aprice = mcost }
-- An amount with optional cost, but no cost basis.
amountnobasisp :: JournalParser m Amount
amountnobasisp =
-- dbg "amountnobasisp" $
label "amount" $ do
let spaces = lift $ skipNonNewlineSpaces
amt <- simpleamountp False
spaces
mprice <- optional $ costp amt <* spaces
pure $ amt { aprice = mprice }
-- An amount with no cost or cost basis.
-- A flag indicates whether we are parsing a multiplier amount;
-- if not, a commodity-less amount will have the default commodity applied to it.
simpleamountp :: Bool -> JournalParser m Amount
simpleamountp mult =
-- dbg "simpleamountp" $
do
sign <- lift signp
leftsymbolamountp sign <|> rightornosymbolamountp sign
where
-- An amount with commodity symbol on the left.
leftsymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount
leftsymbolamountp sign = label "amount" $ do
c <- lift commoditysymbolp
mdecmarkStyle <- getDecimalMarkStyle
mcommodityStyle <- getAmountStyle c
-- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461
let suggestedStyle = mdecmarkStyle <|> mcommodityStyle
commodityspaced <- lift skipNonNewlineSpaces'
sign2 <- lift $ signp
offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
offAfterNum <- getOffset
let numRegion = (offBeforeNum, offAfterNum)
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, aprice=Nothing}
-- An amount with commodity symbol on the right or no commodity symbol.
-- A no-symbol amount will have the default commodity applied to it
-- unless we are parsing a multiplier amount (*AMT).
rightornosymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp sign = label "amount" $ do
offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
offAfterNum <- getOffset
let numRegion = (offBeforeNum, offAfterNum)
mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipNonNewlineSpaces' <*> commoditysymbolp
case mSpaceAndCommodity of
-- right symbol amount
Just (commodityspaced, c) -> do
mdecmarkStyle <- getDecimalMarkStyle
mcommodityStyle <- getAmountStyle c
-- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461
let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent
let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing}
-- no symbol amount
Nothing -> do
-- look for a number style to use when parsing, based on
-- these things we've already parsed, in this order of preference:
mdecmarkStyle <- getDecimalMarkStyle -- a decimal-mark CSV rule
mcommodityStyle <- getAmountStyle "" -- a commodity directive for the no-symbol commodity
mdefaultStyle <- getDefaultAmountStyle -- a D default commodity directive
-- XXX no-symbol amounts in periodic transaction rules and auto posting rules ? #1461
let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle <|> mdefaultStyle
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent
-- if a default commodity has been set, apply it and its style to this amount
-- (unless it's a multiplier in an automated posting)
defcs <- getDefaultCommodityAndStyle
let (c,s) = case (mult, defcs) of
(False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) prec})
_ -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing}
-- For reducing code duplication. Doesn't parse anything. Has the type
-- of a parser only in order to throw parse errors (for convenience).
interpretNumber
:: (Int, Int) -- offsets
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
interpretNumber posRegion msuggestedStyle ambiguousNum mExp =
let rawNum = either (disambiguateNumber msuggestedStyle) id ambiguousNum
in case fromRawNumber rawNum mExp of
Left errMsg -> customFailure $
uncurry parseErrorAtRegion posRegion errMsg
Right (q,p,d,g) -> pure (q, Precision p, d, g)
-- | Try to parse a single-commodity amount from a string
parseamount :: String -> Either HledgerParseErrors Amount
parseamount s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s)
-- | Parse a single-commodity amount from a string, or get an error.
parseamount' :: String -> Amount
parseamount' s =
case parseamount s of
Right amt -> amt
Left err -> error' $ show err -- PARTIAL: XXX should throwError
-- | Like parseamount', but returns a MixedAmount.
parsemixedamount :: String -> Either HledgerParseErrors MixedAmount
parsemixedamount = fmap mixedAmount . parseamount
-- | Like parseamount', but returns a MixedAmount.
parsemixedamount' :: String -> MixedAmount
parsemixedamount' = mixedAmount . parseamount'
-- | Parse a minus or plus sign followed by zero or more spaces,
-- or nothing, returning a function that negates or does nothing.
signp :: Num a => TextParser m (a -> a)
signp = ((char '-' $> negate <|> char '+' $> id) <* skipNonNewlineSpaces) <|> pure id
commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp =
quotedcommoditysymbolp <|> simplecommoditysymbolp <?> "commodity symbol"
quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp =
between (char '"') (char '"') $ takeWhileP Nothing f
where f c = c /= ';' && c /= '\n' && c /= '\"'
simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
-- | Ledger-style cost notation:
-- @ UNITAMT, @@ TOTALAMT, (@) UNITAMT, or (@@) TOTALAMT. The () are ignored.
costp :: Amount -> JournalParser m AmountPrice
costp baseAmt =
-- dbg "costp" $
label "transaction price" $ do
-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs
parenthesised <- option False $ char '(' >> pure True
char '@'
totalPrice <- char '@' $> True <|> pure False
when parenthesised $ void $ char ')'
lift skipNonNewlineSpaces
priceAmount <- simpleamountp False -- <?> "unpriced amount (specifying a price)"
let amtsign' = signum $ aquantity baseAmt
amtsign = if amtsign' == 0 then 1 else amtsign'
pure $ if totalPrice
then TotalPrice priceAmount{aquantity=amtsign * aquantity priceAmount}
else UnitPrice priceAmount
-- | A valuation function or value can be written in double parentheses after an amount.
valuationexprp :: JournalParser m ()
valuationexprp =
-- dbg "valuationexprp" $
label "valuation expression" $ do
string "(("
_ <- T.strip . T.pack <$> (many $ noneOf [')','\n']) -- XXX other line endings ?
string "))"
return ()
balanceassertionp :: JournalParser m BalanceAssertion
balanceassertionp = do
sourcepos <- getSourcePos
char '='
istotal <- fmap isJust $ optional $ try $ char '='
isinclusive <- fmap isJust $ optional $ try $ char '*'
lift skipNonNewlineSpaces
-- this amount can have a cost, but not a cost basis.
-- balance assertions ignore it, but balance assignments will use it
a <- amountnobasisp <?> "amount (for a balance assertion or assignment)"
return BalanceAssertion
{ baamount = a
, batotal = istotal
, bainclusive = isinclusive
, baposition = sourcepos
}
-- Parse a Ledger-style lot cost,
-- {UNITCOST} or {{TOTALCOST}} or {=FIXEDUNITCOST} or {{=FIXEDTOTALCOST}},
-- and discard it.
lotcostp :: JournalParser m ()
lotcostp =
-- dbg "lotcostp" $
label "ledger-style lot cost" $ do
char '{'
doublebrace <- option False $ char '{' >> pure True
_fixed <- fmap isJust $ optional $ lift skipNonNewlineSpaces >> char '='
lift skipNonNewlineSpaces
_a <- simpleamountp False
lift skipNonNewlineSpaces
char '}'
when (doublebrace) $ void $ char '}'
-- Parse a Ledger-style [LOTDATE], and discard it.
lotdatep :: JournalParser m ()
lotdatep =
-- dbg "lotdatep" $
label "ledger-style lot date" $ do
char '['
lift skipNonNewlineSpaces
_d <- datep
lift skipNonNewlineSpaces
char ']'
return ()
-- Parse a Ledger-style (LOT NOTE), and discard it.
lotnotep :: JournalParser m ()
lotnotep =
-- dbg "lotnotep" $
label "ledger-style lot note" $ do
char '('
lift skipNonNewlineSpaces
_note <- stripEnd . T.pack <$> (many $ noneOf [')','\n']) -- XXX other line endings ?
char ')'
return ()
-- | Parse a string representation of a number for its value and display
-- attributes.
--
-- Some international number formats are accepted, eg either period or comma
-- may be used for the decimal mark, and the other of these may be used for
-- separating digit groups in the integer part. See
-- http://en.wikipedia.org/wiki/Decimal_separator for more examples.
--
-- This returns: the parsed numeric value, the precision (number of digits
-- seen following the decimal mark), the decimal mark character used if any,
-- and the digit group style if any.
--
numberp :: Maybe AmountStyle -> TextParser m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp suggestedStyle = label "number" $ do
-- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both
-- dbgparse 0 "numberp"
sign <- signp
rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp
mExp <- optional $ try $ exponentp
dbg7 "numberp suggestedStyle" suggestedStyle `seq` return ()
case dbg7 "numberp quantity,precision,mdecimalpoint,mgrps"
$ fromRawNumber rawNum mExp of
Left errMsg -> Fail.fail errMsg
Right (q, p, d, g) -> pure (sign q, p, d, g)
exponentp :: TextParser m Integer