packages feed

hledger-lib 1.14.1 → 1.52.1

raw patch · 94 files changed

Files

CHANGES.md view
@@ -1,84 +1,1605 @@-Internal/api/developer-ish changes in the hledger-lib (and hledger) packages.-For user-visible changes, see the hledger package changelog.--# 1.14.1 2019-03-20--- require easytest <0.3 to fix build issue--# 1.14 2019-03-01--- added:  -  transaction, [v]post*, balassert* constructors, for tests etc.  --- renamed:  -  porigin -> poriginal  --- refactored:  -  transaction balancing & balance assertion checking (#438)--# 1.13.1 (2019/02/02)--- stop depending on here to avoid haskell-src-meta/stackage blockage.--# 1.13 (2019/02/01)--- in Journal's jtxns field, forecasted txns are appended rather than prepended--- API changes:--  added:-  +setFullPrecision-  +setMinimalPrecision-  +expectParseStateOn-  +embedFileRelative-  +hereFileRelative--  changed:-  - amultiplier -> aismultiplier-  - Amount fields reordered for clearer debug output-  - tpreceding_comment_lines -> tprecedingcomment, reordered-  - Hledger.Data.TransactionModifier.transactionModifierToFunction -> modifyTransactions-  - Hledger.Read.Common.applyTransactionModifiers -> Hledger.Data.Journal.journalModifyTransactions--  - HelpTemplate -> CommandDoc---# 1.12 (2018/12/02)---   switch to megaparsec 7 (Alex Chen)-    We now track the stack of include files in Journal ourselves, since-    megaparsec dropped this feature.---   add 'ExceptT' layer to our parser monad again (Alex Chen)-    We previously had a parser type, 'type ErroringJournalParser = ExceptT-    String ...' for throwing parse errors without allowing further-    backtracking. This parser type was removed under the assumption that it-    would be possible to write our parser without this capability. However,-    after a hairy backtracking bug, we would now prefer to have the option to-    prevent backtracking.--    -   Define a 'FinalParseError' type specifically for the 'ExceptT' layer-    -   Any parse error can be raised as a "final" parse error-    -   Tracks the stack of include files for parser errors, anticipating the-        removal of the tracking of stacks of include files in megaparsec 7-        -   Although a stack of include files is also tracked in the 'StateT-            Journal' layer of the parser, it seems easier to guarantee correct-            error messages in the 'ExceptT FinalParserError' layer-        -   This does not make the 'StateT Journal' stack redundant because the-            'ExceptT FinalParseError' stack cannot be used to detect cycles of-            include files---   more support for location-aware parse errors when re-parsing (Alex Chen)---   make 'includedirectivep' an 'ErroringJournalParser' (Alex Chen)---   drop Ord instance breaking GHC 8.6 build (Peter Simons)---   flip the arguments of (divide\|multiply)\[Mixed\]Amount---   showTransaction: fix a case showing multiple missing amounts-    showTransaction could sometimes hide the last posting's amount even if-    one of the other posting amounts was already implcit, producing invalid+<!--+ _ _ _+| (_) |__+| | | '_ \+| | | |_) |+|_|_|_.__/++Breaking changes++Fixes++Improvements++-->++API/developer-ish changes in hledger-lib.+For user-visible changes, see the hledger package changelog.+++# 1.52.1 2026-04-28+ + +# 1.52 2026-03-20++Breaking changes++- A cost basis field (`acostbasis`) has been added to Amount (to store Ledger/Beancount-style cost basis annotations).++Fixes++- invertAmount: with zero amounts, do nothing instead of failing.+  Previously `invertAmount` would raise a "Ratio has zero denominator"+  exception if the amount's quantity was zero. Now it's a no-op in that case.+  [#2476]++[#2476]: https://github.com/simonmichael/hledger/issues/2476+++# 1.51.2 2026-01-08++- Allow base 4.22 / ghc 9.14.++# 1.51.1 2025-12-08++# 1.51 2025-12-05++Breaking changes++- Hledger.Data.Balancing: balanceTransaction -> balanceSingleTransaction+- Hledger.Utils.IO:+  - inputToHandle -> textToHandle; set utf8 not utf8_bom+  - readHandlePortably, readHandlePortably' -> hGetContentsPortably++Improvements++- Hledger.Utils.String:+  quoteForCommandLine now quotes some additional problem characters, and no longer quotes "7".+  [#2468]+++# 1.50.5 2025-12-08++# 1.50.4 2025-12-04++# 1.50.3 2025-11-18++# 1.50.2 2025-09-26++# 1.50.1 2025-09-16++# 1.50 2025-09-03++Breaking changes++- hledger now requires at least GHC 9.6 (and base 4.18), to ease maintenance.++Fixes++- Fix liftA2 build error with ghc <9.6 (broken since 1.43.1).++Improvements++- Account now stores balances, one per date period. This enables it do+  the hard work in MultiBalanceReport.+  Some new types are created to enable convenient operation of accounts:+  - `BalanceData` is a type which stores an exclusive balance, inclusive+    balance, and number of postings. This was previously directly stored+    in Account, but is now factored into a separate data type.+  - `PeriodData` is a container which stores date-indexed data, as well as+    pre-period data. In post cases, this represents the report spans,+    along with the historical data.+  - Account becomes polymorphic, allowing customisation of the type of+    data it stores. This will usually be `BalanceData`, but in+    `BudgetReport` it can use `These BalanceData BalanceData` to store+    both actuals and budgets in the same structure. The data structure+    changes to contain a `PeriodData`, allowing multiperiod accounts.+  (Stephen Morgan)+- Hledger.Read: make LatestDatesForFile showable+- Hledger.Read.Common: accountnamep and modifiedaccountnamep now take a flag to allow semicolons or not+- Hledger.Utils.IO: getFlag, warnIO, rename exitOnError -> handleExit, improve doc+- Hledger.Query: matchesCommodity handles all query types, not just cur:, and doesn't match by default+- Hledger.Data.Amount: move commodityStylesFromAmounts here, drop canonicalStyleFrom++# 1.43.2 2025-06-13++- Hledger.Utils.IO: rename exitOnError -> handleExit, improve doc+++# 1.43.1 2025-06-04++- Hledger.Query: queryIsAmtOrSym+++# 1.43 2025-06-01++- Support GHC 9.12.++- Fix doctest suite with ghc-8.10.7 (Thomas Miedema)++- Drop base-compat dependency (Thomas Miedema)++- Added NFData instances for Journal and subcomponents. (Stephen Morgan)++- Hledger.Data.Dates:+  - renamed parsedateM -> parsedate.+    M makes me think of monad and is awkward to type for this common helper.+    Maybe is expected for a parser.+  - parsedate now also accepts YYYYMMDD format, for convenience in ghci and for parseHledgerVersion.+    This is more permissive, now parsing many integers successfully; hopefully that won't be a problem.+    I noted but did not document two user-facing uses, which now also accept YYYYMMDD dates:+    --value's argument, and import's .latest files.++- Hledger.Data.Journal: journalCommoditiesUsed++- Hledger.Read: more ways to read the default journal:+  defaultJournalWith, defaultJournalSafely, defaultJournalSafelyWith++- Hledger.Utils.Debug:+  - Provide simpler, more consistent dbg* names.+  - A few cases of hledger/hledger-ui debug output which were always+    traced to stderr or always logged to a file, now consistently follow+    the policy on whether to trace or log.++- Hledger.Utils.IO:+  - exitOnError, a helper to clean up unicode errors and GHC error output generally.+  - make parseYN(A) total+  - export findPager, getHomeSafe+++# 1.42.2 2025-05-16++- Require extra >= 1.7.11, fixing the stack8.10.yaml build. (Thomas Miedema)+++# 1.42.1 2025-03-12+++# 1.42 2025-03-07++Improvements++- readJournal, when not given a file name, now always assumes it is "-" rather than "(string)".+  [#2328]+- Reader's rReadFn has changed type (for the new CSV text encoding feature);+  it now takes a `Handle` rather than a `Text`, allowing more flexibility.+- Make test/unittest.hs more buildable; remove PackageImports that was causing+  trouble for ghci.+  (Thomas Miedema, [#2337])+- Added: postingNegate+- Renamed: negatePostingAmount -> postingNegateMainAmount+- Refactor Hledger.Write.Html etc, reducing Lucid references.+  Clarify the HTML lib situation a bit, and clean up some imports.+  [#2244]+- Added: dropRawOpt, cliOptsDropArgs+- Hledger.Data.Amount: showAmountCost(B) now drops leading whitespace.+++# 1.41 2024-12-09++Breaking changes++- New/refactored modules (Hledger.Write.*) and types (Spreadsheet) to help+  abstract rendering in various output formats, eg HTML, FODS and beancount.+  Spreadsheet is an abstraction for tabular reports, in addition to the+  tabular package we already use; there may be some overlap.+  (Henning Thielemann)++- Rename displayDepth/prrDepth to displayIndent/prrIndent, and make them+  correspond to the number of indentation steps.+  (These are about indentation for rendering, not account depth.) [#2246]++Improvements++- Add Hledger.Data.Currency, currencySymbolToCode, currencyCodeToSymbol+- AmountFormat: add displayQuotes flag to control enclosing quotes+- InputOpts: add `posting_account_tags_` flag to control account tags on postings+- Support ghc 9.10 and base 4.20.+  Note, when built with ghc 9.10.1, hledger error messages are displayed with two extra trailing newlines.++Other API/doc changes++- Hledger.Utils.IO: cleanup; rgb' now takes Float arguments instead of Word8+- rename jinferredcommodities to jinferredcommoditystyles+- rename jcommodities to jdeclaredcommodities+- move/rename nullsourcepos+- document isBlockActive, matcherMatches+- posting*AsLines: fix some docs++++# 1.40 2024-09-09++Breaking changes++- Some constructors of the Interval type have been renamed for clarity.+- Hledger.Read.CsvUtils has moved to Hledger.Write.Csv. (Henning Thielemann)+- Tabular report rendering code has been added/reworked to allow new output formats and more reuse. (Henning Thielemann)++Improvements++- Added `journalDbg` debug output helper.++- Allow doclayout 0.5.++# 1.34 2024-06-01++Improvements++- InputOpts has a new `_defer` flag for internal use instead of overusing `strict_`+- journalCheckBalanceAssertions has moved to JournalChecks+++# 1.33.1 2024-05-02++- Updates for hledger 1.33.1+++# 1.33 2024-04-18++Breaking changes++Fixes++- Require process 1.6.19.0+ to avoid any vulnerabilities on Windows from+  [HSEC-2024-0003](https://haskell.github.io/security-advisories/advisory/HSEC-2024-0003.html).+  This has also required disabling this package's doctest test suite for the moment.++- A potential Glob/filemanip package conflict in Hledger.Utils.IO now prevented,+  avoiding build failures.+++Improvements++- hledger can now be built with GHC 9.8.+- hledger now requires safe >=0.3.20.+- fix spanUnion with open-ended dates; add spanExtend [#2177]+- move readFileStrictly from hledger to Hledger.Utils.IO+- rename/improve amountSetFullPrecisionUpTo; add mixedAmountSetFullPrecisionUpTo+- rename Amount's aprice -> acost+- rename AmountPrice, UnitPrice, TotalPrice -> AmountCost, UnitCost, TotalCost+- showAmountWithoutPrice             -> showAmountWithoutCost+- mixedAmountStripPrices             -> mixedAmountStripCosts+- showMixedAmountWithoutPrice        -> showMixedAmountWithoutCost+- showMixedAmountOneLineWithoutPrice -> showMixedAmountOneLineWithoutCost+- rename amountStripPrices           -> amountStripCost, etc+- rename AmountDisplayOpts -> AmountFormat; add a new flag for symbol display+- rename noColour          -> defaultFmt+- rename noCost            -> noCostFmt+- rename oneLine           -> oneLineFmt+- rename csvDisplay        -> machineFmt+- distinguish oneLineFmt and oneLineNoCostFmt; add fullZeroFmt+- matchedPostingsBeforeAndDuring: improve debug output++[#2177]: https://github.com/simonmichael/hledger/issues/2177+++# 1.32.3 2024-01-28++- Some API renames ended up in this release, including++  - amountStripPrices    -> amountStripCost+  - showAmountPrice      -> showAmountCostB+  - showAmountPriceDebug -> showAmountCostDebug++# 1.32.2 2023-12-31++Breaking changes++- In Hledger.Data.Amount, noPrice is renamed to noCost.++- AmountDisplayOpts has a new displayCommodity flag, controlling commodity symbol display.++Fixes++- Hledger.Utils.Debug.traceOrLog was logging when it should trace and vice versa.++Improvements++- Allow megaparsec 9.6++# 1.32.1 2023-12-07++- readFileStrictly is now provided by Hledger.Utils.IO++# 1.32 2023-12-01++Misc. changes++- styleAmounts is used in more places++- journalApplyCommodityStyles renamed to journalStyleAmounts++- "hard" and "all" rounding strategies have been added++- debug output improvements, eg for precision handling++- Table is now Showable, for debugging+++# 1.31 2023-09-03++Breaking changes++- There is a new consolidated API for styling amounts, and a+  convenient HasAmounts typeclass.  AmountStyle's fields have been+  renamed/reordered more mnemonically, and setting the precision is+  now optional.  (This simplifies the amount-stylingn code, but+  complicates the semantics a little. When reading, an unset precision+  generally behaves like NaturalPrecision.)++- (Possible breaking change):+  showMixedAmountLinesB, showAmountB, showAmountPrice now preserve+  commodityful zeroes when rendering. This is intended to affect print output,+  but it seems possible it might also affect balance and register reports,+  though our tests show no change in those.++- Renamed: journalAddInferredEquityPostings -> journalInferEquityFromCosts++Misc. changes++- Reports now do a final amount styling pass before rendering.++- groupByDateSpan code cleanup (Jay Neubrand)++- Allow aeson 2.2, megaparsec 9.5++# 1.30 2023-06-01++Breaking changes++- dropped: Hledger.Data.RawOptions.inRawOpts++Misc. changes++- added more terminal size, ANSI style/color helpers in Hledger.Utils.IO+  (and therefore Hledger and Hledger.Cli.Script):++      getTerminalHeightWidth+      getTerminalHeight+      getTerminalWidth+      bold'+      faint'+      black'+      red'+      green'+      yellow'+      blue'+      magenta'+      cyan'+      white'+      brightBlack'+      brightRed'+      brightGreen'+      brightYellow'+      brightBlue'+      brightMagenta'+      brightCyan'+      brightWhite'+      rgb'+      multicol+      expandGlob+      sortByModTime++# 1.29.2 2023-04-07++# 1.29.1 2023-03-16++- Hledger.Utils.String:++       added:+       strip1Char+       stripBy+       strip1By++- Allow building with GHC 9.6.1; add base-compat (#2011)++# 1.29 2023-03-11+- added terminal colour detection helpers:+  terminalIsLight+  terminalLightness+  terminalFgColor+  terminalBgColor++- Hledger.Data.RawOptions: add unsetboolopt++- add journalMarkRedundantCosts to help with balancing++- journalInferCosts -> journalInferCostsFromEquity++- `BalancingOpts{infer_transaction_prices_ -> infer_balancing_costs_}`++- Hledger.Data.Balancing: inferBalancingPrices -> transactionInferBalancingCosts++- Hledger.Data.Balancing: inferBalancingAmount -> transactionInferBalancingAmount++- Hledger.Data.Journal: transactionAddPricesFromEquity -> transactionInferCostsFromEquity++- Hledger.Data.Journal: journalAddPricesFromEquity -> journalInferCosts++- Hledger.Data.Dates: intervalStartBefore -> intervalBoundaryBefore++- Hledger.Read.Common: cleaned up some amount parsers; describe Ledger lot notation+  ```+  amountpwithmultiplier -> amountp'+  amountpnolotpricesp   -> amountnobasisp+  amountwithoutpricep   -> simpleamountp+  priceamountp          -> costp+  ```++- depend on text-ansi+++# 1.28 2022-12-01++- Hledger.Utils.Debug's debug logging helpers have been unified.+  The "trace or log" functions log to stderr by default, or to a file+  if ",logging" is appended to the program name (using withProgName). +  The debug log file is PROGNAME.log (changed from debug.log).++- Moved from Hledger.Utils.Debug to Hledger.Utils.Parse:+  traceParse+  traceParseAt+  dbgparse++- Moved from Hledger.Utils.Debug to Hledger.Utils.Print:+  pshow+  pshow'+  pprint+  pprint'+  colorOption+  useColorOnStdout+  useColorOnStderr+  outputFileOption+  hasOutputFile++- Rename Hledger.Utils.Print -> Hledger.Utils.IO, consolidate utils there.++- Hledger.Utils cleaned up.++- Hledger.Data.Amount: showMixedAmountOneLine now also shows costs.+  Note that different costs are kept separate in amount arithmetic.++- Hledger.Read.Common: rename/add amount parsing helpers.++  added:+   parseamount+   parseamount'+   parsemixedamount+   parsemixedamount'++  removed:+   amountp'+   mamountp'++- Hledger.Utils.Parse:+  export customErrorBundlePretty, +  for pretty-printing hledger parse errors.++- Support megaparsec 9.3. (Felix Yan)++- Support GHC 9.4.++- Update cabal files to match hpack 0.35/stack 2.9+++# 1.27 2022-09-01++Breaking changes++- Support for GHC 8.6 and 8.8 has been dropped.+  hledger now requires GHC 8.10 or newer.++- Hledger.Data.Amount: `amount` has been dropped; use `nullamt` instead.++- journal*AccountQuery functions have been dropped; use a type: query instead.+  cbcsubreportquery no longer takes Journal as an argument.+  (#1921)++Misc. changes++- Hledger.Utils.Debug now re-exports Debug.Breakpoint from the+  breakpoint library, so that breakpoint's helpers can be used easily+  during development.++- Hledger.Utils.Debug:+  dlog has been replaced by more reliable functions for debug-logging+  to a file (useful for debugging TUI apps like hledger-ui):++  dlogTrace+  dlogTraceAt+  dlogAt+  dlog0+  dlog1+  dlog2+  dlog3+  dlog4+  dlog5+  dlog6+  dlog7+  dlog8+  dlog9++- Hledger.Utils.Debug: pprint' and pshow' have been added,+  forcing monochrome output.++- Hledger.Utils.String: add quoteForCommandLine++- Hledger.Data.Errors: export makeBalanceAssertionErrorExcerpt++- Hledger.Utils.Parse: export HledgerParseErrors++- Debug logging from journalFilePath and the include directive will+  now show "(unknown)" instead of an empty string.++# 1.26.1 2022-07-11++- require safe 0.3.19+ to avoid deprecation warning++# 1.26 2022-06-04++Breaking changes++- readJournal, readJournalFile, readJournalFiles now return+  `ExceptT String IO a` instead of `IO (Either String a)`.+  Internally, this increases composability and avoids some ugly case handling.+  It means that these must now be evaluated with `runExceptT`.+  That can be imported from `Control.Monad.Except` in the `mtl` package,+  but `Hledger.Read` also re-exports it for convenience.++  New variants readJournal', readJournalFiles', readJournalFile' are+  also provided; these are like the old functions but more convenient,+  assuming default input options and needing one less argument.+  (Stephen Morgan)++- parseAndFinaliseJournal' (a variant of parseAndFinaliseJournal) has been removed. +  In the unlikely event you needed it in your code, you can replace:+  ```haskell+  parseAndFinaliseJournal' parser iopts fp t+  ```+  with:+  ```haskell+  initialiseAndParseJournal parser iopts fp t+  >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+  >>= journalFinalise iopts fp t+  ```++- Some parsers have been generalised from JournalParser to TextParser.+  (Stephen Morgan)++Misc. changes++- Allow doclayout 0.4.++- Our doctests now run with GHC 9.2+ only, to avoid doctest issues.++- Hledger.Data.JournalChecks: some Journal checks have been moved and renamed:+  journalCheckAccounts,+  journalCheckCommodities,+  journalCheckPayees+  +- Hledger.Data.Errors: new error formatting helpers+  makeTransactionErrorExcerpt,+  makePostingErrorExcerpt,+  transactionFindPostingIndex++- HledgerParseErrors is a new type alias for our parse errors.+  CustomErr has been renamed to HledgerParseErrorData.++- Hledger.Query: added+  matchesQuery,+  queryIsCode,+  queryIsTransactionRelated++- Improve ergonomics of SmartDate constructors. +  (Stephen Morgan)++- Hledger.Utils: Add a helper function numDigitsInt to get the number+  of digits in an integer, which has a surprising number of ways to+  get it wrong.+  ([#1813](https://github.com/simonmichael/hledger/issues/1813) (Stephen Morgan)++# 1.25 2022-03-04++- hledger-lib now builds with GHC 9.2 and latest deps. +  ([#1774](https://github.com/simonmichael/hledger/issues/1774)++- Journal has a new jaccounttypes map.+  The journalAccountType lookup function makes it easy to check an account's type.+  The journalTags and journalInheritedTags functions look up an account's tags.+  Functions like journalFilterPostings and journalFilterTransactions,+  and new matching functions matchesAccountExtra, matchesPostingExtra+  and matchesTransactionExtra, use these to allow more powerful matching+  that is aware of account types and tags.++- Journal has a new jdeclaredaccounttags field+  for easy lookup of account tags.+  Query.matchesTaggedAccount is a tag-aware version of matchesAccount.++- Some account name functions have moved from Hledger.Data.Posting+  to Hledger.Data.AccountName:+  accountNamePostingType, accountNameWithPostingType, accountNameWithoutPostingType,+  joinAccountNames, concatAccountNames, accountNameApplyAliases, accountNameApplyAliasesMemo.++- Renamed: CommodityLayout to Layout.++# 1.24.1 2021-12-10++Improvements++- Added: filterQueryOrNotQuery.++# 1.24 2021-12-01++Improvements++- The Semigroup instance of PeriodicReportRow and PeriodicReport now+  preserves the first prrName, rather than the second.+  (Stephen Morgan)++- PeriodicReport and PeriodicReportRow now have Bifunctor instances.+  (Stephen Morgan)++- Move posting rendering functions into Hledger.Data.Posting.+  This produces slightly different output for showPosting, in particular+  it no longer displays the transaction date. However, this has been+  marked as ‘for debugging only’ for a while.+  (Stephen Morgan)++- Drop postingDateOrDate2, transactionDateOrDate2; rename+  whichDateFromOpts to whichDate. (#1731)++- Added new helper functions journalValueAndFilterPostings(With) to make+  valuation and filtration less error prone.+  (Stephen Morgan)++- Avoid deprecation warnings with safe 0.3.18+. +  (Stephen Morgan)++- Drop base-compat-batteries dependency. +  (Stephen Morgan)++- Allow megaparsec 9.2.++# 1.23 2021-09-21++- Require base >=4.11, prevent red squares on Hackage's build matrix.++Much code cleanup and reorganisation, such as:++- Introduce lenses for many types. (Stephen Morgan)++- The now-obsolete normaliseMixedAmount and+  normaliseMixedAmountSquashPricesForDisplay functions have been+  dropped. (Stephen Morgan)++- GenericSourcePos has been dropped, replaced by either SourcePos or+  (SourcePos, SourcePos), simplifying module structure. (Stephen Morgan)++- Functions related to balancing (both transaction balancing and journal balancing)+  have been moved to Hledger.Data.Balancing, reducing module size and reducing the risk+  of import cycles.+  (Stephen Morgan)++- `ReportOptions{infer_value_}` has been renamed to `infer_prices_`,+  for more consistency with the corresponding CLI flag.+  And `BalancingOpts{infer_prices_}` is now `infer_transaction_prices_`.++- JournalParser and ErroringJournalParser have moved to+  Hledger.Data.Journal. (Stephen Morgan)++- MixedAmounts now have a more predictable Ord instance / sort order.+  They are compared in each commodity in turn, with+  alphabetically-first commodity symbols being most significant.+  Missing commodities are assumed to be zero. +  As a consequence, all the ways of representing zero with a MixedAmount ([],+  [A 0], [A 0, B 0, ...]) are now Eq-ual (==), whereas before they were+  not. We have not been able to find anything broken by this change.+  ([#1563](https://github.com/simonmichael/hledger/issues/1563), +  [#1564](https://github.com/simonmichael/hledger/issues/1564), +  Stephen Morgan)++- HUnit's testCase and testGroup are now used directly instead of+  having test and tests aliases. (Stephen Morgan)++- The codebase now passes many hlint checks++- Dropped modules:+  Hledger.Utils.Color,+  Hledger.Data.Commodity,+  Hledger.Utils.UTF8IOCompat,+  Hledger.Utils.Tree module.+  (Stephen Morgan)++- Drop the deprecated old-time lib.+  A small number type signatures have changed:+  journalSetLastReadTime, maybeFileModificationTime and Journal+  now use POSIXTime instead of ClockTime.+  Hledger.Cli.Utils.utcTimeToClockTime has been removed, +  as it is now equivalent to utcTimeToPOSIXSeconds from Data.Time.Clock.POSIX.+  To get the current system time, you should now use getPOSIXTime +  from Data.Time.Clock.POSIX instead of getClockTime.+  ([#1650](https://github.com/simonmichael/hledger/issues/1650), Stephen Morgan)++- modifyTransactions now takes a Map of commodity styles, and will style amounts according to that argument. journalAddForecast and journalTransform now return an Either String Journal. (Stephen Morgan)+  This improves efficiency, as we no longer have to restyle all amounts in+  the journal after generating auto postings or periodic transactions.+  Changing the return type of journalAddForecast and journalTransform+  reduces partiality.+  To get the previous behaviour for modifyTransaction, use modifyTransaction mempty.++- Refactor journalFinalise to clarify flow. (Stephen Morgan)+  The only semantic difference is that we now apply+  journalApplyCommodityStyles before running journalCheckAccountsDeclared+  and journalCheckCommoditiesDeclared.++- Introduce lenses for ReportOpts and ReportSpec. (Stephen Morgan)++- Rename the fields of ReportSpec. (Stephen Morgan)++  This is done to be more consistent with future field naming conventions,+  and to make automatic generation of lenses simpler. See discussion in+  [#1545](https://github.com/simonmichael/hledger/issues/1545).++      rsOpts      -> _rsReportOpts+      rsToday     -> _rsDay+      rsQuery     -> _rsQuery+      rsQueryOpts -> _rsQueryOpts++- Remove aismultiplier from Amount. (Stephen Morgan)++  In Amount, aismultiplier is a boolean flag that will always be False,+  except for in TMPostingRules, where it indicates whether the posting+  rule is a multiplier. It is therefore unnecessary in the vast majority+  of cases. This posting pulls this flag out of Amount and puts it into+  TMPostingRule, so it is only kept around when necessary.++  This changes the parsing of journals somewhat. Previously you could+  include an * before an amount anywhere in a Journal, and it would+  happily parse and set the aismultiplier flag true. This will now fail+  with a parse error: * is now only acceptable before an amount within an+  auto posting rule.++  Any usage of the library in which the aismultiplier field is read or set+  should be removed. If you truly need its functionality, you should+  switch to using TMPostingRule.++  This changes the JSON output of Amount, as it will no longer include+  aismultiplier.++- For accountTransactionsReport, generate the overall reportq from the ReportSpec, rather than being supplied as a separate option. (Stephen Morgan)++  This is the same approach used by the other reports, e.g. EntryReport,+  PostingReport, MultiBalanceReport. This reduces code duplication, as+  previously the reportq had to be separately tweaked in each of 5+  different places.++  If you call accountTransactionreport, there is no need to separately+  derive the report query.++- Remove unused TransactionReport. Move the useful utility functions to AccountTransactionsReport. (Stephen Morgan)++  If you use transactionsReport, you should either use entryReport if you+  don't require a running total, or using accountTransactionsReport with+  thisacctq as Any or None (depending on what you want included in the+  running total).++- Some balance report types have been renamed for clarity and to sync with docs:++      ReportType -> BalanceCalculation+       ChangeReport -> CalcChange+       BudgetReport -> CalcBudget+       ValueChangeReport -> CalcValueChange++      BalanceType -> BalanceAccumulation+       PeriodChange -> PerPeriod+       CumulativeChange -> Cumulative+       HistoricalBalance -> Historical++      ReportOpts:+       reporttype_ -> balancecalc_+       balancetype_ -> balanceaccum_++      CompoundBalanceCommandSpec:+       cbctype -> cbcaccum++      Hledger.Reports.ReportOptions:+       balanceTypeOverride -> balanceAccumulationOverride++# 1.22.2 2021-08-07++- forecast_ has moved from ReportOpts to InputOpts. (Stephen Morgan)++- Generate forecast transactions at journal finalisation, rather than as a postprocessing step.+  This allows us to have a uniform procedure for balancing transactions,+  whether they are normal transactions or forecast transactions, including+  dealing with balance assignments, balance assertions, and auto postings.+  ([#1638](https://github.com/simonmichael/hledger/issues/1638), Stephen Morgan)++# 1.22.1 2021-08-02++- Allow megaparsec 9.1++- journalEndDate's behaviour has been clarified, journalLastDay has+  been added.++- transactionCheckBalanced is now exported. (#1596)++# 1.22 2021-07-03++- GHC 9.0 is now officially supported, and GHC 8.0, 8.2, 8.4 are not;+  building hledger now requires GHC 8.6 or greater.++- Added now-required lower bound on containers. (#1514)++- Added useColor, colorOption helpers usable in pure code, eg for debug output.++- Added a Show instance for AmountDisplayOpts and WideBuilder, for debug logging.++Many internal refactorings/improvements/optimisations by Stephen Morgan,+including:++- Don't infer a txn price with same-sign amounts. (#1551)++- Clean up valuation functions, and make clear which to use where. (#1560)++- Replace journalSelectingAmountFromOpts with journalApplyValuationFromOpts.+  This also has the effect of allowing valuation in more reports, for+  example the transactionReport.++- Refactor to eliminate use of printf.++- Remove unused String, Text utility functions.++- Replace concat(Top|Bottom)Padded with textConcat(Top|Bottom)Padded.++- Export Text.Tabular from Text.Tabular.AsciiWide, clean up import lists.++- When matching an account query against a posting, don't try to match+  against the same posting twice, in cases when poriginal is Nothing.++- Create mixedAmountApplyValuationAfterSumFromOptsWith for doing any+  valuation needed after summing amounts.++- Create journalApplyValuationFromOpts. This does costing and+  valuation on a journal, and is meant to replace most direct calls of+  costing and valuation. The exception is for reports which require+  amounts to be summed before valuation is applied, for example a+  historical balance report with --value=end.++- Remove unused (amount|mixedAmount|posting|transaction)ApplyCostValuation functions.++- Remove unnecessary normalisedMixedAmount.++- Remove `showAmounts*B` functions, replacing them entirely with+  `showMixedAmount*B` functions.++- Pull "show-costs" option used by the Close command up into ReporOpts.++- Add more efficient toEncoding for custom ToJSON declarations.++- Fix ledgerDateSpan, so that it considers both transaction and+  posting dates. (#772)++- Move reportPeriodName to Hledger.Reports.ReportOptions, use it for+  HTML and CSV output for compound balance reports.++- Simplify the JSON representation of AmountPrecision. It now uses the+  same JSON representation as Maybe Word8. This means that the JSON+  serialisation is now broadly compatible with that used before the+  commit f6fa76bba7530af3be825445a1097ae42498b1cd, differing only in+  how it handles numbers outside Word8 and that it can now produce+  null for NaturalPrecision.++- A number of AccountName and Journal functions which are supposed to+  produce unique sorted results now use Sets internally to be slightly+  more efficient. There is also a new function journalCommodities.++- More efficiently check whether Amounts are or appear to be zero.+  Comparing two Quantity (either with == or compare) does a lot of+  normalisation (calling roundMax) which is unnecessary if we're+  comparing to zero. Do things more directly to save work.+  For `reg -f examples/10000x10000x10.journal`, this results in++  - A 12% reduction in heap allocations, from 70GB to 62GB+  - A 14% reduction in (profiled) time, from 79s to 70s++  Results for bal -f examples/10000x10000x10.journal are of the same+  order of magnitude.++- In sorting account names, perform lookups on HashSets and HashMaps,+  rather than lists. This is probably not an enormous performance sink+  in real situations, but it takes a huge amount of time and memory in+  our benchmarks (specifically 10000x10000x10.journal). For +  `bal -f examples/10000x10000x10.journal`, this results in++  - A 23% reduction in heap allocation, from 27GiB to 21GiB+  - A 33% reduction in (profiled) time running, from 26.5s to 17.9s++- Minor refactor, using foldMap instead of asum . map . toList.++- Do not call showAmount twice for every posting. For print -f+  examples/10000x10000x10.journal, this results in a 7.7% reduction in+  heap allocations, from 7.6GB to 7.1GB.++- Some efficiency improvements in register reports.+  Use renderRow interface for Register report.++  For `reg -f examples/10000x10000x10.journal`, this results in:++  - Heap allocations decreasing by 55%, from 68.6GB to 31.2GB+  - Resident memory decreasing by 75%, from 254GB to 65GB+  - Total (profiled) time decreasing by 55%, from 37s to 20s++- Split showMixedAmountB into showMixedAmountB and showAmountsB, the+  former being a simple wrapper around the latter. This removes the+  need for the showNormalised option, as showMixedAmountB will always+  showNormalised and showAmountsB will never do so.++- Change internal representation of MixedAmount to use a strict Map+  instead of a list of Amounts. No longer export Mixed constructor, to+  keep API clean. (If you really need it, you can import it directly+  from Hledger.Data.Types). We also ensure the JSON representation of+  MixedAmount doesn't change: it is stored as a normalised list of+  Amounts.+  +  This commit improves performance. Here are some indicative results:++      hledger reg -f examples/10000x1000x10.journal+      - Maximum residency decreases from 65MB to 60MB (8% decrease)+      - Total memory in use decreases from 178MiB to 157MiB (12% decrease)++      hledger reg -f examples/10000x10000x10.journal+      - Maximum residency decreases from 69MB to 60MB (13% decrease)+      - Total memory in use decreases from 198MiB to 153MiB (23% decrease)++      hledger bal -f examples/10000x1000x10.journal+      - Total heap usage decreases from 6.4GB to 6.0GB (6% decrease)+      - Total memory in use decreases from 178MiB to 153MiB (14% decrease)++      hledger bal -f examples/10000x10000x10.journal+      - Total heap usage decreases from 7.3GB to 6.9GB (5% decrease)+      - Total memory in use decreases from 196MiB to 185MiB (5% decrease)++      hledger bal -M -f examples/10000x1000x10.journal+      - Total heap usage decreases from 16.8GB to 10.6GB (47% decrease)+      - Total time decreases from 14.3s to 12.0s (16% decrease)++      hledger bal -M -f examples/10000x10000x10.journal+      - Total heap usage decreases from 108GB to 48GB (56% decrease)+      - Total time decreases from 62s to 41s (33% decrease)++  If you never directly use the constructor Mixed or pattern match against+  it then you don't need to make any changes. If you do, then do the+  following:++  - If you really care about the individual Amounts and never normalise+    your MixedAmount (for example, just storing `Mixed amts` and then+    extracting `amts` as a pattern match, then use should switch to using+    [Amount]. This should just involve removing the `Mixed` constructor.+  - If you ever call `mixed`, `normaliseMixedAmount`, or do any sort of+    amount arithmetic (+), (-), then you should replace the constructor+    `Mixed` with the function `mixed`. To extract the list of Amounts, use+    the function `amounts`.+  - Any remaining calls to `normaliseMixedAmount` can be removed, as that+    is now the identity function.++- Create a new API for MixedAmount arithmetic. This should supplant+  the old interface, which relied on the Num typeclass. MixedAmount+  did not have a very good Num instance. The only functions which were+  defined were fromInteger, (+), and negate. Furthermore, it was not+  law-abiding, as 0 + a /= a in general. Replacements for used+  functions are:++      0 -> nullmixedamt / mempty+      (+) -> maPlus / (<>)+      (-) -> maMinus+      negate -> maNegate+      sum -> maSum+      sumStrict -> maSum++  Also creates some new constructors for MixedAmount:++      mixedAmount :: Amount -> MixedAmount+      maAddAmount :: MixedAmount -> Amount -> MixedAmount+      maAddAmounts :: MixedAmount -> [Amount] -> MixedAmount++  Add Semigroup and Monoid instances for MixedAmount.+  Ideally we would remove the Num instance entirely.++  The only change needed have nullmixedamt/mempty substitute for 0+  without problems was to not squash prices in+  mixedAmount(Looks|Is)Zero. This is correct behaviour in any case.+++# 1.21 2021-03-10++- Building Hledger.Data.Journal no longer fails if the monad-extras+  package is installed.++- Many parts of the hledger-lib and hledger APIs have become more+  Text-ified, expecting or returning Text instead of String, reducing+  hledger's time and resident memory requirements by roughly 10%.+  Some functions now use WideBuilder (a text "builder" which keeps track+  of width), to concatenate text more efficiently. There are some+  helpers for converting to and from WideBuilder (wbUnpack, wbToText..)+  showAmountB/showMixedAmountB are new amount-displaying functions+  taking an AmountDisplayOpts. These will probably replace the old+  show(Mixed)Amount* functions. (#1427, Stephen Morgan)++- AtThen valuation is now implemented for all report types.+  amountApplyValuation now takes the posting date as an argument.+  (transaction/posting)ApplyValuation's valuation type and+  transaction/posting arguments have been reordered like+  amountApplyValuation's. (Stephen Morgan)++- Amount, AmountPrice, AmountStyle, DigitGroupStyle fields are now+  strict. (Stephen Morgan)++- Amount prices are now stored with their sign, so negative prices can+  be represented. (They seem to have always worked, but now the+  internal representation is more accurate.) (Stephen Morgan)+ +- normaliseMixedAmount now combines Amounts with TotalPrices in the+  same commodity. (Stephen Morgan)++- normaliseMixedAmount now uses a strict Map for combining amounts+  internally, closing a big space leak. (Stephen Morgan)++- (multiply|divide)(Mixed)?Amount now also multiply or divide the+  TotalPrice if it is present, and the old+  (multiply|divide)(Mixed)?AmountAndPrice functions are removed. (Stephen Morgan)++- (amount|mixedAmount)(Looks|Is)Zero functions now check whether both+  the quantity and the cost are zero. This is usually what you want,+  but if you do only want to check whether the quantity is zero, you+  can run mixedAmountStripPrices (or similar) before this. (Stephen Morgan)++- commodityStylesFromAmounts now consumes the list immediately,+  reducing the maximum heap size per thread from ~850K to ~430K in a+  real-world register report. (Stephen Morgan)++- *ApplyValuation functions take two less arguments, and+  *ApplyCostValuation functions have been added, performing both+  costing and valuation. (Stephen Morgan)++- traceAtWith now has a level argument and works properly.++- API changes include:+  ```+  Hledger.Data.Amount:+   setAmountPrecision -> amountSetPrecision+   setFullPrecision -> amountSetFullPrecision+   setMixedAmountPrecision -> mixedAmountSetPrecision+   showMixed -> showMixedAmountB+   showMixedLines -> showMixedAmountLinesB+  -mixedAmountSetFullPrecision++  Hledger.Data.Journal:+   mapJournalTransactions -> journalMapTransactions+   mapJournalPostings -> journalMapPostings+  -mapTransactionPostings+  +journalPayeesUsed+  +journalPayeesDeclaredOrUsed++  Hledger.Data.Transaction:+  +transactionFile+  +transactionMapPostings++  Hledger.Data.Valuation:+  -valuationTypeIsCost+  -valuationTypeIsDefaultValue+  -ValuationType's AtDefault constructor++  Hledger.Query:+  +matchesDescription+  +matchesPayeeWIP++  Hledger.Utils.Text:+  +textConcatBottomPadded+  +wbToText+  +wbUnpack++  Text.Tabular.AsciiWide:+   alignCell -> textCell+  ```+# 1.20.4 2021-01-29++- See hledger.++# 1.20.3 2021-01-14++- See hledger.++# 1.20.2 2020-12-28++- Fix the info manuals' node structure.++- Drop unused parsec dependency.++# 1.20.1 2020-12-15++- renamed: updateReportSpecFromOpts -> updateReportSpec[With]++# 1.20 2020-12-05++- added: journalApplyAliases, transactionApplyAliases, postingApplyAliases++- a new more robust price lookup implementation, fgl library dropped (#1402)++- Reverted a stripAnsi change in 1.19.1 that caused a 3x slowdown of amount rendering +  in terminal reports. (#1350)++- Amount and table rendering has been improved, so that stripAnsi is no longer needed.+  This speeds up amount rendering in the terminal, speeding up some reports by 10% or more since 1.19.+  (Stephen Morgan)++- global commodity display styles can now be set in InputOpts or Journal,+  overriding all others (declared or inferred). This is used by the import+  command and probably command-line options in future.++- Journal keeps a new piece of parsing state, a decimal mark character,+  which can optionally be set to force the number format expected by all+  amount parsers.++- Remove Empty Query constructor, which does nothing and has done so for a very long time. (Stephen Morgan)++- In ReportOpts, store query terms term-by-term in a list in querystring_. (Stephen Morgan)+  This helps deal with tricky quoting issues, as we no longer have to make+  sure everything is quoted properly before merging it into a string.++- Implement concat(Top|Bottom)Padded in terms of renderRow, allowing them to be width aware. (Stephen Morgan)++- Expand Tabular.AsciiWide to allow multiline, custom-width,+  vertically/horizontally-aligned cells, and optional table borders.+  (Stephen Morgan)++- Introduce showMixed*Unnormalised, eliminate most direct calls of strWidth. (Stephen Morgan)++- showMixedAmountElided now makes better use of space, showing as many+  Amounts possible as long as they and the elision string fit within+  32 characters. (Stephen Morgan)++- Add Functor instance for CompoundPeriodicReport. (Stephen Morgan)++- Generalise CBCSubreportSpec to allow more subreport control. (Stephen Morgan)++- Export some MultiBalanceReport helper functions. (Stephen Morgan)++- Make Default instances clearer, remove Default instance for Bool. (Stephen Morgan)++- Many ReportOpts-related changes, such as the addition of ReportSpec, aimed+  at preventing runtime errors (from parsing: regexps, dates, format strings;+  from not having today's date set; etc.)+  ReportSpec holds a ReportOpts, the day of the report, and the Query generated from these.++- StringFormat now takes an optional overline width, which is+  currently only used by defaultBalanceLineFormat. (Stephen Morgan)++- quoteIfNeeded should not escape the backslashes in unicode code points. (Stephen Morgan)++- Export OrdPlus and constructors. (Stephen Morgan)++- Debug output now uses pretty-simple instead pretty-show.+  This hopefully gives overall nicer debug output (eg in colour), +  including for values which don't have Read-able Show output.+  This means that we can start removing custom Show instances +  that were a workaround for pretty-show. Eg account names+  in debug output no longer show their colons as underscores.++  Here's some old pretty-show output:++   CsvRules+     { rdirectives = [ ( "skip" , "1" ) ]+     , rcsvfieldindexes = [ ( "date" , 1 ) , ( "amount" , 2 ) ]+     , rassignments = [ ( "amount" , "%2" ) , ( "date" , "%1" ) ]+     , rconditionalblocks = []+     }++  And the new pretty-simple output:++   CsvRules+     { rdirectives=+       [ ( "skip", "1" ) ]+     , rcsvfieldindexes=+       [ ( "date", 1 ), ( "amount", 2 ) ]+     , rassignments=+       [ ( "amount", "%2" ), ( "date", "%1" ) ]+     , rconditionalblocks= []+     }++  We require pretty-simple 4.0.0.0 to get this compact output.+  It's a little less compact than pretty-show, but not too bad.+  Non-compact pretty-simple output would be:++   CsvRules+       { rdirectives=+           [+               ( "skip"+               , "1B"+               )+           ]+       , rcsvfieldindexes=+           [+               ( "date"+               , 1+               )+           ,+               ( "amount"+               , 2+               )+           ]+       , rassignments=+           [+               ( "amount"+               , "%2"+               )+           ,+               ( "date"+               , "%1"+               )+           ]+       , rconditionalblocks=[]+       }+++# 1.19.1 2020-09-07++- Allow megaparsec 9++- stripAnsi: correctly strip ansi sequences with no+  numbers/semicolons. (Stephen Morgan)++- Added case-insensitive accountNameToAccountRegexCI,+  accountNameToAccountOnlyRegexCI, made the default account type+  queries case insensitive again. (#1341)++# 1.19 2020-09-01++- Added a missing lower bound for aeson, making cabal installs more+  reliable. (#1268)++- The Regex type alias has been replaced by the Regexp ADT, which+  contains both the compiled regular expression (so is guaranteed to+  be usable at runtime) and the original string (so can be serialised,+  printed, compared, etc.) A Regexp also knows whether is it case+  sensitive or case insensitive. The Hledger.Utils.Regex API has+  changed. (#1312, #1330).++- Typeable and Data instances are no longer derived for hledger's+  data types; they were redundant/no longer needed.++- NFData instances are no longer derived for hledger's data types.+  This speeds up a full build by roughly 7%. But it means we can't+  deep-evaluate hledger values, or time hledger code with Criterion.+  https://github.com/simonmichael/hledger/pull/1330#issuecomment-684075129+  has some ideas on this.++- Query no longer has a custom Show instance++- Hledger.Utils.String: quoteIfNeeded now actually escapes quotes in+  strings. escapeQuotes was dropped. (Stephen Morgan)++- Hledger.Utils.Tree: dropped some old utilities++- Some fromIntegral calls have been replaced with safer code, removing+  some potential for integer wrapping bugs (#1325, #1326)++- Parsing numbers with more than 255 decimal places now gives an error+  instead of silently misparsing (#1326)++- Digit groups are now limited to at most 255 digits each. (#1326)++- Exponents are parsed as Integer rather than Int.+  This means exponents greater than 9223372036854775807 or less than+  -9223372036854775808 are now parsed correctly, in theory. (In+  practice, very large exponents will cause hledger to eat all your+  memory, so avoid them for now.) (#1326)++- AmountStyle's asprecision is now a sum type with Word8, instead of+  an Int with magic values.++- DigitGroupStyle uses Word8 instead of Int.++- Partial helper function parsedate has been dropped, use fromGregorian instead.++- Partial helper function mkdatespan has been dropped.++- Helper function transaction now takes a Day instead of a date string. (Stephen Morgan)++- Old CPP directives made redundant by version bounds have been+  removed. (Stephen Morgan)++- Smart dates are now represented by the SmartDate type, and are+  always well formed. (Stephen Morgan)++- accountTransactionsReport (used for hledger aregister and+  hledger-ui/hledger-web registers) now filters transactions more+  thoroughly, so eg transactions dated outside the report period will+  not be shown. Previously the transaction would be shown if it had+  any posting dated inside the report period. Possibly some other+  filter criteria now get applied that didn't before. I think on+  balance this will give slightly preferable results.++- The old BalanceReport code has been dropped at last, replaced by+  MultiBalanceReport so that all balance reports now use the same+  code. (Stephen Morgan, #1256).++  - The large multiBalanceReport function has been split up and refactored+    extensively.+  - Tabular data formerly represented as [[MixedAmount]] is now HashMap+    AccountName (Map DateSpan Account). Reports with many columns are now faster.+  - Calculating starting balances no longer calls the whole balanceReport,+    just the first few functions.+  - displayedAccounts is completely rewritten. Perhaps one subtle thing to+    note is that in tree mode it no longer excludes nodes with zero inclusive+    balance unless they also have zero exclusive balance.+  - Simon's note: "I'll mark the passing of the old multiBalanceReport, into+    which I poured many an hour :). It is in a way the heart (brain ?) of+    hledger - the key feature of ledgerlikes (balance report) and a key+    improvement introduced by hledger (tabular multiperiod balance reports)+    ...+    Thanks @Xitian9, great work."++# 1.18.1 2020-06-21++- fix some doc typos (Martin Michlmayr)++# 1.18 2020-06-07++- added: getHledgerCliOpts', takes an explicit argument list++- added: toJsonText++- changed: isNegativeMixedAmount now gives an answer for+  multi-commodity amounts which are all negative++- changed: multiBalanceReport now gets the query from ReportOpts (Dmitry Astapov)++- renamed:+  isZeroAmount                -> amountLooksZero+  isReallyZeroAmount          -> amountIsZero+  isZeroMixedAmount           -> mixedAmountLooksZero+  isReallyZeroMixedAmount     -> mixedAmountIsZero+  isReallyZeroMixedAmountCost dropped++- renamed: finaliseJournal -> journalFinalise++- renamed: fixedlotpricep -> lotpricep, now also parses non-fixed lot prices++- dropped: transactionPostingBalances++- dropped: outputflags no longer exported by Hledger.Cli.CliOptions++- fixed: documentation for journalExpenseAccountQuery (Pavan Rikhi)++# 1.17.1 2020-03-19++- require newer Decimal, math-functions libs to ensure consistent+  rounding behaviour, even when built with old GHCs/snapshots. +  hledger uses banker's rounding (rounds to nearest even number, eg+  0.5 displayed with zero decimal places is "0").++- added: debug helpers traceAt, traceAtWith++- Journal is now a Semigroup, not a Monoid (since <> is right-biased). (Stephen Morgan)++# 1.17.0.1 2020-03-01++- fix org heading comments and doctest setup comment that were+  breaking haddock (and in some cases, installation)++# 1.17 2020-03-01++- Reader-finding utilities have moved from Hledger.Read to+  Hledger.Read.JournalReader so the include directive can use them.++- Reader changes:+  - rExperimental flag removed+  - old rParser renamed to rReadFn+  - new rParser field provides the actual parser.+    This seems to require making Reader a higher-kinded type, unfortunately.++- Hledger.Tabular.AsciiWide now renders smoother outer borders in+  pretty (unicode) mode.+  Also, a fix for table edges always using single-width intersections+  and support for double horizontal lines with single vertical lines. (Eric Mertens)++- Hledger.Utils.Parse: restofline can go to eof also++- Hledger.Read cleanup++- Hledger.Read.CsvReader cleanup+  Exports added: CsvRecord, CsvValue, csvFileFor.+  Exports removed: expandIncludes, parseAndValidateCsvRules, transactionFromCsvRecord++- more cleanup of amount canonicalisation helpers (#1187)+  Stop exporting journalAmounts, overJournalAmounts, traverseJournalAmounts.+  Rename journalAmounts helper to journalStyleInfluencingAmounts.++- export mapMixedAmount++- Don't store leaf name in PeriodReport. (Stephen Morgan)+  Calculate at the point of consumption instead.++- Generalise PeriodicReport to be polymorphic in the account labels. (Stephen Morgan)++- Use records instead of tuples in PeriodicReport. (Stephen Morgan)++- Use PeriodicReport in place of MultiBalanceReport. (Stephen Morgan)++- Calculate MultiReportBalance columns more efficiently. (Stephen Morgan)+  Only calculate posting date once for each posting, and calculate their+  columns instead of checking each DateSpan separately.++- Moved JSON instances from hledger-web to hledger-lib (Hledger.Data.Json),+  and added ToJSON instances for all (?) remaining data types, up to Ledger.++- Dropped nullassertion's "assertion" alias, fixing a warning.+  Perhaps we'll stick with the null* naming convention. +++# 1.16.2 2020-01-14++- add support for megaparsec 8 (#1175)++# 1.16.1 2019-12-03++- Drop unnecessary mtl-compat dependency++- Fix building with GHC 8.0, 8.2++# 1.16 2019-12-01++- drop support for GHC 7.10, due to MonadFail hassles in JournalReader.hs++- add support for GHC 8.8, base-compat 0.11 (#1090)++  We are now using the new fail from the MonadFail class, which we+  always import as qualified Fail.fail, from base-compat-batteries+  Control.Monad.Fail.Compat to work with old GHC versions. If old fail+  is needed (shouldn't be) it should be imported qualified as+  Prelude.Fail, using imports such as:++      import Prelude hiding (fail)+      import Prelude qualified (fail)+      import Control.Monad.State.Strict hiding (fail)+      import "base-compat-batteries" Prelude.Compat hiding (fail)+      import "base-compat-batteries" qualified Control.Monad.Fail.Compat as Fail++- hledger and hledger-lib unit tests have been ported to tasty.++- The doctest suite has been disabled for now since it doesn't run+  well with cabal (#1139)+  +# 1.15.2 2019-09-05++Changes:++- postingApplyValuation, mixedAmountApplyValuation, amountApplyValuation+  take an argument, the report end date if one was specified.++# 1.15.1 2019-09-02++- fix failing doctests++# 1.15 2019-09-01++Removals include:++- journalPrices+- BalanceHistoryReport+- postingValueAtDate++Additions include:++- MarketPrice (more pure form of PriceDirective without the amount style information)+- PriceOracle (efficient lookup of exchange rates)+- ValuationType (ways to convert amount value)+- aliasnamep (export)+- setNaturalPrecisionUpTo+- dbgNWith, ptraceAtWith+- postingTransformAmount, postingToCost, postingValue+- amountToCost, mixedAmountToCost+- valueTypeFromOpts+- mapJournalTransactions, mapJournalPostings, mapTransactionPostings+- journalStartDate, journalEndDate+- journalPriceOracle+- marketPriceReverse+- priceDirectiveToMarketPrice+- mixedAmountApplyValuation+- mixedAmountValueAtDate++Changes include:++- Price -> AmountPrice,  AKA "transaction price"+- old MarketPrice -> PriceDirective+- TransactionsReport/AccountTransactionsReport split into separate files+- journalTransactionsReport -> transactionsReport+- accountTransactionsReportItems: rewrite using catMaybes and mapAccumL (Henning Thielemann)+- optionally save the current date in ReportOpts+- Hledger.Cli tests now have correct prefix; add Cli.Utils tests+- MultiBalanceReport now returns zero for row totals when in cumulative or historical mode (#329)+++# 1.14.1 2019-03-20++- require easytest <0.3 to fix build issue++# 1.14 2019-03-01++- added:  +  transaction, [v]post*, balassert* constructors, for tests etc.  ++- renamed:  +  porigin -> poriginal  ++- refactored:  +  transaction balancing & balance assertion checking (#438)++# 1.13.1 (2019/02/02)++- stop depending on here to avoid haskell-src-meta/stackage blockage.++# 1.13 (2019/02/01)++- in Journal's jtxns field, forecasted txns are appended rather than prepended++- API changes:++  added:+  +setFullPrecision+  +setMinimalPrecision+  +expectParseStateOn+  +embedFileRelative+  +hereFileRelative++  changed:+  - amultiplier -> aismultiplier+  - Amount fields reordered for clearer debug output+  - tpreceding_comment_lines -> tprecedingcomment, reordered+  - Hledger.Data.TransactionModifier.transactionModifierToFunction -> modifyTransactions+  - Hledger.Read.Common.applyTransactionModifiers -> Hledger.Data.Journal.journalModifyTransactions++  - HelpTemplate -> CommandDoc+++# 1.12 (2018/12/02)++-   switch to megaparsec 7 (Alex Chen)+    We now track the stack of include files in Journal ourselves, since+    megaparsec dropped this feature.++-   add 'ExceptT' layer to our parser monad again (Alex Chen)+    We previously had a parser type, 'type ErroringJournalParser = ExceptT+    String ...' for throwing parse errors without allowing further+    backtracking. This parser type was removed under the assumption that it+    would be possible to write our parser without this capability. However,+    after a hairy backtracking bug, we would now prefer to have the option to+    prevent backtracking.++    -   Define a 'FinalParseError' type specifically for the 'ExceptT' layer+    -   Any parse error can be raised as a "final" parse error+    -   Tracks the stack of include files for parser errors, anticipating the+        removal of the tracking of stacks of include files in megaparsec 7+        -   Although a stack of include files is also tracked in the 'StateT+            Journal' layer of the parser, it seems easier to guarantee correct+            error messages in the 'ExceptT FinalParserError' layer+        -   This does not make the 'StateT Journal' stack redundant because the+            'ExceptT FinalParseError' stack cannot be used to detect cycles of+            include files++-   more support for location-aware parse errors when re-parsing (Alex Chen)++-   make 'includedirectivep' an 'ErroringJournalParser' (Alex Chen)++-   drop Ord instance breaking GHC 8.6 build (Peter Simons)++-   flip the arguments of (divide\|multiply)\[Mixed\]Amount++-   showTransaction: fix a case showing multiple missing amounts+    showTransaction could sometimes hide the last posting's amount even if+    one of the other posting amounts was already implicit, producing invalid     transaction output.  -   plog, plogAt: add missing newline
Hledger.hs view
@@ -1,6 +1,26 @@-{-# LANGUAGE OverloadedStrings #-}+{-|+This is the root of the @hledger-lib@ package and the @Hledger.*@ module hierarchy.+hledger-lib is the core engine used by various hledger UIs and tools,+providing the main data types, file format parsers, reporting logic, and utilities. +SPDX-License-Identifier: GPL-3.0-or-later+Copyright (c) 2007-2025 (each year in this range) Simon Michael <simon@joyful.com> and contributors.++This program is free software: you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation, either version 3 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;+without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.+See the GNU General Public License for more details.+You should have received a copy of the GNU General Public License along with this program.+If not, see <https://www.gnu.org/licenses/>.++-}+ module Hledger (+  -- $DOCS   module X  ,tests_Hledger )@@ -12,10 +32,357 @@ import           Hledger.Query   as X import           Hledger.Utils   as X -tests_Hledger = tests "Hledger" [+tests_Hledger = testGroup "Hledger" [    tests_Data   ,tests_Query   ,tests_Read   ,tests_Reports   ,tests_Utils   ]+++{- $DOCS++This is also the starting point for hledger's code docs,+aimed at hledger developers and PTA implementors (and curious users).+These are embedded in hledger's source code as Haddock comments and can be viewed+in your code editor,+or in a web browser (eg with @make haddock@),+or (for released versions) on Hackage, eg [hledger-lib:Hledger](https://hackage.haskell.org/package/hledger-lib/docs/Hledger.html).+See also:++- hledger:Hledger.Cli+- hledger-ui:Hledger.UI+- hledger-web:Hledger.Web+- [The README files](https://github.com/search?q=repo%3Asimonmichael%2Fhledger+path%3A**%2FREADME*&type=code&ref=advsearch)+- [The high-level developer docs](https://hledger.org/dev.html)++The rest of this page discusses some general topics.+Together with the hledger manual it describes and provides a functional specification+for hledger and hledger-like apps.+The current code and tests generally conform to this, hopefully.++== Jargon++In addition to the terminology defined in the hledger manual,+eg at [Journal](https://hledger.org/dev/hledger.html#journal):++Here are some words with particular meanings in the context of hledger:++- __/Decimal/__ is a decimal number representation provided by+  the Decimal package, used by hledger for storing numeric quantities.++- __/Normalised decimal/__ A Decimal which has no trailing decimal zeros.+  This can be ensured by the @normaliseDecimal@ function.++- __/Amount/__ ('Amount') is hledger's representation of numeric amounts+  which have a decimal quantity,+  a commodity symbol ('CommoditySymbol'),+  and a display style ('AmountStyle') and display precision ('Precision').+  and optionally a cost in another commodity.++- __/Style/__, __/Amount style/__ An amount's display style, such its decimal mark and symbol placement.+  Represented by "CommodityStyle". (That also stores display precision,+  though it is sometimes convenient to speak of style and precision separately.)++- __/Commodity style/__ The standard display style inferred or specified for a particular commodity.+  Normally all amounts in that commodity are displayed with that style.++- __/Precision/__ In hledger docs, "precision" means the number of decimal digits,+  ie digits to the right of the decimal mark.++- __/Journal precision/__ The number of decimal digits written for an amount+  in the journal file (or in other input data).++- __/Decimal precision/__ The number of decimal digits stored in an Amount's internal Decimal number.+  After parsing, this will be the same as the journal precision; it can increase during amount calculations.++- __/Display precision/__ The preferred number of decimal digits to show in output+  (except by @print@-like reports, which show journal precision by default).++- __/MixedAmount/__ ('MixedAmount') is hledger's representation of a+  multi-commodity amount; it is a set of zero or more Amounts in+  different commodities and costs (stored as a map for efficiency).++- __/amount/__ means either a single-commodity Amount or a multi-commodity MixedAmount,+  depending on context. There are various sources and kinds of amount:++- __/Posting amount/__ An amount being posted (moved from or to) an account.++- __/Cost amount/__ The (cost in a different commodity) associated with a posting amount.+  Eg the purchase cost when buying, or the sale price when selling.+  Cost is recorded in the journal immediately following the posting amount, expressed as a unit or total cost.++- __/Unit cost/__ The cost per unit of the posting amount. Written as @\@ UNITCOST@.++- __/Total cost/__ The total cost the posting amount. Written as @\@\@ TOTALCOST@.++- __/Amount cost/__ A posting amount converted to its cost's commodity. Shown by @hledger print -B@.++    > 2023-01-01+    >    (a)   2 A @ 2 B   ; <- the amount cost is 4 B++    > 2023-01-01+    >    (a)   2 A @@ 2 B   ; <- the amount cost is 2 B++- __/Cost/__ can mean any of the four above depending on context.++- __/Balance assertion \/ assignment amount/__+  An amount written after the posting amount and cost,+  following @=@ or @==@ or @=*@ or @==*@,+  representing a balance assertion+  (or when the posting amount is omitted, a balance assignment).++- __/Balance assertion \/ assignment cost/__+  The unit or total cost of the balance assertion\/assignment amount, if any.+  Written after it in the usual way.++- __/Price/__, __/Market price/__+  A conversion rate\/exchange rate from a particular commodity to another as of a particular date.+  These usually fluctuate over time, and are recorded by @P@ price directives.+  Shown by @hledger prices@.++- __/Price amount/__ The amount written in a @P@ price directive,+  which specifies the destination commodity and the per-unit conversion rate.++- __/Cost vs price/__+  Both of these words are quite slippery in english.+  To simplify, we always say+  "cost" for a conversion rate used in a particular transaction (posting), and+  "price" for conversion rates prevailing in the environment.++- __/Value/__+  Any amount converted to some other commodity using a market price on a certain date.+  Shown by any hledger report when the @-V@, @-X@ or @--value@ option is used.++- __/Real postings/__ Normal account postings, required to balance to zero.++- __/Virtual postings/__ Account postings which are exempt from the normal balance-to-zero requirement.+  Written with parentheses around the account name.+  Can be excluded from reports with the @--real@ flag.++- __/Balanced virtual postings/__ Account postings which are required to balance to zero,+  but separately from the real postings.+  Written with square brackets around the account name.+  Can be excluded from reports with the @--real@ flag.++- __/Transaction balancing/__ The process of inferring amounts and/or costs to balance a transaction,+  both in its real and its balanced virtual postings.++- __/Balancing amount/__ An amount that is inferred to balance a transaction with a missing amount. Shown by @hledger print -x@.++    > 2023-01-01+    >    a   1+    >    b        ; <- a balancing amount of -1 is inferred++- __/Balancing cost/__ A cost that is inferred to balance a transaction involving two commodities. Shown by @hledger print -x@.++    > 2023-01-01+    >    a   1 A  ; <- a balancing cost of @@ 2 B is inferred+    >    b  -2 B++== Precision++As mentioned in Jargon:+"precision" in hledger means the number of digits to the right of the decimal mark.+And, amounts have several precisions we can talk about:++__/Journal precision/__ is the number of decimal digits recorded in the+journal file \/ input data. We accept up to 255 decimal digits there.++__/Decimal precision/__ is the number of decimal digits stored internally in each Decimal value. Decimal supports up to 255 decimal digits.+In amounts just parsed from the journal, this will be the same as their journal precision.+During calculations, amounts' decimal precision may increase, and will not decrease.++__/Display precision/__ is the preferred number of decimal digits to show in report output.+It is represented by 'AmountPrecision', which is currently part of the 'AmountStyle' stored within each Amount.+In amounts just parsed from the journal, this will be the same as the journal and decimal precisions;+later it gets standardised for each commodity's amounts.+When display precision is less than the decimal precision, fewer, rounded decimal digits are displayed ("rounding").+When display precision is greater than the decimal precision, additional decimal zeros are displayed ("padding").++Basically, hledger amounts have two main precisions we care about at runtime:+their internal decimal precision, used for calculation, and their display precision, used for rendering.++== Rounding++__/Internal rounding/__ means rounding (or padding) internal Decimal numbers,+using @amountSetInternalPrecision@ (which uses @Data.Decimal.roundTo@).+Internal rounding loses information so we don't do this much.++__/Display rounding/__ means applying a target display precision to an existing amount.+This can be done more or less forcefully, determined by a "display rounding strategy" ('Rounding').+Currently this too is stored within each Amount's AmountStyle, for convenience,+(though semantically speaking it is not part of the amount).++The rounding strategies are:++- none - leave the amount's display precision unchanged+- soft - add or remove trailing decimal zeros to approximate the target precision, but don't remove significant digits+- hard - use the exact target precision, possibly rounding and hiding significant digits+- all  - do hard rounding of both the main amount and its cost amount (costs are normally not display-rounded).++Broadly, here is when display rounding happens:++1. After reading a journal, when standard commodity styles are applied,+  display precisions are kept unchanged; no rounding is done at this stage (since 1.31).++2. While balancing each transaction,+  its amounts are temporarily hard-rounded to the standard commodity display precisions,+  to provide some configurable tolerance in the balancing calculations.+  (We plan to change this to use transaction-local standard precisions,+  inferred from the transaction's journal precisions only, like Ledger.)++3. Just before output, reports do display rounding according to their needs (since 1.31).+  Most reports do hard display rounding.+  @print@ and other print-like commands do no rounding by default,+  or optionally one of the other rounding strategies.++=== Precision and style handling++hledger supports user-specified precisions from 0 to 255 for each+commodity, and tries to propagate these consistently and intuitively+through all the various processing steps.++This gets rather complicated, so we keep a summary of the current+precision and style behaviours here.+This doc should always be kept synced with code.++In Decimal number calculations:++- the result is normalised, meaning any trailing decimal zeros are trimmed.+  So the result 's precision can be larger+  (1 / 2, both with precision 0, is 0.5, with precision 1)+  or smaller+  (2.0 / 1.0, both with precision 1, is normalised to 2, with precision 0).++In amount calculations:++- When amounts are summed (or subtracted), the result has the maximum+  of their decimal precisions, the maximum of their display precisions,+  and the display style of the second amount.++- When an amount is multiplied (or divided) by a pure number,+  the result's decimal precision is that of the decimal result, normalised.+  The display precision and style is kept unchanged.++- When an amount is converted to cost, the new amount's decimal precision+  is that of the cost amount (if it's a total cost),+  or of the cost amount multiplied by the quantity and normalised (if it's a unit cost).+  Its display precision is kept unchanged.+  Its display style is that of the cost amount.++- When an amount is converted to value, the new amount's decimal precision+  is that of the price amount multiplied by the quantity and normalised.+  Its display precision is set to match the decimal precision,+  or to a fallback precision (8) if the decimal appears to be infinite.+  Its display style is its commodity's standard display style.+  If no standard style is known for the commodity (eg because it does not appear in the journal),+  it is given the fallback display style (symbol on the left unspaced, period as decimal mark,+  precision limited to a maximum of 8 digits).++In a run of hledger:++__1. Input__++__1.1. Parsing__++- Each parsed amount initially has decimal precision, display precision,+  and display style set according to how it was written in the journal.++__1.2. Standard styling__++- After all amounts are parsed,+  standard display styles and display precisions are inferred for each commodity+  from its amounts, directives like @commodity@ and @D@, and -c\/--commodity options+  (in 'journalInferCommodityStyles'),+  and these are applied to all amounts and their costs for consistent display+  (in 'journalStyleAmounts').+  No amount display precisions are changed at this stage.++__1.3. Transaction balancing__++- When amounts are summed, the result has the maximum of their+  decimal precisions and the maximum of their display precisions.++- A balancing amount without a cost will have the same precisions as+  the amount (or sum) it is balancing.++- A balancing amount which has a cost will be converted to cost; see+  "When an amount is converted to cost" above.++- When inferring a balancing cost:++    - The "from amount" is the sum of postings in the first-appearing commodity.++    - The "to amount" is the sum of postings in the second-appearing commodity. See "When amounts are summed" above.++    - If the from amount comes from a single posting, it is given a total cost.+      The cost's decimal precision will be that of the to amount divided by the from quantity, normalised. +      Its display precision and style will be that of the to amount.++    - If the from amount comes from multiple postings, they all are given a unit cost.+      The cost's decimal precision will be that of the to amount divided by the from quantity, normalised. +      Its display precision will be the sum of the from and to amounts' display precisions, or 2, whichever is greater.+      Its display style will be that of the to amount.++- An amount inferred from a balance assignment will have the same precisions as the balance assignment amount.++__1.4. Determining market prices__++If needed, for a value report:++- Any @P@ price directives form the __/declared prices/__.+  Like posting amounts, their price amounts have been standard-styled+  but their precisions have not yet been changed.++- If the @--infer-market-prices@ flag is used, additional price+  directives are generated from any journal postings with costs+  (in 'amountPriceDirectiveFromCost').+  When the cost was a unit cost, the price amount will have the same precisions.+  When the cost was a total cost,++    - The total cost is divided by the amount quantity to get a unit cost.+    - Its decimal precision becomes that of the decimal result, normalised.+    - Its display precision is set to match the new decimal precision;+      unless the decimal appears to be infinite (because it uses all the 255 digits allowed),+      in which case it is given a smaller fallback display precision (8 decimal digits).++    These plus the declared prices are the __/forward prices/__.++- Additional market prices are generated (as 'MarketPrice' this time, not 'PriceDirective')+  by reversing the forward prices (in 'marketPriceReverse').+  Any new prices generated in this way are the __/reverse prices/__.+  Their decimal precision will be that of (1 \/ the decimal quantity), normalised.+  (They don't have a display precision.)+  These plus the forward prices are the __/direct prices/__+  (giving direct conversion rates from one commodity to another).++And later, if needed:++- For each requested value conversion from commodity A to commodity B,+  if an appropriate price is not found in the direct prices, we try to calculate a __/chained price/__,+  combining two or more direct prices that form a path from A to B.+  The resulting price's decimal precision will be the product of the chained prices, normalised,+  then padded back up to the maximum of their decimal precisions+  (undoing the normalising, because later we will choose the value amount's display precision+   based on the value's decimal precision).++__2. Calculating reports__++- Amounts may be converted to cost (-B), summed, averaged, converted+  to velue (-V\/-X\/--value), etc.  Precisions and styles are affected+  as described in "In amount calculations" above.++__3. Output__++- print-like reports: amounts are displayed with their current display precisions.+  Or with --round, they can be soft- or hard-rounded/padded to the standard commodity precisions.+ +- All other reports: amounts are displayed hard rounded/padded to the standard commodity precisions.++- In the roi report: if there is no standard display precision for the valuation commodity,+  it is limited to a maximum of 8 digits.++== Exports of this module:+-}
Hledger/Data.hs view
@@ -12,12 +12,18 @@                module Hledger.Data.Account,                module Hledger.Data.AccountName,                module Hledger.Data.Amount,-               module Hledger.Data.Commodity,+               module Hledger.Data.BalanceData,+               module Hledger.Data.Balancing,+               module Hledger.Data.Currency,                module Hledger.Data.Dates,+               module Hledger.Data.DayPartition,+               module Hledger.Data.Errors,                module Hledger.Data.Journal,+               module Hledger.Data.JournalChecks,+               module Hledger.Data.Json,                module Hledger.Data.Ledger,-               module Hledger.Data.MarketPrice,                module Hledger.Data.Period,+               module Hledger.Data.PeriodData,                module Hledger.Data.PeriodicTransaction,                module Hledger.Data.Posting,                module Hledger.Data.RawOptions,@@ -26,19 +32,27 @@                module Hledger.Data.Transaction,                module Hledger.Data.TransactionModifier,                module Hledger.Data.Types,+               module Hledger.Data.Valuation,                tests_Data               ) where +import Test.Tasty (testGroup) import Hledger.Data.Account+import Hledger.Data.BalanceData import Hledger.Data.AccountName import Hledger.Data.Amount-import Hledger.Data.Commodity+import Hledger.Data.Balancing+import Hledger.Data.Currency import Hledger.Data.Dates+import Hledger.Data.DayPartition+import Hledger.Data.Errors import Hledger.Data.Journal+import Hledger.Data.JournalChecks+import Hledger.Data.Json import Hledger.Data.Ledger-import Hledger.Data.MarketPrice import Hledger.Data.Period+import Hledger.Data.PeriodData import Hledger.Data.PeriodicTransaction import Hledger.Data.Posting import Hledger.Data.RawOptions@@ -46,15 +60,22 @@ import Hledger.Data.Timeclock import Hledger.Data.Transaction import Hledger.Data.TransactionModifier-import Hledger.Data.Types-import Hledger.Utils.Test+import Hledger.Data.Types hiding (MixedAmountKey, Mixed)+import Hledger.Data.Valuation -tests_Data = tests "Data" [-   tests_AccountName+tests_Data = testGroup "Data" [+   tests_Account+  ,tests_AccountName   ,tests_Amount+  ,tests_BalanceData+  ,tests_Balancing+  ,tests_DayPartition+  -- ,tests_Currency   ,tests_Journal   ,tests_Ledger+  ,tests_PeriodData   ,tests_Posting+  ,tests_Valuation   ,tests_StringFormat   ,tests_Timeclock   ,tests_Transaction
Hledger/Data/Account.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} {-|  @@ -8,33 +11,73 @@ -}  module Hledger.Data.Account-where-import Data.List-import Data.List.Extra (groupSort, groupOn)-import Data.Maybe-import Data.Ord-import qualified Data.Map as M-import Data.Text (pack,unpack)-import Safe (headMay, lookupJustDef)-import Text.Printf+( nullacct+, accountFromBalances+, accountFromPostings+, accountsFromPostings+, accountTree+, accountTreeFromBalanceAndNames+, showAccounts+, showAccountsBoringFlag+, printAccounts+, lookupAccount+, parentAccounts+, accountsLevels+, mapAccounts+, mapPeriodData+, anyAccounts+, filterAccounts+, sumAccounts+, clipAccounts+, clipAccountsAndAggregate+, pruneAccounts+, flattenAccounts+, mergeAccounts+, accountSetDeclarationInfo+, sortAccountNamesByDeclaration+, sortAccountTreeByDeclaration+, sortAccountTreeOn+-- -- * Tests+, tests_Account+) where +import Control.Applicative ((<|>))+import Data.HashSet qualified as HS+import Data.HashMap.Strict qualified as HM+import Data.List (find, sortOn)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.List.NonEmpty (NonEmpty(..), groupWith)+import Data.Map qualified as M+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.These (These(..))+import Data.Time (Day(..), fromGregorian)+import Safe (headMay)+import Text.Printf (printf)++import Hledger.Data.BalanceData ()+import Hledger.Data.PeriodData import Hledger.Data.AccountName import Hledger.Data.Amount-import Hledger.Data.Posting() import Hledger.Data.Types import Hledger.Utils   -- deriving instance Show Account-instance Show Account where-    show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)"-                       (pack $ regexReplace ":" "_" $ unpack aname)  -- hide : so pretty-show doesn't break line-                       (if aboring then "y" else "n" :: String)-                       anumpostings-                       (showMixedAmount aebalance)-                       (showMixedAmount aibalance)+instance Show a => Show (Account a) where+  showsPrec d acct =+    showParen (d > 10) $+       showString "Account "+      . showString (T.unpack $ aname acct)+      . showString " (boring:"+      . showString (if aboring acct then "y" else "n")+      . showString ", adata:"+      . shows (adata acct)+      . showChar ')' -instance Eq Account where+instance Eq (Account a) where   (==) a b = aname a == aname b -- quick equality test for speed              -- and              -- [ aname a == aname b@@ -44,53 +87,92 @@              -- , aibalance a == aibalance b              -- ] -nullacct = Account-  { aname            = ""+nullacct :: Account BalanceData+nullacct = accountFromBalances "" mempty++-- | Construct an 'Account" from an account name and balances. Other fields are+-- left blank.+accountFromBalances :: AccountName -> PeriodData a -> Account a+accountFromBalances name bal = Account+  { aname            = name   , adeclarationinfo = Nothing   , asubs            = []   , aparent          = Nothing   , aboring          = False-  , anumpostings     = 0-  , aebalance        = nullmixedamt-  , aibalance        = nullmixedamt+  , adata            = bal   } --- | Derive 1. an account tree and 2. each account's total exclusive--- and inclusive changes from a list of postings.+-- | Derive 1. an account tree and 2. each account's total exclusive and+-- inclusive changes associated with dates from a list of postings and a+-- function for associating a date to each posting (usually representing the+-- start dates of report subperiods). -- This is the core of the balance command (and of *ledger). -- The accounts are returned as a list in flattened tree order, -- and also reference each other as a tree. -- (The first account is the root of the tree.)-accountsFromPostings :: [Posting] -> [Account]-accountsFromPostings ps =-  let-    grouped = groupSort [(paccount p,pamount p) | p <- ps]-    counted = [(aname, length amts) | (aname, amts) <- grouped]-    summed =  [(aname, sumStrict amts) | (aname, amts) <- grouped]  -- always non-empty-    acctstree      = accountTree "root" $ map fst summed-    acctswithnumps = mapAccounts setnumps    acctstree      where setnumps    a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted}-    acctswithebals = mapAccounts setebalance acctswithnumps where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed}-    acctswithibals = sumAccounts acctswithebals-    acctswithparents = tieAccountParents acctswithibals-    acctsflattened = flattenAccounts acctswithparents-  in-    acctsflattened+accountsFromPostings :: (Posting -> Maybe Day) -> [Posting] -> [Account BalanceData]+accountsFromPostings getPostingDate = flattenAccounts . accountFromPostings getPostingDate --- | Convert a list of account names to a tree of Account objects, --- with just the account names filled in. +-- | Derive 1. an account tree and 2. each account's total exclusive+-- and inclusive changes associated with dates from a list of postings and a+-- function for associating a date to each posting (usually representing the+-- start dates of report subperiods).+-- This is the core of the balance command (and of *ledger).+-- The accounts are returned as a tree.+accountFromPostings :: (Posting -> Maybe Day) -> [Posting] -> Account BalanceData+accountFromPostings getPostingDate ps =+    tieAccountParents . sumAccounts $ mapAccounts setBalance acctTree+  where+    -- The special name "..." is stored in the root of the tree+    acctTree     = accountTree "root" . HM.keys $ HM.delete "..." accountMap+    setBalance a = a{adata = HM.lookupDefault mempty name accountMap}+      where name = if aname a == "root" then "..." else aname a+    accountMap   = processPostings ps++    processPostings :: [Posting] -> HM.HashMap AccountName (PeriodData BalanceData)+    processPostings = foldl' (flip processAccountName) mempty+      where+        processAccountName p = HM.alter (updateBalanceData p) (paccount p)+        updateBalanceData p = Just+                            . insertPeriodData (getPostingDate p) (BalanceData (pamount p) nullmixedamt 1)+                            . fromMaybe mempty++-- | Convert a list of account names to a tree of Account objects,+-- with just the account names filled in and an empty balance. -- A single root account with the given name is added.-accountTree :: AccountName -> [AccountName] -> Account-accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m }+accountTree :: Monoid a => AccountName -> [AccountName] -> Account a+accountTree rootname = accountTreeFromBalanceAndNames rootname mempty++-- | Convert a list of account names to a tree of Account objects,+-- with just the account names filled in. Each account is given the same+-- supplied balance.+-- A single root account with the given name is added.+accountTreeFromBalanceAndNames :: AccountName -> PeriodData a -> [AccountName] -> Account a+accountTreeFromBalanceAndNames rootname bals as =+    (accountFromBalances rootname bals){ asubs=map (uncurry accountTree') $ M.assocs m }   where     T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName-    accountTree' a (T m) =-      nullacct{-        aname=a-       ,asubs=map (uncurry accountTree') $ M.assocs m-       }+    accountTree' a (T m') =+      (accountFromBalances a bals){ asubs=map (uncurry accountTree') $ M.assocs m' } +-- | An efficient-to-build tree suggested by Cale Gibbard, probably+-- better than accountNameTreeFrom.+newtype FastTree a = T (M.Map a (FastTree a))+  deriving (Show, Eq, Ord)++mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a+mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')++treeFromPath :: [a] -> FastTree a+treeFromPath []     = T M.empty+treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs))++treeFromPaths :: (Ord a) => [[a]] -> FastTree a+treeFromPaths = foldl' mergeTrees (T M.empty) . map treeFromPath++ -- | Tie the knot so all subaccounts' parents are set correctly.-tieAccountParents :: Account -> Account+tieAccountParents :: Account a -> Account a tieAccountParents = tie Nothing   where     tie parent a@Account{..} = a'@@ -98,35 +180,50 @@         a' = a{aparent=parent, asubs=map (tie (Just a')) asubs}  -- | Get this account's parent accounts, from the nearest up to the root.-parentAccounts :: Account -> [Account]+parentAccounts :: Account a -> [Account a] parentAccounts Account{aparent=Nothing} = [] parentAccounts Account{aparent=Just a} = a:parentAccounts a  -- | List the accounts at each level of the account tree.-accountsLevels :: Account -> [[Account]]+accountsLevels :: Account a -> [[Account a]] accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[])  -- | Map a (non-tree-structure-modifying) function over this and sub accounts.-mapAccounts :: (Account -> Account) -> Account -> Account+mapAccounts :: (Account a -> Account a) -> Account a -> Account a mapAccounts f a = f a{asubs = map (mapAccounts f) $ asubs a} +-- | Apply a function to all 'PeriodData' within this and sub accounts.+mapPeriodData :: (PeriodData a -> PeriodData a) -> Account a -> Account a+mapPeriodData f = mapAccounts (\a -> a{adata = f $ adata a})+ -- | Is the predicate true on any of this account or its subaccounts ?-anyAccounts :: (Account -> Bool) -> Account -> Bool+anyAccounts :: (Account a -> Bool) -> Account a -> Bool anyAccounts p a     | p a = True     | otherwise = any (anyAccounts p) $ asubs a --- | Add subaccount-inclusive balances to an account tree.-sumAccounts :: Account -> Account-sumAccounts a-  | null $ asubs a = a{aibalance=aebalance a}-  | otherwise      = a{aibalance=ibal, asubs=subs}+-- | Is the predicate true on all of this account and its subaccounts ?+allAccounts :: (Account a -> Bool) -> Account a -> Bool+allAccounts p a+    | not (p a) = False+    | otherwise = all (allAccounts p) $ asubs a++-- | Recalculate all the subaccount-inclusive balances in this tree.+sumAccounts :: Account BalanceData -> Account BalanceData+sumAccounts a = a{asubs = subs, adata = setInclusiveBalances $ adata a}   where     subs = map sumAccounts $ asubs a-    ibal = sum $ aebalance a : map aibalance subs+    subtotals = foldMap adata subs +    setInclusiveBalances :: PeriodData BalanceData -> PeriodData BalanceData+    setInclusiveBalances = mergePeriodData onlyChildren noChildren combineChildren subtotals++    combineChildren children this = this  {bdincludingsubs = bdexcludingsubs this <> bdincludingsubs children}+    onlyChildren    children      = mempty{bdincludingsubs = bdincludingsubs children}+    noChildren               this = this  {bdincludingsubs = bdexcludingsubs this}+ -- | Remove all subaccounts below a certain depth.-clipAccounts :: Int -> Account -> Account+clipAccounts :: Int -> Account a -> Account a clipAccounts 0 a = a{asubs=[]} clipAccounts d a = a{asubs=subs}     where@@ -134,12 +231,15 @@  -- | Remove subaccounts below the specified depth, aggregating their balance at the depth limit -- (accounts at the depth limit will have any sub-balances merged into their exclusive balance).-clipAccountsAndAggregate :: Int -> [Account] -> [Account]-clipAccountsAndAggregate d as = combined+-- If the depth is Nothing, return the original accounts+clipAccountsAndAggregate :: Monoid a => DepthSpec -> [Account a] -> [Account a]+clipAccountsAndAggregate (DepthSpec Nothing []) as = as+clipAccountsAndAggregate depthSpec              as = combined     where-      clipped  = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as]-      combined = [a{aebalance=sum (map aebalance same)}-                 | same@(a:_) <- groupOn aname clipped]+      clipped  = [a{aname=clipOrEllipsifyAccountName depthSpec $ aname a} | a <- as]+      combined = [a{adata=foldMap adata same}+                 | same@(a:|_) <- groupWith aname clipped]+ {- test cases, assuming d=1: @@ -169,7 +269,7 @@ -}  -- | Remove all leaf accounts and subtrees matching a predicate.-pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account+pruneAccounts :: (Account a -> Bool) -> Account a -> Maybe (Account a) pruneAccounts p = headMay . prune   where     prune a@@ -182,90 +282,112 @@ -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the -- tree's structure remains intact and can still be used. It's a tree/list!-flattenAccounts :: Account -> [Account]+flattenAccounts :: Account a -> [Account a] flattenAccounts a = squish a []-  where squish a as = a : Prelude.foldr squish as (asubs a)+  where squish a' as = a' : Prelude.foldr squish as (asubs a')  -- | Filter an account tree (to a list).-filterAccounts :: (Account -> Bool) -> Account -> [Account]+filterAccounts :: (Account a -> Bool) -> Account a -> [Account a] filterAccounts p a     | p a       = a : concatMap (filterAccounts p) (asubs a)     | otherwise = concatMap (filterAccounts p) (asubs a) --- | Sort each group of siblings in an account tree by inclusive amount,--- so that the accounts with largest normal balances are listed first.  --- The provided normal balance sign determines whether normal balances--- are negative or positive, affecting the sort order. Ie,--- if balances are normally negative, then the most negative balances--- sort first, and vice versa.-sortAccountTreeByAmount :: NormalSign -> Account -> Account-sortAccountTreeByAmount normalsign a-  | null $ asubs a = a-  | otherwise      = a{asubs=-                        sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . aibalance)) $-                        map (sortAccountTreeByAmount normalsign) $ asubs a}+-- | Merge two account trees and their subaccounts.+--+-- This assumes that the top-level 'Account's have the same name.+mergeAccounts :: Account a -> Account b -> Account (These a b)+mergeAccounts a = tieAccountParents . merge a   where-    maybeflip | normalsign==NormallyNegative = id-              | otherwise                  = flip+    merge acct1 acct2 = acct1+       { adeclarationinfo = adeclarationinfo acct1 <|> adeclarationinfo acct2+       , aparent = Nothing+       , aboring = aboring acct1 && aboring acct2+       , adata = mergeBalances (adata acct1) (adata acct2)+       , asubs = mergeSubs (sortOn aname $ asubs acct1) (sortOn aname $ asubs acct2)+       } +    mergeSubs (x:xs) (y:ys) = case compare (aname x) (aname y) of+      EQ -> merge x y : mergeSubs xs ys+      LT -> fmap This x : mergeSubs xs (y:ys)+      GT -> fmap That y : mergeSubs (x:xs) ys+    mergeSubs xs [] = map (fmap This) xs+    mergeSubs [] ys = map (fmap That) ys++    mergeBalances = mergePeriodData This That These++-- | Sort each group of siblings in an account tree by projecting through+-- a provided function.+sortAccountTreeOn :: Ord b => (Account a -> b) -> Account a -> Account a+sortAccountTreeOn f = mapAccounts $ \a -> a{asubs=sortOn f $ asubs a}+ -- | Add extra info for this account derived from the Journal's -- account directives, if any (comment, tags, declaration order..).-accountSetDeclarationInfo :: Journal -> Account -> Account+accountSetDeclarationInfo :: Journal -> Account a -> Account a accountSetDeclarationInfo j a@Account{..} =   a{ adeclarationinfo=lookup aname $ jdeclaredaccounts j }  -- | Sort account names by the order in which they were declared in -- the journal, at each level of the account tree (ie within each -- group of siblings). Undeclared accounts are sorted last and--- alphabetically. +-- alphabetically. -- This is hledger's default sort for reports organised by account. -- The account list is converted to a tree temporarily, adding any--- missing parents; these can be kept (suitable for a tree-mode report) +-- missing parents; these can be kept (suitable for a tree-mode report) -- or removed (suitable for a flat-mode report). -- sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName] sortAccountNamesByDeclaration j keepparents as =-  (if keepparents then id else filter (`elem` as)) $  -- maybe discard missing parents that were added-  map aname $                                         -- keep just the names-  drop 1 $                                            -- drop the root node that was added-  flattenAccounts $                                   -- convert to an account list-  sortAccountTreeByDeclaration $                      -- sort by declaration order (and name)-  mapAccounts (accountSetDeclarationInfo j) $         -- add declaration order info-  accountTree "root"                                  -- convert to an account tree-  as+    (if keepparents then id else filter (`HS.member` HS.fromList as)) $  -- maybe discard missing parents that were added+    map aname $                                         -- keep just the names+    drop 1 $                                            -- drop the root node that was added+    flattenAccounts $                                   -- convert to an account list+    sortAccountTreeByDeclaration $                      -- sort by declaration order (and name)+    mapAccounts (accountSetDeclarationInfo j) $         -- add declaration order info+    (accountTree "root" as :: Account ())               -- convert to an account tree  -- | Sort each group of siblings in an account tree by declaration order, then account name.--- So each group will contain first the declared accounts, --- in the same order as their account directives were parsed, --- and then the undeclared accounts, sorted by account name. -sortAccountTreeByDeclaration :: Account -> Account+-- So each group will contain first the declared accounts,+-- in the same order as their account directives were parsed,+-- and then the undeclared accounts, sorted by account name.+sortAccountTreeByDeclaration :: Account a -> Account a sortAccountTreeByDeclaration a   | null $ asubs a = a   | otherwise      = a{asubs=-      sortOn accountDeclarationOrderAndName $ +      sortOn accountDeclarationOrderAndName $       map sortAccountTreeByDeclaration $ asubs a       } -accountDeclarationOrderAndName :: Account -> (Int, AccountName)+accountDeclarationOrderAndName :: Account a -> (Int, AccountName) accountDeclarationOrderAndName a = (adeclarationorder', aname a)   where     adeclarationorder' = maybe maxBound adideclarationorder $ adeclarationinfo a  -- | Search an account list by name.-lookupAccount :: AccountName -> [Account] -> Maybe Account+lookupAccount :: AccountName -> [Account a] -> Maybe (Account a) lookupAccount a = find ((==a).aname)  -- debug helpers -printAccounts :: Account -> IO ()+printAccounts :: Show a => Account a -> IO () printAccounts = putStrLn . showAccounts +showAccounts :: Show a => Account a -> String showAccounts = unlines . map showAccountDebug . flattenAccounts  showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts -showAccountDebug a = printf "%-25s %4s %4s %s"+showAccountDebug a = printf "%-25s %s %4s"                      (aname a)-                     (showMixedAmount $ aebalance a)-                     (showMixedAmount $ aibalance a)                      (if aboring a then "b" else " " :: String)+                     (show $ adata a)+++tests_Account = testGroup "Account" [+    testGroup "accountFromPostings" [+      testCase "no postings, no days" $+        accountFromPostings undefined [] @?= accountTree "root" []+     ,testCase "no postings, only 2000-01-01" $+         allAccounts (all (== fromGregorian 2000 01 01) . M.keys . pdperiods . adata)+                     (accountFromPostings undefined []) @? "Not all adata have exactly 2000-01-01"+    ]+  ]
Hledger/Data/AccountName.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-|  'AccountName's are strings like @assets:cash:petty@, with multiple@@ -16,41 +15,69 @@   ,accountNameFromComponents   ,accountNameLevel   ,accountNameToAccountOnlyRegex+  ,accountNameToAccountOnlyRegexCI   ,accountNameToAccountRegex+  ,accountNameToAccountRegexCI   ,accountNameTreeFrom-  ,accountRegexToAccountName   ,accountSummarisedName+  ,accountNameInferType+  ,accountNameInferTypeExcept+  ,accountNameType+  ,defaultBaseConversionAccount+  ,assetAccountRegex+  ,cashAccountRegex+  ,liabilityAccountRegex+  ,equityAccountRegex+  ,conversionAccountRegex+  ,revenueAccountRegex+  ,gainAccountRegex+  ,expenseAccountRegex   ,acctsep   ,acctsepchar   ,clipAccountName   ,clipOrEllipsifyAccountName+  ,getAccountNameClippedDepth   ,elideAccountName   ,escapeName   ,expandAccountName   ,expandAccountNames   ,isAccountNamePrefixOf---  ,isAccountRegex +--  ,isAccountRegex   ,isSubAccountNameOf   ,parentAccountName   ,parentAccountNames   ,subAccountNamesFrom   ,topAccountNames+  ,topAccountName   ,unbudgetedAccountName+  ,accountNamePostingType+  ,accountNameWithoutPostingType+  ,accountNameWithPostingType+  ,joinAccountNames+  ,concatAccountNames+  ,accountNameApplyAliases+  ,accountNameApplyAliasesMemo   ,tests_AccountName ) where -import Data.List-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid-#endif+import Control.Applicative ((<|>))+import Control.Monad (foldM)+import Data.Foldable (asum, find, toList)+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as M+import Data.Maybe (mapMaybe)+import Data.MemoUgly (memo)+import Data.Set qualified as S import Data.Text (Text)-import qualified Data.Text as T-import Data.Tree-import Text.Printf+import Data.Text qualified as T+import Data.Tree (Tree(..), unfoldTree)+import Safe+import Text.DocLayout (realLength) -import Hledger.Data.Types-import Hledger.Utils +import Hledger.Data.Types hiding (asubs)+import Hledger.Utils+import Data.List (partition)  -- $setup -- >>> :set -XOverloadedStrings@@ -61,6 +88,50 @@ acctsep :: Text acctsep = T.pack [acctsepchar] +-- The base conversion account name used by --infer-equity,+-- when no other account of type V/Conversion has been declared.+defaultBaseConversionAccount = "equity:conversion"++-- | Regular expressions matching common English top-level account names,+-- used as a fallback when account types are not declared.+assetAccountRegex      = toRegexCI' "^assets?(:|$)"+cashAccountRegex       = toRegexCI' "^assets?(:.+)?:(cash|bank|che(ck|que?)(ing)?|savings?|current)(:|$)"+liabilityAccountRegex  = toRegexCI' "^(debts?|liabilit(y|ies))(:|$)"+equityAccountRegex     = toRegexCI' "^equity(:|$)"+conversionAccountRegex = toRegexCI' "^equity:(trade|trades|trading|conversion)(:|$)"+revenueAccountRegex    = toRegexCI' "^(income|revenue)s?(:|$)"+gainAccountRegex       = toRegexCI' "^(income|revenue)s?:(capital[- ]?)?(gains?|loss(es)?)(:|$)"+expenseAccountRegex    = toRegexCI' "^expenses?(:|$)"++-- | Try to guess an account's type from its name,+-- matching common English top-level account names.+accountNameInferType :: AccountName -> Maybe AccountType+accountNameInferType a+  | regexMatchText cashAccountRegex       a = Just Cash+  | regexMatchText assetAccountRegex      a = Just Asset+  | regexMatchText liabilityAccountRegex  a = Just Liability+  | regexMatchText conversionAccountRegex a = Just Conversion+  | regexMatchText equityAccountRegex     a = Just Equity+  | regexMatchText revenueAccountRegex    a = Just Revenue+  | regexMatchText expenseAccountRegex    a = Just Expense+  | otherwise                               = Nothing++-- | Like accountNameInferType, but exclude the provided types from the guesses.+-- Used eg to prevent "equity:conversion" being inferred as Conversion when a different+-- account has been declared with that type.+accountNameInferTypeExcept :: [AccountType] -> AccountName -> Maybe AccountType+accountNameInferTypeExcept excludedtypes a =+  case accountNameInferType a of+    Just t | not $ t `elem` excludedtypes -> Just t+    _ -> Nothing++-- Extract the 'AccountType' of an 'AccountName' by looking it up in the+-- provided Map, traversing the parent accounts if necessary. If none of those+-- work, try 'accountNameInferType'.+accountNameType :: M.Map AccountName AccountType -> AccountName -> Maybe AccountType+accountNameType atypes a = asum (map (`M.lookup` atypes) $ a : parentAccountNames a)+                         <|> accountNameInferType a+ -- accountNameComponents :: AccountName -> [String] -- accountNameComponents = splitAtElement acctsepchar @@ -83,18 +154,85 @@       cs = accountNameComponents a       a' = accountLeafName a +-- | The level (depth) of an account name.+--+-- >>> accountNameLevel ""  -- special case+-- 0+-- >>> accountNameLevel "assets"+-- 1+-- >>> accountNameLevel "assets:cash"+-- 2 accountNameLevel :: AccountName -> Int accountNameLevel "" = 0 accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1  -- | A top-level account prefixed to some accounts in budget reports.--- Defined here so it can be ignored by accountNameDrop. +-- Defined here so it can be ignored by accountNameDrop. unbudgetedAccountName :: T.Text unbudgetedAccountName = "<unbudgeted>" +accountNamePostingType :: AccountName -> PostingType+accountNamePostingType a+    | T.null a = RegularPosting+    | T.head a == '[' && T.last a == ']' = BalancedVirtualPosting+    | T.head a == '(' && T.last a == ')' = VirtualPosting+    | otherwise = RegularPosting++accountNameWithoutPostingType :: AccountName -> AccountName+accountNameWithoutPostingType a = case accountNamePostingType a of+                                    BalancedVirtualPosting -> textUnbracket a+                                    VirtualPosting -> textUnbracket a+                                    RegularPosting -> a++accountNameWithPostingType :: PostingType -> AccountName -> AccountName+accountNameWithPostingType BalancedVirtualPosting = wrap "[" "]" . accountNameWithoutPostingType+accountNameWithPostingType VirtualPosting         = wrap "(" ")" . accountNameWithoutPostingType+accountNameWithPostingType RegularPosting         = accountNameWithoutPostingType++-- | Prefix one account name to another, preserving posting type+-- indicators like concatAccountNames.+joinAccountNames :: AccountName -> AccountName -> AccountName+joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b]++-- | Join account names into one. If any of them has () or [] posting type+-- indicators, these (the first type encountered) will also be applied to+-- the resulting account name.+concatAccountNames :: [AccountName] -> AccountName+concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as+    where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as++-- | Rewrite an account name using all matching aliases from the given list, in sequence.+-- Each alias sees the result of applying the previous aliases.+-- Or, return any error arising from a bad regular expression in the aliases.+accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName+accountNameApplyAliases aliases a =+  let (name,typ) = (accountNameWithoutPostingType a, accountNamePostingType a)+  in foldM+     (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct))+     name+     aliases+     >>= Right . accountNameWithPostingType typ++-- | Memoising version of accountNameApplyAliases, maybe overkill.+accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName+accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)+  -- XXX re-test this memoisation++-- aliasMatches :: AccountAlias -> AccountName -> Bool+-- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a+-- aliasMatches (RegexAlias re  _) a = regexMatchesCI re a++aliasReplace :: AccountAlias -> AccountName -> Either RegexError AccountName+aliasReplace (BasicAlias old new) a+  | old `isAccountNamePrefixOf` a || old == a =+      Right $ new <> T.drop (T.length old) a+  | otherwise = Right a+aliasReplace (RegexAlias re repl) a =+  fmap T.pack . regexReplace re repl $ T.unpack a -- XXX+ -- | Remove some number of account name components from the front of the account name. -- If the special "<unbudgeted>" top-level account is present, it is preserved and--- dropping affects the rest of the account name. +-- dropping affects the rest of the account name. accountNameDrop :: Int -> AccountName -> AccountName accountNameDrop n a   | a == unbudgetedAccountName = a@@ -102,24 +240,30 @@       case accountNameDrop n $ T.drop (T.length unbudgetedAccountAndSep) a of         "" -> unbudgetedAccountName         a' -> unbudgetedAccountAndSep <> a'-  | otherwise = accountNameFromComponents $ drop n $ accountNameComponents a-  where +  | otherwise = accountNameFromComponentsOrElide . drop n $ accountNameComponents a+  where     unbudgetedAccountAndSep = unbudgetedAccountName <> acctsep+    accountNameFromComponentsOrElide [] = "..."+    accountNameFromComponentsOrElide xs = accountNameFromComponents xs  -- | Sorted unique account names implied by these account names, -- ie these plus all their parent accounts up to the root. -- Eg: ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] expandAccountNames :: [AccountName] -> [AccountName]-expandAccountNames as = nub $ sort $ concatMap expandAccountName as+expandAccountNames = toList . foldMap (S.fromList . expandAccountName)  -- | "a:b:c" -> ["a","a:b","a:b:c"] expandAccountName :: AccountName -> [AccountName]-expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents+expandAccountName = map accountNameFromComponents . NE.tail . NE.inits . accountNameComponents  -- | ["a:b:c","d:e"] -> ["a","d"] topAccountNames :: [AccountName] -> [AccountName]-topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]+topAccountNames = filter ((1==) . accountNameLevel) . expandAccountNames +-- | "a:b:c" -> "a"+topAccountName :: AccountName -> AccountName+topAccountName = T.takeWhile (/= acctsepchar)+ parentAccountName :: AccountName -> AccountName parentAccountName = accountNameFromComponents . init . accountNameComponents @@ -127,7 +271,7 @@ parentAccountNames a = parentAccountNames' $ parentAccountName a     where       parentAccountNames' "" = []-      parentAccountNames' a = a : parentAccountNames' (parentAccountName a)+      parentAccountNames' a2 = a2 : parentAccountNames' (parentAccountName a2)  -- | Is the first account a parent or other ancestor of (and not the same as) the second ? isAccountNamePrefixOf :: AccountName -> AccountName -> Bool@@ -135,24 +279,28 @@  isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p =-    (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))+  (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))  -- | From a list of account names, select those which are direct -- subaccounts of the given account name. subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts --- | Convert a list of account names to a tree.+-- | Convert a list of account names to a tree, efficiently. accountNameTreeFrom :: [AccountName] -> Tree AccountName-accountNameTreeFrom accts =-    Node "root" (accounttreesfrom (topAccountNames accts))-        where-          accounttreesfrom :: [AccountName] -> [Tree AccountName]-          accounttreesfrom [] = []-          accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]-          subs = subAccountNamesFrom (expandAccountNames accts)----nullaccountnametree = Node "root" []+accountNameTreeFrom accts = unfoldTree grow ("root", expandAccountNames accts)+  where+    -- unfoldTree :: (b -> (a, [b])) -> b -> Tree a+    -- grow :: (b -> (a, [b]))+    -- a = AccountName                  - the label at each node of the tree+    -- b = (AccountName, [AccountName]) - the next node's account, and the accounts remaining to consume under it+    grow :: ((AccountName, [AccountName]) -> (AccountName, [(AccountName, [AccountName])]))+    grow (a,[])   = (a,[])+    grow (a,rest) = (a, [(s, filter (s `isAccountNamePrefixOf`) deepersubs) | s <- asubs])+      where+        (asubs, deepersubs) = partition (isChildOf a) rest+        isChildOf "root" = (1==) . accountNameLevel+        isChildOf acct   = (`isSubAccountNameOf` acct)  -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news:@@ -185,69 +333,145 @@     fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where         elideparts :: Int -> [Text] -> [Text] -> [Text]-        elideparts width done ss-          | textWidth (accountNameFromComponents $ done++ss) <= width = done++ss-          | length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss)+        elideparts w done ss+          | realLength (accountNameFromComponents $ done++ss) <= w = done++ss+          | length ss > 1 = elideparts w (done++[textTakeWidth 2 $ headErr ss]) (tailErr ss)  -- PARTIAL headErr, tailErr will succeed because length > 1           | otherwise = done++ss  -- | Keep only the first n components of an account name, where n--- is a positive integer. If n is 0, returns the empty string.-clipAccountName :: Int -> AccountName -> AccountName-clipAccountName n = accountNameFromComponents . take n . accountNameComponents+-- is a positive integer.+clipAccountNameTo :: Int -> AccountName -> AccountName+clipAccountNameTo n = accountNameFromComponents . take n . accountNameComponents --- | Keep only the first n components of an account name, where n--- is a positive integer. If n is 0, returns "...".-clipOrEllipsifyAccountName :: Int -> AccountName -> AccountName-clipOrEllipsifyAccountName 0 = const "..."-clipOrEllipsifyAccountName n = accountNameFromComponents . take n . accountNameComponents+-- | Calculate the depth to which an account name should be clipped for a given+-- 'DepthSpec'.+--+-- First checking whether the account name matches any of the regular+-- expressions controlling depth. If so, clip to the depth of the most specific+-- of those matches, i.e. the one which starts matching the latest as you+-- progress up the parents of the account. Otherwise clip to the flat depth+-- provided, or return the full name if Nothing.+getAccountNameClippedDepth :: DepthSpec -> AccountName -> Maybe Int+getAccountNameClippedDepth (DepthSpec flat regexps) acctName =+    mostSpecificRegexp regexps <|> flat+  where+    -- If any regular expressions match, choose the one with the greatest+    -- specificity and clip to that depth.+    mostSpecificRegexp = fmap snd . foldr takeMax Nothing . mapMaybe matchRegexp+      where+        -- If two regexps match, take the most specific one. If there is a tie,+        -- take the last one (this aligns with the behaviour for flat depths+        -- limiting).+        takeMax (s, d) (Just (s', d')) = Just $ if s'>= s then (s', d') else (s, d)+        takeMax (s, d) Nothing = Just (s, d) +    -- If the regular expression matches the account name, store the specificity and requested depth+    matchRegexp :: (Regexp, Int) -> Maybe (Int, Int)+    matchRegexp (r, d) = if regexMatchText r acctName then Just (getSpecificity r, d) else Nothing+    -- Specificity is the smallest parent of the account which matches the regular expression+    getSpecificity r = maybe maxBound fst $ find (regexMatchText r . snd) acctParents+    acctParents = zip [1..] . initDef [] $ expandAccountName acctName++-- | Clip an account name to a given 'DepthSpec', first checking whether it+-- matches any of the regular expressions controlling depth. If so, clip to the+-- depth of the most specific of those matches, i.e. the one which starts+-- matching the latest as you progress up the parents of the account. Otherwise+-- clip to the flat depth provided, or return the full name if Nothing.+clipAccountName :: DepthSpec -> AccountName -> AccountName+clipAccountName ds a = maybe id clipAccountNameTo (getAccountNameClippedDepth ds a) a++-- | As 'clipAccountName', but return '...' if asked to clip to depth 0.+clipOrEllipsifyAccountName :: DepthSpec -> AccountName -> AccountName+clipOrEllipsifyAccountName ds a = go (getAccountNameClippedDepth ds a)+  where+    go Nothing  = a+    go (Just 0) = "..."+    go (Just n) = clipAccountNameTo n a+ -- | Escape an AccountName for use within a regular expression.--- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"+-- >>> putStr . T.unpack $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#-escapeName :: AccountName -> Regexp-escapeName = regexReplaceBy "[[?+|()*\\\\^$]" ("\\" <>)-           . T.unpack+escapeName :: AccountName -> Text+escapeName = T.concatMap escapeChar+  where+    escapeChar c = if c `elem` escapedChars then T.snoc "\\" c else T.singleton c+    escapedChars = ['[', '?', '+', '|', '(', ')', '*', '$', '^', '\\']  -- | Convert an account name to a regular expression matching it and its subaccounts. accountNameToAccountRegex :: AccountName -> Regexp-accountNameToAccountRegex "" = ""-accountNameToAccountRegex a = printf "^%s(:|$)" (escapeName a)+accountNameToAccountRegex a = toRegex' $ "^" <> escapeName a <> "(:|$)"  -- PARTIAL: Is this safe after escapeName? +-- | Convert an account name to a regular expression matching it and its subaccounts,+-- case insensitively.+accountNameToAccountRegexCI :: AccountName -> Regexp+accountNameToAccountRegexCI a = toRegexCI' $ "^" <> escapeName a <> "(:|$)"  -- PARTIAL: Is this safe after escapeName?+ -- | Convert an account name to a regular expression matching it but not its subaccounts. accountNameToAccountOnlyRegex :: AccountName -> Regexp-accountNameToAccountOnlyRegex "" = ""-accountNameToAccountOnlyRegex a = printf "^%s$"  $ escapeName a -- XXX pack+accountNameToAccountOnlyRegex a = toRegex' $ "^" <> escapeName a <> "$" -- PARTIAL: Is this safe after escapeName? --- | Convert an exact account-matching regular expression to a plain account name.-accountRegexToAccountName :: Regexp -> AccountName-accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack+-- | Convert an account name to a regular expression matching it but not its subaccounts,+-- case insensitively.+accountNameToAccountOnlyRegexCI :: AccountName -> Regexp+accountNameToAccountOnlyRegexCI a = toRegexCI' $ "^" <> escapeName a <> "$" -- PARTIAL: Is this safe after escapeName?  -- -- | Does this string look like an exact account-matching regular expression ? --isAccountRegex  :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" -tests_AccountName = tests "AccountName" [-  tests "accountNameTreeFrom" [-     accountNameTreeFrom ["a"]       `is` Node "root" [Node "a" []]-    ,accountNameTreeFrom ["a","b"]   `is` Node "root" [Node "a" [], Node "b" []]-    ,accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]]-    ,accountNameTreeFrom ["a:b:c"]   `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]]-  ]-  ,tests "expandAccountNames" [-    expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`+tests_AccountName = testGroup "AccountName" [+   testCase "accountNameTreeFrom" $ do+    accountNameTreeFrom ["a"]       @?= Node "root" [Node "a" []]+    accountNameTreeFrom ["a","b"]   @?= Node "root" [Node "a" [], Node "b" []]+    accountNameTreeFrom ["a","a:b"] @?= Node "root" [Node "a" [Node "a:b" []]]+    accountNameTreeFrom ["a:b:c"]   @?= Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]]+  ,testCase "expandAccountNames" $ do+    expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] @?=      ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]-  ]-  ,tests "isAccountNamePrefixOf" [-     "assets" `isAccountNamePrefixOf` "assets" `is` False-    ,"assets" `isAccountNamePrefixOf` "assets:bank" `is` True-    ,"assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True-    ,"my assets" `isAccountNamePrefixOf` "assets:bank" `is` False-  ]-  ,tests "isSubAccountNameOf" [-     "assets" `isSubAccountNameOf` "assets" `is` False-    ,"assets:bank" `isSubAccountNameOf` "assets" `is` True-    ,"assets:bank:checking" `isSubAccountNameOf` "assets" `is` False-    ,"assets:bank" `isSubAccountNameOf` "my assets" `is` False-  ]+  ,testCase "isAccountNamePrefixOf" $ do+    "assets" `isAccountNamePrefixOf` "assets" @?= False+    "assets" `isAccountNamePrefixOf` "assets:bank" @?= True+    "assets" `isAccountNamePrefixOf` "assets:bank:checking" @?= True+    "my assets" `isAccountNamePrefixOf` "assets:bank" @?= False+  ,testCase "isSubAccountNameOf" $ do+    "assets" `isSubAccountNameOf` "assets" @?= False+    "assets:bank" `isSubAccountNameOf` "assets" @?= True+    "assets:bank:checking" `isSubAccountNameOf` "assets" @?= False+    "assets:bank" `isSubAccountNameOf` "my assets" @?= False+  ,testCase "accountNameInferType" $ do+    accountNameInferType "assets"            @?= Just Asset+    accountNameInferType "assets:cash"       @?= Just Cash+    accountNameInferType "assets:A/R"        @?= Just Asset+    accountNameInferType "liabilities"       @?= Just Liability+    accountNameInferType "equity"            @?= Just Equity+    accountNameInferType "equity:conversion" @?= Just Conversion+    accountNameInferType "expenses"          @?= Just Expense+    accountNameInferType "revenues"          @?= Just Revenue+    accountNameInferType "revenue"           @?= Just Revenue+    accountNameInferType "income"            @?= Just Revenue+    -- Gain type is no longer inferred from names; these are now Revenue+    accountNameInferType "income:gains"          @?= Just Revenue+    accountNameInferType "revenue:gain"          @?= Just Revenue+    accountNameInferType "revenues:capital-gains" @?= Just Revenue+    accountNameInferType "income:capitalgain"    @?= Just Revenue+    accountNameInferType "income:losses"         @?= Just Revenue+    accountNameInferType "revenue:capital-loss"  @?= Just Revenue+    accountNameInferType "income:gains:realized" @?= Just Revenue+  ,testCase "joinAccountNames" $ do+    joinAccountNames "assets" "cash"     @?= "assets:cash"+    joinAccountNames "assets:cash" "a"   @?= "assets:cash:a"+    joinAccountNames "assets" "(cash)"   @?= "(assets:cash)"+    joinAccountNames "assets" "[cash]"   @?= "[assets:cash]"+    joinAccountNames "(assets)" "cash"   @?= "(assets:cash)"+    joinAccountNames "" "assets"         @?= "assets"+    joinAccountNames "assets" ""         @?= "assets"+  ,testCase "concatAccountNames" $ do+    concatAccountNames ["assets", "cash"]   @?= "assets:cash"+    concatAccountNames ["assets:cash", "a"] @?= "assets:cash:a"+    concatAccountNames ["assets", "(cash)"] @?= "(assets:cash)"+    concatAccountNames ["assets", "[cash]"] @?= "[assets:cash]"+    concatAccountNames ["(assets)", "cash"] @?= "(assets:cash)"+    concatAccountNames ["", "assets"]       @?= ":assets"+    concatAccountNames ["assets", ""]       @?= "assets:"  ]
Hledger/Data/Amount.hs view
@@ -12,830 +12,1465 @@   0 @ -It may also have an assigned 'Price', representing this amount's per-unit-or total cost in a different commodity. If present, this is rendered like-so:--@-  EUR 2 \@ $1.50  (unit price)-  EUR 2 \@\@ $3   (total price)-@--A 'MixedAmount' is zero or more simple amounts, so can represent multiple-commodities; this is the type most often used:--@-  0-  $50 + EUR 3-  16h + $13.55 + AAPL 500 + 6 oranges-@--When a mixed amount has been \"normalised\", it has no more than one amount-in each commodity and no zero amounts; or it has just a single zero amount-and no others.--Limited arithmetic with simple and mixed amounts is supported, best used-with similar amounts since it mostly ignores assigned prices and commodity-exchange rates.---}--{-# LANGUAGE StandaloneDeriving, RecordWildCards, OverloadedStrings #-}--module Hledger.Data.Amount (-  -- * Amount-  amount,-  nullamt,-  missingamt,-  num,-  usd,-  eur,-  gbp,-  hrs,-  at,-  (@@),-  amountWithCommodity,-  -- ** arithmetic-  costOfAmount,-  divideAmount,-  multiplyAmount,-  divideAmountAndPrice,-  multiplyAmountAndPrice,-  amountValue,-  amountTotalPriceToUnitPrice,-  -- ** rendering-  amountstyle,-  styleAmount,-  showAmount,-  cshowAmount,-  showAmountWithZeroCommodity,-  showAmountDebug,-  showAmountWithoutPrice,-  maxprecision,-  maxprecisionwithpoint,-  setAmountPrecision,-  withPrecision,-  setFullPrecision,-  setMinimalPrecision,-  setAmountInternalPrecision,-  withInternalPrecision,-  setAmountDecimalPoint,-  withDecimalPoint,-  canonicaliseAmount,-  -- * MixedAmount-  nullmixedamt,-  missingmixedamt,-  mixed,-  amounts,-  filterMixedAmount,-  filterMixedAmountByCommodity,-  normaliseMixedAmountSquashPricesForDisplay,-  normaliseMixedAmount,-  -- ** arithmetic-  costOfMixedAmount,-  divideMixedAmount,-  multiplyMixedAmount,-  divideMixedAmountAndPrice,-  multiplyMixedAmountAndPrice,-  averageMixedAmounts,-  isNegativeAmount,-  isNegativeMixedAmount,-  isZeroAmount,-  isReallyZeroAmount,-  isZeroMixedAmount,-  isReallyZeroMixedAmount,-  isReallyZeroMixedAmountCost,-  mixedAmountValue,-  mixedAmountTotalPriceToUnitPrice,-  -- ** rendering-  styleMixedAmount,-  showMixedAmount,-  showMixedAmountOneLine,-  showMixedAmountDebug,-  showMixedAmountWithoutPrice,-  showMixedAmountOneLineWithoutPrice,-  cshowMixedAmountWithoutPrice,-  cshowMixedAmountOneLineWithoutPrice,-  showMixedAmountWithZeroCommodity,-  showMixedAmountWithPrecision,-  setMixedAmountPrecision,-  canonicaliseMixedAmount,-  -- * misc.-  ltraceamount,-  tests_Amount-) where--import Data.Char (isDigit)-import Data.Decimal (roundTo, decimalPlaces, normalizeDecimal)-import Data.Function (on)-import Data.List-import Data.Map (findWithDefault)-import Data.Maybe-import Data.Time.Calendar (Day)--- import Data.Text (Text)-import qualified Data.Text as T-import Safe (maximumDef)-import Text.Printf-import qualified Data.Map as M--import Hledger.Data.Types-import Hledger.Data.Commodity-import Hledger.Utils ---deriving instance Show MarketPrice------------------------------------------------------------------------------------- Amount styles---- | Default amount style -amountstyle = AmountStyle L False 0 (Just '.') Nothing------------------------------------------------------------------------------------- Amount--instance Num Amount where-    abs a@Amount{aquantity=q}    = a{aquantity=abs q}-    signum a@Amount{aquantity=q} = a{aquantity=signum q}-    fromInteger i                = nullamt{aquantity=fromInteger i}-    negate a@Amount{aquantity=q} = a{aquantity= -q}-    (+)                          = similarAmountsOp (+)-    (-)                          = similarAmountsOp (-)-    (*)                          = similarAmountsOp (*)---- | The empty simple amount.-amount, nullamt :: Amount-amount = Amount{acommodity="", aquantity=0, aprice=NoPrice, astyle=amountstyle, aismultiplier=False}-nullamt = amount---- | A temporary value for parsed transactions which had no amount specified.-missingamt :: Amount-missingamt = amount{acommodity="AUTO"}---- Handy amount constructors for tests.--- usd/eur/gbp round their argument to a whole number of pennies/cents.-num n = amount{acommodity="",  aquantity=n}-hrs n = amount{acommodity="h", aquantity=n,           astyle=amountstyle{asprecision=2, ascommodityside=R}}-usd n = amount{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}-eur n = amount{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}-gbp n = amount{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}-amt `at` priceamt = amt{aprice=UnitPrice priceamt}-amt @@ priceamt = amt{aprice=TotalPrice priceamt}---- | Apply a binary arithmetic operator to two amounts, which should--- be in the same commodity if non-zero (warning, this is not checked).--- A zero result keeps the commodity of the second amount.--- The result's display style is that of the second amount, with--- precision set to the highest of either amount.--- Prices are ignored and discarded.--- Remember: the caller is responsible for ensuring both amounts have the same commodity.-similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount-similarAmountsOp op Amount{acommodity=_,  aquantity=q1, astyle=AmountStyle{asprecision=p1}}-                    Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} =-   -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug)-   amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}-  --  c1==c2 || q1==0 || q2==0 =-  --  otherwise = error "tried to do simple arithmetic with amounts in different commodities"---- | Convert an amount to the specified commodity, ignoring and discarding--- any assigned prices and assuming an exchange rate of 1.-amountWithCommodity :: CommoditySymbol -> Amount -> Amount-amountWithCommodity c a = a{acommodity=c, aprice=NoPrice}---- | Convert an amount to the commodity of its assigned price, if any.  Notes:------ - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error) XXX------ - price amounts should be positive, though this is not currently enforced-costOfAmount :: Amount -> Amount-costOfAmount a@Amount{aquantity=q, aprice=price} =-    case price of-      NoPrice -> a-      UnitPrice  p@Amount{aquantity=pq} -> p{aquantity=pq * q}-      TotalPrice p@Amount{aquantity=pq} -> p{aquantity=pq * signum q}---- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice.--- Has no effect on amounts without one.--- Also increases the unit price's display precision to show one extra decimal place,--- to help keep transaction amounts balancing. --- Does Decimal division, might be some rounding/irrational number issues.-amountTotalPriceToUnitPrice :: Amount -> Amount-amountTotalPriceToUnitPrice -  a@Amount{aquantity=q, aprice=TotalPrice pa@Amount{aquantity=pq, astyle=ps@AmountStyle{asprecision=pp}}}-  = a{aprice = UnitPrice pa{aquantity=abs (pq/q), astyle=ps{asprecision=pp+1}}}-amountTotalPriceToUnitPrice a = a---- | Divide an amount's quantity by a constant.-divideAmount :: Quantity -> Amount -> Amount-divideAmount n a@Amount{aquantity=q} = a{aquantity=q/n}---- | Multiply an amount's quantity by a constant.-multiplyAmount :: Quantity -> Amount -> Amount-multiplyAmount n a@Amount{aquantity=q} = a{aquantity=q*n}---- | Divide an amount's quantity (and its total price, if it has one) by a constant.--- The total price will be kept positive regardless of the multiplier's sign.-divideAmountAndPrice :: Quantity -> Amount -> Amount-divideAmountAndPrice n a@Amount{aquantity=q,aprice=p} = a{aquantity=q/n, aprice=f p}-  where-    f (TotalPrice a) = TotalPrice $ abs $ n `divideAmount` a-    f p = p---- | Multiply an amount's quantity (and its total price, if it has one) by a constant.--- The total price will be kept positive regardless of the multiplier's sign.-multiplyAmountAndPrice :: Quantity -> Amount -> Amount-multiplyAmountAndPrice n a@Amount{aquantity=q,aprice=p} = a{aquantity=q*n, aprice=f p}-  where-    f (TotalPrice a) = TotalPrice $ abs $ n `multiplyAmount` a-    f p = p---- | Is this amount negative ? The price is ignored.-isNegativeAmount :: Amount -> Bool-isNegativeAmount Amount{aquantity=q} = q < 0--digits = "123456789" :: String---- | Does this amount appear to be zero when displayed with its given precision ?-isZeroAmount :: Amount -> Bool-isZeroAmount --  a==missingamt = False-  = not . any (`elem` digits) . showAmountWithoutPriceOrCommodity---- | Is this amount "really" zero, regardless of the display precision ?-isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount Amount{aquantity=q} = q == 0---- | Get the string representation of an amount, based on its commodity's--- display settings except using the specified precision.-showAmountWithPrecision :: Int -> Amount -> String-showAmountWithPrecision p = showAmount . setAmountPrecision p---- | Set an amount's display precision.-setAmountPrecision :: Int -> Amount -> Amount-setAmountPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}}---- | Set an amount's display precision, flipped.-withPrecision :: Amount -> Int -> Amount-withPrecision = flip setAmountPrecision---- | Increase an amount's display precision, if necessary, enough so--- that it will be shown exactly, with all significant decimal places--- (excluding trailing zeros).-setFullPrecision :: Amount -> Amount-setFullPrecision a = setAmountPrecision p a-  where-    p                = max displayprecision normalprecision-    displayprecision = asprecision $ astyle a-    normalprecision  = fromIntegral $ decimalPlaces $ normalizeDecimal $ aquantity a---- | Set an amount's display precision to just enough so that it will--- be shown exactly, with all significant decimal places.-setMinimalPrecision :: Amount -> Amount-setMinimalPrecision a = setAmountPrecision normalprecision a-  where-    normalprecision  = fromIntegral $ decimalPlaces $ normalizeDecimal $ aquantity a---- | Get a string representation of an amount for debugging,--- appropriate to the current debug level. 9 shows maximum detail.-showAmountDebug :: Amount -> String-showAmountDebug Amount{acommodity="AUTO"} = "(missing)"-showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle)---- | Get the string representation of an amount, without any \@ price.-showAmountWithoutPrice :: Amount -> String-showAmountWithoutPrice a = showAmount a{aprice=NoPrice}---- | Set an amount's internal precision, ie rounds the Decimal representing --- the amount's quantity to some number of decimal places.--- Rounding is done with Data.Decimal's default roundTo function:--- "If the value ends in 5 then it is rounded to the nearest even value (Banker's Rounding)".--- Does not change the amount's display precision.--- Intended only for internal use, eg when comparing amounts in tests. -setAmountInternalPrecision :: Int -> Amount -> Amount-setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{ -   astyle=s{asprecision=p} -  ,aquantity=roundTo (fromIntegral p) q-  }---- | Set an amount's internal precision, flipped.--- Intended only for internal use, eg when comparing amounts in tests. -withInternalPrecision :: Amount -> Int -> Amount-withInternalPrecision = flip setAmountInternalPrecision---- | Set (or clear) an amount's display decimal point.-setAmountDecimalPoint :: Maybe Char -> Amount -> Amount-setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} }---- | Set (or clear) an amount's display decimal point, flipped.-withDecimalPoint :: Amount -> Maybe Char -> Amount-withDecimalPoint = flip setAmountDecimalPoint---- | Colour version.-cshowAmountWithoutPrice :: Amount -> String-cshowAmountWithoutPrice a = cshowAmount a{aprice=NoPrice}---- | Get the string representation of an amount, without any price or commodity symbol.-showAmountWithoutPriceOrCommodity :: Amount -> String-showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=NoPrice}--showPrice :: Price -> String-showPrice NoPrice         = ""-showPrice (UnitPrice pa)  = " @ "  ++ showAmount pa-showPrice (TotalPrice pa) = " @@ " ++ showAmount pa--showPriceDebug :: Price -> String-showPriceDebug NoPrice         = ""-showPriceDebug (UnitPrice pa)  = " @ "  ++ showAmountDebug pa-showPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa---- | Given a map of standard amount display styles, apply the appropriate one to this amount.--- If there's no standard style for this amount's commodity, return the amount unchanged.-styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount-styleAmount styles a =-  case M.lookup (acommodity a) styles of-    Just s  -> a{astyle=s}-    Nothing -> a ---- | Get the string representation of an amount, based on its--- commodity's display settings. String representations equivalent to--- zero are converted to just \"0\". The special "missing" amount is--- displayed as the empty string.-showAmount :: Amount -> String-showAmount = showAmountHelper False---- | Colour version. For a negative amount, adds ANSI codes to change the colour, --- currently to hard-coded red.-cshowAmount :: Amount -> String-cshowAmount a =-  (if isNegativeAmount a then color Dull Red else id) $-  showAmountHelper False a--showAmountHelper :: Bool -> Amount -> String-showAmountHelper _ Amount{acommodity="AUTO"} = ""-showAmountHelper showzerocommodity a@Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}} =-    case ascommodityside of-      L -> printf "%s%s%s%s" (T.unpack c') space quantity' price-      R -> printf "%s%s%s%s" quantity' space (T.unpack c') price-    where-      quantity = showamountquantity a-      displayingzero = not (any (`elem` digits) quantity)-      (quantity',c') | displayingzero && not showzerocommodity = ("0","")-                     | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)-      space = if not (T.null c') && ascommodityspaced then " " else "" :: String-      price = showPrice p---- | Like showAmount, but show a zero amount's commodity if it has one.-showAmountWithZeroCommodity :: Amount -> String-showAmountWithZeroCommodity = showAmountHelper True---- | Get the string representation of the number part of of an amount,--- using the display settings from its commodity.-showamountquantity :: Amount -> String-showamountquantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p, asdecimalpoint=mdec, asdigitgroups=mgrps}} =-    punctuatenumber (fromMaybe '.' mdec) mgrps qstr-    where-      -- isint n = fromIntegral (round n) == n-      qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer)-        | p == maxprecisionwithpoint = show q-        | p == maxprecision          = chopdotzero $ show q-        | otherwise                  = show $ roundTo (fromIntegral p) q---- | Replace a number string's decimal point with the specified character,--- and add the specified digit group separators. The last digit group will--- be repeated as needed.-punctuatenumber :: Char -> Maybe DigitGroupStyle -> String -> String-punctuatenumber dec mgrps s = sign ++ reverse (applyDigitGroupStyle mgrps (reverse int)) ++ frac''-    where-      (sign,num) = break isDigit s-      (int,frac) = break (=='.') num-      frac' = dropWhile (=='.') frac-      frac'' | null frac' = ""-             | otherwise  = dec:frac'--applyDigitGroupStyle :: Maybe DigitGroupStyle -> String -> String-applyDigitGroupStyle Nothing s = s-applyDigitGroupStyle (Just (DigitGroups c gs)) s = addseps (repeatLast gs) s-  where-    addseps [] s = s-    addseps (g:gs) s-      | length s <= g = s-      | otherwise     = let (part,rest) = splitAt g s-                        in part ++ [c] ++ addseps gs rest-    repeatLast [] = []-    repeatLast gs = init gs ++ repeat (last gs)--chopdotzero str = reverse $ case reverse str of-                              '0':'.':s -> s-                              s         -> s---- | For rendering: a special precision value which means show all available digits.-maxprecision :: Int-maxprecision = 999998---- | For rendering: a special precision value which forces display of a decimal point.-maxprecisionwithpoint :: Int-maxprecisionwithpoint = 999999---- like journalCanonicaliseAmounts--- | Canonicalise an amount's display style using the provided commodity style map.-canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount-canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}-    where-      s' = findWithDefault s c styles---- | Find the market value of this amount on the given date, in it's--- default valuation commodity, based on recorded market prices.--- If no default valuation commodity can be found, the amount is left--- unchanged.-amountValue :: Journal -> Day -> Amount -> Amount-amountValue j d a =-  case commodityValue j d (acommodity a) of-    Just v  -> v{aquantity=aquantity v * aquantity a}-    Nothing -> a---- This is here not in Commodity.hs to use the Amount Show instance above for debugging. --- | Find the market value, if known, of one unit of this commodity (A) on--- the given valuation date, in the commodity (B) mentioned in the latest--- applicable market price. The latest applicable market price is the market--- price directive for commodity A with the latest date that is on or before--- the valuation date; or if there are multiple such prices with the same date,--- the last parsed.-commodityValue :: Journal -> Day -> CommoditySymbol -> Maybe Amount-commodityValue j valuationdate c-    | null applicableprices = dbg Nothing-    | otherwise             = dbg $ Just $ mpamount $ last applicableprices-  where-    dbg = dbg8 ("using market price for "++T.unpack c)-    applicableprices =-      [p | p <- sortOn mpdate $ jmarketprices j-      , mpcommodity p == c-      , mpdate p <= valuationdate-      ]------------------------------------------------------------------------------------- MixedAmount--instance Num MixedAmount where-    fromInteger i = Mixed [fromInteger i]-    negate (Mixed as) = Mixed $ map negate as-    (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs-    (*)    = error' "error, mixed amounts do not support multiplication"-    abs    = error' "error, mixed amounts do not support abs"-    signum = error' "error, mixed amounts do not support signum"---- | The empty mixed amount.-nullmixedamt :: MixedAmount-nullmixedamt = Mixed []---- | A temporary value for parsed transactions which had no amount specified.-missingmixedamt :: MixedAmount-missingmixedamt = Mixed [missingamt]---- | Convert amounts in various commodities into a normalised MixedAmount.-mixed :: [Amount] -> MixedAmount-mixed = normaliseMixedAmount . Mixed---- | Simplify a mixed amount's component amounts:------ * amounts in the same commodity are combined unless they have different prices or total prices------ * multiple zero amounts, all with the same non-null commodity, are replaced by just the last of them, preserving the commodity and amount style (all but the last zero amount are discarded)------ * multiple zero amounts with multiple commodities, or no commodities, are replaced by one commodity-less zero amount------ * an empty amount list is replaced by one commodity-less zero amount------ * the special "missing" mixed amount remains unchanged----normaliseMixedAmount :: MixedAmount -> MixedAmount-normaliseMixedAmount = normaliseHelper False--normaliseHelper :: Bool -> MixedAmount -> MixedAmount-normaliseHelper squashprices (Mixed as)-  | missingamt `elem` as = missingmixedamt -- missingamt should always be alone, but detect it even if not-  | null nonzeros        = Mixed [newzero]-  | otherwise            = Mixed nonzeros-  where-    newzero = case filter (/= "") (map acommodity zeros) of-               _:_ -> last zeros-               _   -> nullamt-    (zeros, nonzeros) = partition isReallyZeroAmount $-                        map sumSimilarAmountsUsingFirstPrice $-                        groupBy groupfn $-                        sortBy sortfn-                        as-    sortfn  | squashprices = compare `on` acommodity-            | otherwise    = compare `on` \a -> (acommodity a, aprice a)-    groupfn | squashprices = (==) `on` acommodity-            | otherwise    = \a1 a2 -> acommodity a1 == acommodity a2 && combinableprices a1 a2--    combinableprices Amount{aprice=NoPrice} Amount{aprice=NoPrice} = True-    combinableprices Amount{aprice=UnitPrice p1} Amount{aprice=UnitPrice p2} = p1 == p2-    combinableprices _ _ = False---- | Like normaliseMixedAmount, but combine each commodity's amounts--- into just one by throwing away all prices except the first. This is--- only used as a rendering helper, and could show a misleading price.-normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount-normaliseMixedAmountSquashPricesForDisplay = normaliseHelper True---- | Sum same-commodity amounts in a lossy way, applying the first--- price to the result and discarding any other prices. Only used as a--- rendering helper.-sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount-sumSimilarAmountsUsingFirstPrice [] = nullamt-sumSimilarAmountsUsingFirstPrice as = (sumStrict as){aprice=aprice $ head as}---- -- | Sum same-commodity amounts. If there were different prices, set--- -- the price to a special marker indicating "various". Only used as a--- -- rendering helper.--- sumSimilarAmountsNotingPriceDifference :: [Amount] -> Amount--- sumSimilarAmountsNotingPriceDifference [] = nullamt--- sumSimilarAmountsNotingPriceDifference as = undefined---- | Get a mixed amount's component amounts.-amounts :: MixedAmount -> [Amount]-amounts (Mixed as) = as---- | Filter a mixed amount's component amounts by a predicate.-filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount-filterMixedAmount p (Mixed as) = Mixed $ filter p as---- | Return an unnormalised MixedAmount containing exactly one Amount--- with the specified commodity and the quantity of that commodity--- found in the original. NB if Amount's quantity is zero it will be--- discarded next time the MixedAmount gets normalised.-filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount-filterMixedAmountByCommodity c (Mixed as) = Mixed as'-  where-    as' = case filter ((==c) . acommodity) as of-            []   -> [nullamt{acommodity=c}]-            as'' -> [sum as'']---- | Apply a transform to a mixed amount's component 'Amount's.-mapMixedAmount :: (Amount -> Amount) -> MixedAmount -> MixedAmount-mapMixedAmount f (Mixed as) = Mixed $ map f as---- | Convert a mixed amount's component amounts to the commodity of their--- assigned price, if any.-costOfMixedAmount :: MixedAmount -> MixedAmount-costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as---- | Divide a mixed amount's quantities by a constant.-divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount-divideMixedAmount n = mapMixedAmount (divideAmount n)---- | Multiply a mixed amount's quantities by a constant.-multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount-multiplyMixedAmount n = mapMixedAmount (multiplyAmount n)---- | Divide a mixed amount's quantities (and total prices, if any) by a constant.--- The total prices will be kept positive regardless of the multiplier's sign.-divideMixedAmountAndPrice :: Quantity -> MixedAmount -> MixedAmount-divideMixedAmountAndPrice n = mapMixedAmount (divideAmountAndPrice n)---- | Multiply a mixed amount's quantities (and total prices, if any) by a constant.--- The total prices will be kept positive regardless of the multiplier's sign.-multiplyMixedAmountAndPrice :: Quantity -> MixedAmount -> MixedAmount-multiplyMixedAmountAndPrice n = mapMixedAmount (multiplyAmountAndPrice n)---- | Calculate the average of some mixed amounts.-averageMixedAmounts :: [MixedAmount] -> MixedAmount-averageMixedAmounts [] = 0-averageMixedAmounts as = fromIntegral (length as) `divideMixedAmount` sum as ---- | Is this mixed amount negative, if it can be normalised to a single commodity ?-isNegativeMixedAmount :: MixedAmount -> Maybe Bool-isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a-                                     _   -> Nothing-    where as = amounts $ normaliseMixedAmountSquashPricesForDisplay m---- | Does this mixed amount appear to be zero when displayed with its given precision ?-isZeroMixedAmount :: MixedAmount -> Bool-isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay---- | Is this mixed amount "really" zero ? See isReallyZeroAmount.-isReallyZeroMixedAmount :: MixedAmount -> Bool-isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay---- | Is this mixed amount "really" zero, after converting to cost--- commodities where possible ?-isReallyZeroMixedAmountCost :: MixedAmount -> Bool-isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount---- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we--- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there.--- -- For now, use this when cross-commodity zero equality is important.--- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool--- mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b')---     where a' = normaliseMixedAmountSquashPricesForDisplay a---           b' = normaliseMixedAmountSquashPricesForDisplay b---- | Given a map of standard amount display styles, apply the appropriate ones to each individual amount.-styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount-styleMixedAmount styles (Mixed as) = Mixed $ map (styleAmount styles) as ---- | Get the string representation of a mixed amount, after--- normalising it to one amount per commodity. Assumes amounts have--- no or similar prices, otherwise this can show misleading prices.-showMixedAmount :: MixedAmount -> String-showMixedAmount = showMixedAmountHelper False False---- | Like showMixedAmount, but zero amounts are shown with their--- commodity if they have one.-showMixedAmountWithZeroCommodity :: MixedAmount -> String-showMixedAmountWithZeroCommodity = showMixedAmountHelper True False---- | Get the one-line string representation of a mixed amount.-showMixedAmountOneLine :: MixedAmount -> String-showMixedAmountOneLine = showMixedAmountHelper False True--showMixedAmountHelper :: Bool -> Bool -> MixedAmount -> String-showMixedAmountHelper showzerocommodity useoneline m =-  join $ map showamt $ amounts $ normaliseMixedAmountSquashPricesForDisplay m-  where-    join | useoneline = intercalate ", "-         | otherwise  = vConcatRightAligned-    showamt | showzerocommodity = showAmountWithZeroCommodity-            | otherwise         = showAmount---- | Compact labelled trace of a mixed amount, for debugging.-ltraceamount :: String -> MixedAmount -> MixedAmount-ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount)---- | Set the display precision in the amount's commodities.-setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount-setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as---- | Get the string representation of a mixed amount, showing each of its--- component amounts with the specified precision, ignoring their--- commoditys' display precision settings.-showMixedAmountWithPrecision :: Int -> MixedAmount -> String-showMixedAmountWithPrecision p m =-    vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountSquashPricesForDisplay m---- | Get an unambiguous string representation of a mixed amount for debugging.-showMixedAmountDebug :: MixedAmount -> String-showMixedAmountDebug m | m == missingmixedamt = "(missing)"-                       | otherwise       = printf "Mixed [%s]" as-    where as = intercalate "\n       " $ map showAmountDebug $ amounts m---- TODO these and related fns are comically complicated:---- | Get the string representation of a mixed amount, without showing any transaction prices.-showMixedAmountWithoutPrice :: MixedAmount -> String-showMixedAmountWithoutPrice m = intercalate "\n" $ map showamt as-  where-    Mixed as = normaliseMixedAmountSquashPricesForDisplay $ mixedAmountStripPrices m-    showamt = printf (printf "%%%ds" width) . showAmountWithoutPrice-      where-        width = maximumDef 0 $ map (length . showAmount) as---- | Colour version of showMixedAmountWithoutPrice. Any individual Amount--- which is negative is wrapped in ANSI codes to make it display in red.-cshowMixedAmountWithoutPrice :: MixedAmount -> String-cshowMixedAmountWithoutPrice m = intercalate "\n" $ map showamt as-  where-    Mixed as = normaliseMixedAmountSquashPricesForDisplay $ mixedAmountStripPrices m-    showamt a =-      (if isNegativeAmount a then color Dull Red else id) $-      printf (printf "%%%ds" width) $ showAmountWithoutPrice a-      where-        width = maximumDef 0 $ map (length . showAmount) as--mixedAmountStripPrices :: MixedAmount -> MixedAmount-mixedAmountStripPrices (Mixed as) = Mixed $ map (\a -> a{aprice=NoPrice}) as---- | Get the one-line string representation of a mixed amount, but without--- any \@ prices.-showMixedAmountOneLineWithoutPrice :: MixedAmount -> String-showMixedAmountOneLineWithoutPrice m = intercalate ", " $ map showAmountWithoutPrice as-    where-      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m-      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}---- | Colour version.-cshowMixedAmountOneLineWithoutPrice :: MixedAmount -> String-cshowMixedAmountOneLineWithoutPrice m = intercalate ", " $ map cshowAmountWithoutPrice as-    where-      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m-      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}---- | Canonicalise a mixed amount's display styles using the provided commodity style map.-canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount-canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as--mixedAmountValue :: Journal -> Day -> MixedAmount -> MixedAmount-mixedAmountValue j d (Mixed as) = Mixed $ map (amountValue j d) as---- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice.--- Has no effect on amounts without one. --- Does Decimal division, might be some rounding/irrational number issues.-mixedAmountTotalPriceToUnitPrice :: MixedAmount -> MixedAmount-mixedAmountTotalPriceToUnitPrice (Mixed as) = Mixed $ map amountTotalPriceToUnitPrice as------------------------------------------------------------------------------------- tests--tests_Amount = tests "Amount" [-   tests "Amount" [--     tests "costOfAmount" [-       costOfAmount (eur 1) `is` eur 1-      ,costOfAmount (eur 2){aprice=UnitPrice $ usd 2} `is` usd 4-      ,costOfAmount (eur 1){aprice=TotalPrice $ usd 2} `is` usd 2-      ,costOfAmount (eur (-1)){aprice=TotalPrice $ usd 2} `is` usd (-2)-    ]-  -    ,tests "isZeroAmount" [-       expect $ isZeroAmount amount-      ,expect $ isZeroAmount $ usd 0-    ]-  -    ,tests "negating amounts" [-       negate (usd 1) `is` (usd 1){aquantity= -1}-      ,let b = (usd 1){aprice=UnitPrice $ eur 2} in negate b `is` b{aquantity= -1}-    ]-  -    ,tests "adding amounts without prices" [-       (usd 1.23 + usd (-1.23)) `is` usd 0-      ,(usd 1.23 + usd (-1.23)) `is` usd 0-      ,(usd (-1.23) + usd (-1.23)) `is` usd (-2.46)-      ,sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] `is` usd 0-      -- highest precision is preserved-      ,asprecision (astyle $ sum [usd 1 `withPrecision` 1, usd 1 `withPrecision` 3]) `is` 3-      ,asprecision (astyle $ sum [usd 1 `withPrecision` 3, usd 1 `withPrecision` 1]) `is` 3-      -- adding different commodities assumes conversion rate 1-      ,expect $ isZeroAmount (usd 1.23 - eur 1.23)-    ]-  -    ,tests "showAmount" [-      showAmount (usd 0 + gbp 0) `is` "0"-    ]--  ]--  ,tests "MixedAmount" [--     tests "adding mixed amounts to zero, the commodity and amount style are preserved" [-      sum (map (Mixed . (:[]))-               [usd 1.25-               ,usd (-1) `withPrecision` 3-               ,usd (-0.25)-               ])-        `is` Mixed [usd 0 `withPrecision` 3]-    ]-  -    ,tests "adding mixed amounts with total prices" [-      sum (map (Mixed . (:[]))-       [usd 1 @@ eur 1-       ,usd (-2) @@ eur 1-       ])-        `is` Mixed [usd 1 @@ eur 1-                   ,usd (-2) @@ eur 1-                   ]-    ]-  -    ,tests "showMixedAmount" [-       showMixedAmount (Mixed [usd 1]) `is` "$1.00"-      ,showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00"-      ,showMixedAmount (Mixed [usd 0]) `is` "0"-      ,showMixedAmount (Mixed []) `is` "0"-      ,showMixedAmount missingmixedamt `is` ""-    ]-  -    ,tests "showMixedAmountWithoutPrice" $-      let a = usd 1 `at` eur 2 in -    [-        showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"-       ,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"-    ]-  -    ,tests "normaliseMixedAmount" [-       test "a missing amount overrides any other amounts" $ -        normaliseMixedAmount (Mixed [usd 1, missingamt]) `is` missingmixedamt-      ,test "unpriced same-commodity amounts are combined" $ -        normaliseMixedAmount (Mixed [usd 0, usd 2]) `is` Mixed [usd 2]-      ,test "amounts with same unit price are combined" $ -        normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1]-      ,test "amounts with different unit prices are not combined" $ -        normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]-      ,test "amounts with total prices are not combined" $-        normaliseMixedAmount (Mixed  [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]-    ]-  -    ,tests "normaliseMixedAmountSquashPricesForDisplay" [-       normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]-      ,expect $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay-        (Mixed [usd 10-               ,usd 10 @@ eur 7-               ,usd (-10)-               ,usd (-10) @@ eur 7-               ])-    ]+It may also have an 'AmountCost', representing this amount's per-unit+or total cost in a different commodity. If present, this is rendered like+so:++@+  EUR 2 \@ $1.50  (unit cost)+  EUR 2 \@\@ $3   (total cost)+@++A 'MixedAmount' is zero or more simple amounts, so can represent multiple+commodities; this is the type most often used:++@+  0+  $50 + EUR 3+  16h + $13.55 + AAPL 500 + 6 oranges+@++A mixed amount is always \"normalised\", it has no more than one amount+in each commodity and cost. When calling 'amounts' it will have no zero+amounts, or just a single zero amount and no other amounts.++Limited arithmetic with simple and mixed amounts is supported, best used+with similar amounts since it mostly ignores costss and commodity exchange rates.++-}++{-# LANGUAGE CPP  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE NamedFieldPuns #-}++module Hledger.Data.Amount (+  -- * Commodity+  showCommoditySymbol,+  isNonsimpleCommodityChar,+  quoteCommoditySymbolIfNeeded,++  -- * Amount+  -- ** arithmetic+  nullamt,+  missingamt,+  num,+  usd,+  eur,+  gbp,+  per,+  hrs,+  at,+  (@@),+  amountWithCommodity,+  amountCost,+  amountIsZero,+  amountLooksZero,+  divideAmount,+  multiplyAmount,+  invertAmount,+  -- ** styles+  amountstyle,+  canonicaliseAmount,+  styleAmount,+  amountSetStyles,+  amountStyleSetRounding,+  amountStylesSetRounding,+  amountUnstyled,+  commodityStylesFromAmounts,+  -- canonicalStyleFrom,+  getAmounts,++  -- ** rendering+  AmountFormat(..),+  defaultFmt,+  fullZeroFmt,+  noCostFmt,+  oneLineFmt,+  oneLineNoCostFmt,+  machineFmt,+  showAmount,+  showAmountWith,+  showAmountB,+  showAmountCost,+  showAmountCostB,+  showAmountCostBasis,+  showAmountCostBasisB,+  cshowAmount,+  showAmountWithZeroCommodity,+  showAmountDebug,+  showAmountWithoutCost,+  amountSetPrecision,+  amountSetPrecisionMin,+  amountSetPrecisionMax,+  withPrecision,+  amountSetFullPrecision,+  amountSetFullPrecisionUpTo,+  amountInternalPrecision,+  amountDisplayPrecision,+  defaultMaxPrecision,+  setAmountInternalPrecision,+  withInternalPrecision,+  setAmountDecimalPoint,+  withDecimalPoint,+  amountStripCost,++  -- * MixedAmount+  nullmixedamt,+  missingmixedamt,+  isMissingMixedAmount,+  mixed,+  mixedAmount,+  maAddAmount,+  maAddAmounts,+  amounts,+  amountsRaw,+  amountsPreservingZeros,+  maCommodities,+  filterMixedAmount,+  filterMixedAmountByCommodity,+  mapMixedAmount,+  unifyMixedAmount,+  mixedAmountStripCosts,+  -- ** arithmetic+  mixedAmountCost,+  maNegate,+  maPlus,+  maMinus,+  maSum,+  divideMixedAmount,+  multiplyMixedAmount,+  averageMixedAmounts,+  sumAndAverageMixedAmounts,+  isNegativeAmount,+  isNegativeMixedAmount,+  mixedAmountIsZero,+  maIsZero,+  maIsNonZero,+  mixedAmountLooksZero,+  -- ** styles+  canonicaliseMixedAmount,+  styleMixedAmount,+  mixedAmountSetStyles,+  mixedAmountUnstyled,+  -- ** rendering+  showMixedAmount,+  showMixedAmountWith,+  showMixedAmountOneLine,+  showMixedAmountDebug,+  showMixedAmountWithoutCost,+  showMixedAmountOneLineWithoutCost,+  showMixedAmountElided,+  showMixedAmountWithZeroCommodity,+  showMixedAmountB,+  showMixedAmountLinesB,+  showMixedAmountLinesPartsB,+  wbToText,+  wbUnpack,+  mixedAmountSetPrecision,+  mixedAmountSetFullPrecision,+  mixedAmountSetFullPrecisionUpTo,+  mixedAmountSetPrecisionMin,+  mixedAmountSetPrecisionMax,++  -- * misc.+  tests_Amount+) where++import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..), (<|>))+import Control.Monad (foldM)+import Data.Char (isDigit)+import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo)+import Data.Default (Default(..))+import Data.Foldable (toList)+import Data.List (find, intercalate, intersperse, mapAccumL, partition)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import Data.Map.Strict qualified as M+import Data.Set qualified as S+import Data.Maybe (fromMaybe, isNothing)+import Data.Semigroup (Semigroup(..))+import Data.Text qualified as T+import Data.Text.Lazy.Builder qualified as TB+import Data.Word (Word8)+import Safe (headDef, lastDef, lastMay)+import System.Console.ANSI (Color(..),ColorIntensity(..))++import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), assertBool, testCase)++import Hledger.Data.Types+import Hledger.Utils (colorB, error', numDigitsInt, numDigitsInteger)+import Hledger.Utils.Text (textQuoteIfNeeded)+import Text.WideString (WideBuilder(..), wbFromText, wbToText, wbUnpack)+import Data.Functor ((<&>))+-- import Data.Function ((&))+-- import Hledger.Utils.Debug (dbg0)+++-- A 'Commodity' is a symbol representing a currency or some other kind of+-- thing we are tracking, and some display preferences that tell how to+-- display 'Amount's of the commodity - is the symbol on the left or right,+-- are thousands separated by comma, significant decimal places and so on.++-- | Show space-containing commodity symbols quoted, as they are in a journal.+showCommoditySymbol :: T.Text -> T.Text+showCommoditySymbol = textQuoteIfNeeded++-- characters that may not be used in a non-quoted commodity symbol+isNonsimpleCommodityChar :: Char -> Bool+isNonsimpleCommodityChar = liftA2 (||) isDigit isOther+  where+    otherChars = "-+.@*;\t\n \"{}=" :: T.Text+    isOther c = T.any (==c) otherChars++quoteCommoditySymbolIfNeeded :: T.Text -> T.Text+quoteCommoditySymbolIfNeeded s+  | T.any isNonsimpleCommodityChar s = "\"" <> s <> "\""+  | otherwise = s++-- | Formatting options available when displaying Amounts and MixedAmounts.+-- Similar to "AmountStyle" but lower level, not attached to amounts or commodities, and can override it in some ways.+-- See also hledger manual > "Amount formatting, parseability", which speaks of human, hledger, and machine output.+data AmountFormat = AmountFormat+  { displayCommodity        :: Bool       -- ^ Whether to display commodity symbols.+  , displayZeroCommodity    :: Bool       -- ^ Whether to display commodity symbols for zero Amounts.+  , displayCommodityOrder   :: Maybe [CommoditySymbol]+                                          -- ^ For a MixedAmount, an optional order in which to display the commodities.+                                          --   Also, causes 0s to be generated for any commodities which are not present+                                          --   (important for tabular reports).+  , displayDigitGroups      :: Bool       -- ^ Whether to display digit group marks (eg thousands separators)+  , displayForceDecimalMark :: Bool       -- ^ Whether to add a trailing decimal mark when there are no decimal digits +                                          --   and there are digit group marks, to disambiguate+  , displayOneLine          :: Bool       -- ^ Whether to display on one line.+  , displayMinWidth         :: Maybe Int  -- ^ Minimum width to pad to+  , displayMaxWidth         :: Maybe Int  -- ^ Maximum width to clip to+  , displayCost             :: Bool       -- ^ Whether to display Amounts' costs.+  , displayCostBasis        :: Bool       -- ^ Whether to display Amounts' cost basis (Ledger-style lot syntax).+  , displayColour           :: Bool       -- ^ Whether to ansi-colourise negative Amounts.+  , displayQuotes           :: Bool       -- ^ Whether to enclose complex symbols in quotes (normally true)+  } deriving (Show)++-- | By default, display amounts using @defaultFmt@ amount display options.+instance Default AmountFormat where def = defaultFmt++-- | Display amounts without colour, and with various other defaults.+defaultFmt :: AmountFormat+defaultFmt = AmountFormat {+    displayCommodity        = True+  , displayZeroCommodity    = False+  , displayCommodityOrder   = Nothing+  , displayDigitGroups      = True+  , displayForceDecimalMark = False+  , displayOneLine          = False+  , displayMinWidth         = Just 0+  , displayMaxWidth         = Nothing+  , displayCost             = True+  , displayCostBasis        = True+  , displayColour           = False+  , displayQuotes           = True+  }++-- | Like defaultFmt but show zero amounts with commodity symbol and styling, like non-zero amounts.+fullZeroFmt :: AmountFormat+fullZeroFmt = defaultFmt{displayZeroCommodity=True}++-- | Like defaultFmt but don't show costs or cost basis.+noCostFmt :: AmountFormat+noCostFmt = defaultFmt{displayCost=False, displayCostBasis=False}++-- | Like defaultFmt but display all amounts on one line.+oneLineFmt :: AmountFormat+oneLineFmt = defaultFmt{displayOneLine=True}++-- | Like noCostFmt but display all amounts on one line.+oneLineNoCostFmt :: AmountFormat+oneLineNoCostFmt = noCostFmt{displayOneLine=True}++-- | A (slightly more) machine-readable amount format; like oneLineNoCostFmt but don't show digit group marks.+machineFmt :: AmountFormat+machineFmt = oneLineNoCostFmt{displayDigitGroups=False}++-------------------------------------------------------------------------------+-- Amount arithmetic++instance Num Amount where+    abs a@Amount{aquantity=q}    = a{aquantity=abs q}+    signum a@Amount{aquantity=q} = a{aquantity=signum q}+    fromInteger i                = nullamt{aquantity=fromInteger i}+    negate                       = transformAmount negate+    (+)                          = similarAmountsOp (+)+    (-)                          = similarAmountsOp (-)+    (*)                          = similarAmountsOp (*)++-- | The empty simple amount - a zero with no commodity symbol or cost+-- and the default amount display style.+nullamt :: Amount+nullamt = Amount{acommodity="", aquantity=0, astyle=amountstyle, acost=Nothing, acostbasis=Nothing}++-- | A special amount used as a marker, meaning+-- "no explicit amount provided here, infer it when needed".+-- It is nullamt with commodity symbol "AUTO".+missingamt :: Amount+missingamt = nullamt{acommodity="AUTO"}++-- Handy amount constructors for tests.+-- usd/eur/gbp round their argument to a whole number of pennies/cents.+-- XXX these are a bit clashy+num n = nullamt{acommodity="",  aquantity=n}+hrs n = nullamt{acommodity="h", aquantity=n,           astyle=amountstyle{asprecision=Precision 2, ascommodityside=R}}+usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}}+per n = nullamt{acommodity="%", aquantity=n,           astyle=amountstyle{asprecision=Precision 1, ascommodityside=R, ascommodityspaced=True}}+amt `at` costamt = amt{acost=Just $ UnitCost costamt}+amt @@ costamt = amt{acost=Just $ TotalCost costamt}++-- | Apply a binary arithmetic operator to two amounts, which should+-- be in the same commodity if non-zero (warning, this is not checked).+-- A zero result keeps the commodity of the second amount.+-- The result's display style is that of the second amount, with+-- precision set to the highest of either amount.+-- Costs are ignored and discarded.+-- Remember: the caller is responsible for ensuring both amounts have the same commodity.+similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount+similarAmountsOp op Amount{acommodity=_,  aquantity=q1, astyle=AmountStyle{asprecision=p1}}+                    Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} =+   -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug)+   nullamt{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}+  --  c1==c2 || q1==0 || q2==0 =+  --  otherwise = error' "tried to do simple arithmetic with amounts in different commodities"++-- | Convert an amount to the specified commodity, ignoring and discarding+-- any costs and assuming an exchange rate of 1.+amountWithCommodity :: CommoditySymbol -> Amount -> Amount+amountWithCommodity c a = a{acommodity=c, acost=Nothing}++-- | Convert a amount to its total cost in another commodity,+-- using its attached cost amount if it has one.  Notes:+--+-- - cost amounts must be MixedAmounts with exactly one component Amount+--   (or there will be a runtime error XXX)+--+-- - cost amounts should be positive in the Journal+--   (though this is currently not enforced)+--+amountCost :: Amount -> Amount+amountCost a@Amount{aquantity=q, acost=mp} =+    case mp of+      Nothing                                  -> a+      Just (UnitCost  p@Amount{aquantity=pq}) -> p{aquantity=pq * q}+      Just (TotalCost p@Amount{aquantity=pq}) -> p{aquantity=pq}++-- | Strip all costs from an Amount+amountStripCost :: Amount -> Amount+amountStripCost a = a{acost=Nothing}++-- | Apply a function to an amount's quantity (and its total cost, if it has one).+transformAmount :: (Quantity -> Quantity) -> Amount -> Amount+transformAmount f a@Amount{aquantity=q,acost=p} = a{aquantity=f q, acost=f' <$> p}+  where+    f' (TotalCost a1@Amount{aquantity=pq}) = TotalCost a1{aquantity = f pq}+    f' p' = p'++-- | Divide an amount's quantity (and total cost, if any) by some number.+divideAmount :: Quantity -> Amount -> Amount+divideAmount n = transformAmount (/n)++-- | Multiply an amount's quantity (and its total cost, if it has one) by a constant.+multiplyAmount :: Quantity -> Amount -> Amount+multiplyAmount n = transformAmount (*n)++-- | Invert an amount (replace its quantity q with 1/q).+-- The amount's transacted price, if any, is not changed.+-- An amount with zero quantity is left unchanged.+invertAmount :: Amount -> Amount+invertAmount a@Amount{aquantity=0} = a+invertAmount a@Amount{aquantity=q} = a{aquantity=1/q}++-- | Is this amount negative ? The cost is ignored.+isNegativeAmount :: Amount -> Bool+isNegativeAmount Amount{aquantity=q} = q < 0++-- | Round an Amount's Quantity (internally) to match its display precision. +-- If that is unset or NaturalPrecision, this does nothing.+amountRoundedQuantity :: Amount -> Quantity+amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=mp}} = case mp of+    NaturalPrecision -> q+    Precision p      -> roundTo p q++-- | Apply a test to both an Amount and its total cost, if it has one.+testAmountAndTotalCost :: (Amount -> Bool) -> Amount -> Bool+testAmountAndTotalCost f amt = case acost amt of+    Just (TotalCost cost) -> f amt && f cost+    _                       -> f amt++-- | Do this Amount and (and its total cost, if it has one) appear to be zero+-- when rendered with its display precision ?+-- The display precision should usually have a specific value here;+-- if unset, it will be treated like NaturalPrecision.+amountLooksZero :: Amount -> Bool+amountLooksZero = testAmountAndTotalCost looksZero+  where+    looksZero Amount{aquantity=Decimal e q, astyle=AmountStyle{asprecision=p}} = case p of+        Precision d      -> if e > d then abs q <= 5*10^(e-d-1) else q == 0+        NaturalPrecision -> q == 0++-- | Is this Amount (and its total cost, if it has one) exactly zero, ignoring its display precision ?+amountIsZero :: Amount -> Bool+amountIsZero = testAmountAndTotalCost (\Amount{aquantity=Decimal _ q} -> q == 0)++-- | Does this amount's internal Decimal representation have the+-- maximum number of digits, suggesting that it probably is+-- representing an infinite decimal ?+amountHasMaxDigits :: Amount -> Bool+amountHasMaxDigits = (>= 255) . numDigitsInteger . decimalMantissa . aquantity+-- XXX this seems not always right. Eg:+-- ghci> let n = 100 / (3.0 :: Decimal)+-- decimalPlaces n+-- 255+-- numDigitsInteger $ decimalMantissa n+-- 257+++-- | Set an amount's display precision, flipped.+withPrecision :: Amount -> AmountPrecision -> Amount+withPrecision = flip amountSetPrecision++-- | Set an amount's display precision.+amountSetPrecision :: AmountPrecision -> Amount -> Amount+amountSetPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}}++-- | Ensure an amount's display precision is at least the given minimum precision.+-- Always sets an explicit Precision.+amountSetPrecisionMin :: Word8 -> Amount -> Amount+amountSetPrecisionMin minp a = amountSetPrecision p a+  where p = Precision $ max minp (amountDisplayPrecision a)++-- | Ensure an amount's display precision is at most the given maximum precision.+-- Always sets an explicit Precision.+amountSetPrecisionMax :: Word8 -> Amount -> Amount+amountSetPrecisionMax maxp a = amountSetPrecision p a+  where p = Precision $ min maxp (amountDisplayPrecision a)++-- | Increase an amount's display precision, if needed, to enough decimal places+-- to show it exactly (showing all significant decimal digits, without trailing zeros).+-- If the amount's display precision is unset, it will be treated as precision 0.+amountSetFullPrecision :: Amount -> Amount+amountSetFullPrecision a = amountSetPrecision p a+  where+    p                = max displayprecision naturalprecision+    displayprecision = asprecision $ astyle a+    naturalprecision = Precision $ amountInternalPrecision a+-- XXX Is that last sentence correct ?+-- max (Precision n) NaturalPrecision is NaturalPrecision.+-- Would this work instead ?+-- amountSetFullPrecision a = amountSetPrecision (Precision p) a+--   where p = max (amountDisplayPrecision a) (amountInternalPrecision a)+++-- | We often want to display "infinite decimal" amounts rounded to some readable+-- number of digits, while still displaying amounts with a large but "non infinite"+-- number of decimal digits (eg 10 or 100 or 200 digits) in full.+-- This helper is like amountSetFullPrecision, but with some refinements:+--+-- 1. A maximum display precision can be specified, setting a hard upper limit.+--+-- 2. If no limit is specified, and the internal precision is the maximum (255),+-- indicating an infinite decimal, display precision is set to a smaller default (8).+--+-- This function always sets an explicit display precision (ie, Precision n).+--+amountSetFullPrecisionUpTo :: Maybe Word8 -> Amount -> Amount+amountSetFullPrecisionUpTo mmaxp a = amountSetPrecision (Precision p) a+  where+    p = case mmaxp of+      Just maxp -> min maxp $ max disp intp+      Nothing   -> if amountHasMaxDigits a then defaultMaxPrecision else max disp intp+      where+        disp = amountDisplayPrecision a+        intp = amountInternalPrecision a++-- | The fallback display precision used when showing amounts+-- representing an infinite decimal.+defaultMaxPrecision :: Word8+defaultMaxPrecision = 8++-- | How many internal decimal digits are stored for this amount ?+amountInternalPrecision :: Amount -> Word8+amountInternalPrecision = decimalPlaces . normalizeDecimal . aquantity++-- | How many decimal digits will be displayed for this amount ?+amountDisplayPrecision :: Amount -> Word8+amountDisplayPrecision a =+  case asprecision $ astyle a of+    Precision n      -> n+    NaturalPrecision -> amountInternalPrecision a++-- | Set an amount's internal decimal precision as well as its display precision.+-- This rounds or pads its Decimal quantity to the specified number of decimal places.+-- Rounding is done with Data.Decimal's default roundTo function:+-- "If the value ends in 5 then it is rounded to the nearest even value (Banker's Rounding)".+setAmountInternalPrecision :: Word8 -> Amount -> Amount+setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{+   aquantity=roundTo p q+  ,astyle=s{asprecision=Precision p}+  }++-- | setAmountInternalPrecision with arguments flipped.+withInternalPrecision :: Amount -> Word8 -> Amount+withInternalPrecision = flip setAmountInternalPrecision++-- Amount display styles++-- v1+{-# DEPRECATED canonicaliseAmount "please use styleAmounts instead" #-}+canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount+canonicaliseAmount = styleAmounts++-- v2+{-# DEPRECATED styleAmount "please use styleAmounts instead" #-}+styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount+styleAmount = styleAmounts++-- v3+{-# DEPRECATED amountSetStyles "please use styleAmounts instead" #-}+amountSetStyles :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount+amountSetStyles = styleAmounts++-- v4+instance HasAmounts Amount where+  -- | Given some commodity display styles, find and apply the appropriate one to this amount,+  -- and its cost amount if any (and stop; we assume costs don't have costs).+  -- Display precision will be applied (or not) as specified by the style's rounding strategy,+  -- except that costs' precision is never changed (costs are often recorded inexactly,+  -- so we don't want to imply greater precision than they were recorded with).+  -- If no style is found for an amount, it is left unchanged.+  styleAmounts styles a@Amount{aquantity=qty, acommodity=comm, astyle=oldstyle, acost=mcost0} =+    a{astyle=newstyle, acost=mcost1}+    where+      newstyle = mknewstyle False qty oldstyle comm ++      mcost1 = case mcost0 of+        Nothing -> Nothing+        Just (UnitCost  ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ UnitCost  ca{astyle=mknewstyle True cq cs ccomm}+        Just (TotalCost ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ TotalCost ca{astyle=mknewstyle True cq cs ccomm}++      mknewstyle :: Bool -> Quantity -> AmountStyle -> CommoditySymbol -> AmountStyle+      mknewstyle iscost oldq olds com =+        case M.lookup com styles of+          Just s  -> +            -- dbg0 "new      style" $ +            amountStyleApplyWithRounding iscost oldq +              (+                -- dbg0 "applying style"+                s)+              (+                -- dbg0 "old      style"+                olds)+          Nothing -> olds++-- | Get an amount and its attached cost amount if any. Returns one or two amounts.+getAmounts :: Amount -> [Amount]+getAmounts a@Amount{acost} = a : case acost of+  Nothing            -> []+  Just (UnitCost  c) -> [c]+  Just (TotalCost c) -> [c]++-- AmountStyle helpers++-- | Replace one AmountStyle with another, but don't just replace the display precision;+-- update that in one of several ways as selected by the new style's "rounding strategy":+--+-- NoRounding - keep the precision unchanged+--+-- SoftRounding -+--+--  if either precision is NaturalPrecision, use NaturalPrecision;+--+--  if the new precision is greater than the old, use the new (adds decimal zeros);+--+--  if the new precision is less than the old, use as close to the new as we can get+--    without dropping (more) non-zero digits (drops decimal zeros).+--+--  for a cost amount, keep the precision unchanged+--+-- HardRounding -+--+--  for a posting amount, use the new precision (may truncate significant digits);+--+--  for a cost amount, keep the precision unchanged+--+-- AllRounding -+--+--  for both posting and cost amounts, do hard rounding.+--+-- Arguments:+--+--  whether this style is for a posting amount or a cost amount,+--+--  the amount's decimal quantity (for inspecting its internal representation), +--+--  the new style, +--+--  the old style.+--+amountStyleApplyWithRounding :: Bool -> Quantity -> AmountStyle -> AmountStyle -> AmountStyle+amountStyleApplyWithRounding iscost q news@AmountStyle{asprecision=newp, asrounding=newr} AmountStyle{asprecision=oldp} =+  case newr of+    NoRounding   -> news{asprecision=oldp}+    SoftRounding -> news{asprecision=if iscost then oldp else newp'}+      where+        newp' = case (newp, oldp) of+          (Precision new, Precision old) ->+            if new >= old+            then Precision new+            else Precision $ max (min old internal) new+              where internal = decimalPlaces $ normalizeDecimal q+          _ -> NaturalPrecision+    HardRounding -> news{asprecision=if iscost then oldp else newp}+    AllRounding  -> news++-- | Set this amount style's rounding strategy when it is being applied to amounts.+amountStyleSetRounding :: Rounding -> AmountStyle -> AmountStyle+amountStyleSetRounding r as = as{asrounding=r}++-- | Set these amount styles' rounding strategy when they are being applied to amounts.+amountStylesSetRounding :: Rounding -> M.Map CommoditySymbol AmountStyle -> M.Map CommoditySymbol AmountStyle+amountStylesSetRounding r = M.map (amountStyleSetRounding r)++-- | Default amount style+amountstyle = AmountStyle L False Nothing (Just '.') (Precision 0) NoRounding++-- | Reset this amount's display style to the default.+amountUnstyled :: Amount -> Amount+amountUnstyled a = a{astyle=amountstyle}++-- | 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 =+  Right . foldr (\a -> M.insertWith canonicalStyle (acommodity a) (astyle a)) mempty++-- -- | Given a list of amount styles (assumed to be from parsed amounts+-- -- in a single commodity), in parse order, choose a canonical style.+-- canonicalStyleFrom :: [AmountStyle] -> AmountStyle+-- canonicalStyleFrom = foldl' canonicalStyle amountstyle++-- TODO: should probably detect and report inconsistencies here.+-- Though, we don't have the info for a good error message, so maybe elsewhere.++-- | Given a pair of AmountStyles, choose a canonical style.+-- This is:+-- the general style of the first amount,+-- with the first digit group style seen,+-- with the maximum precision of all.+canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle+canonicalStyle a b = a{asprecision = prec, asdecimalmark = decmark, asdigitgroups = mgrps}+ where+  -- precision is maximum of all precisions+  prec = max (asprecision a) (asprecision b)+  -- identify the digit group mark (& group sizes)+  mgrps = asdigitgroups a <|> asdigitgroups b+  -- 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 _ -> Just defdecmark+    Nothing -> asdecimalmark a <|> asdecimalmark b <|> Just defdecmark+++-- | Set (or clear) an amount's display decimal point.+setAmountDecimalPoint :: Maybe Char -> Amount -> Amount+setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalmark=mc} }++-- | Set (or clear) an amount's display decimal point, flipped.+withDecimalPoint :: Amount -> Maybe Char -> Amount+withDecimalPoint = flip setAmountDecimalPoint++-- Amount rendering++-- | Render an amount using its display style and the default amount format.+-- Zero-equivalent amounts  are shown as just \"0\".+-- The special "missing" amount is shown as the empty string.+showAmount :: Amount -> String+showAmount = wbUnpack . showAmountB defaultFmt++-- | Like showAmount but uses the given amount format.+showAmountWith :: AmountFormat -> Amount -> String+showAmountWith fmt = wbUnpack . showAmountB fmt++-- | Render an amount using its display style and the given amount format, as a builder for efficiency.+-- (This can be converted to a Text with wbToText or to a String with wbUnpack).+-- The special "missing" amount is displayed as the empty string. +showAmountB :: AmountFormat -> Amount -> WideBuilder+showAmountB _ Amount{acommodity="AUTO"} = mempty+showAmountB+  afmt@AmountFormat{displayCommodity, displayZeroCommodity, displayDigitGroups+                   ,displayForceDecimalMark, displayCost, displayCostBasis, displayColour, displayQuotes}+  a@Amount{astyle=style} =+    color $ case ascommodityside style of+      L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> cost <> costbasis+      R -> quantity' <> (if displayCommodity then space <> wbFromText comm else mempty) <> cost <> costbasis+  where+    color = if displayColour && isNegativeAmount a then colorB Dull Red else id+    quantity = showAmountQuantity displayForceDecimalMark $+      if displayDigitGroups then a else a{astyle=(astyle a){asdigitgroups=Nothing}}+    (quantity', comm)+      | amountLooksZero a && not displayZeroCommodity = (WideBuilder (TB.singleton '0') 1, "")+      | otherwise = (quantity, (if displayQuotes then quoteCommoditySymbolIfNeeded else id) $ acommodity a)+    space = if not (T.null comm) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty+    cost = if displayCost then showAmountCostB afmt a else mempty+    costbasis = if displayCostBasis then showAmountCostBasisB afmt a else mempty++-- Show an amount's cost as @ UNITCOST or @@ TOTALCOST, plus a leading space, or "" if there's no cost.+showAmountCost :: Amount -> String+showAmountCost = wbUnpack . showAmountCostB defaultFmt++-- showAmountCost, efficient builder version.+showAmountCostB :: AmountFormat -> Amount -> WideBuilder+showAmountCostB afmt amt = case acost amt of+  Nothing             -> mempty+  Just (UnitCost  pa) -> WideBuilder (TB.fromString " @ ")  3 <> showAmountB afmt pa+  Just (TotalCost pa) -> WideBuilder (TB.fromString " @@ ") 4 <> showAmountB afmt (sign pa)+  where sign = if aquantity amt < 0 then negate else id++showAmountCostDebug :: Maybe AmountCost -> String+showAmountCostDebug Nothing                = ""+showAmountCostDebug (Just (UnitCost pa))  = "@ "  ++ showAmountDebug pa+showAmountCostDebug (Just (TotalCost pa)) = "@@ " ++ showAmountDebug pa++-- | Show an amount's cost basis as Ledger-style lot syntax: {LOTCOST} [LOTDATE] (LOTNOTE).+showAmountCostBasis :: Amount -> String+showAmountCostBasis = wbUnpack . showAmountCostBasisB defaultFmt++-- showAmountCostBasis, efficient builder version.+showAmountCostBasisB :: AmountFormat -> Amount -> WideBuilder+showAmountCostBasisB afmt amt = case acostbasis amt of+  Nothing -> mempty+  Just CostBasis{cbCost, cbDate, cbLabel} ->+    lotcost <> lotdate <> lotnote+    where+      lotcost = case cbCost of+        Nothing -> mempty+        Just a  -> WideBuilder (TB.fromString " {") 2 <> showAmountB afmt a <> WideBuilder (TB.singleton '}') 1+      lotdate = case cbDate of+        Nothing -> mempty+        Just d  -> WideBuilder (TB.fromString " [") 2 <> wbFromText (T.pack $ show d) <> WideBuilder (TB.singleton ']') 1+      lotnote = case cbLabel of+        Nothing -> mempty+        Just l  -> WideBuilder (TB.fromString " (") 2 <> wbFromText l <> WideBuilder (TB.singleton ')') 1++-- | Colour version. For a negative amount, adds ANSI codes to change the colour,+-- currently to hard-coded red.+--+-- > cshowAmount = wbUnpack . showAmountB def{displayColour=True}+cshowAmount :: Amount -> String+cshowAmount = wbUnpack . showAmountB def{displayColour=True}++-- | Get the string representation of an amount, without any \@ cost.+--+-- > showAmountWithoutCost = wbUnpack . showAmountB noCostFmt+showAmountWithoutCost :: Amount -> String+showAmountWithoutCost = wbUnpack . showAmountB noCostFmt++-- | Like showAmount, but show a zero amount's commodity if it has one.+--+-- > showAmountWithZeroCommodity = wbUnpack . showAmountB defaultFmt{displayZeryCommodity=True}+showAmountWithZeroCommodity :: Amount -> String+showAmountWithZeroCommodity = wbUnpack . showAmountB defaultFmt{displayZeroCommodity=True}++-- | Get a string representation of an amount for debugging,+-- appropriate to the current debug level. 9 shows maximum detail.+showAmountDebug :: Amount -> String+showAmountDebug Amount{acommodity="AUTO"} = "(missing)"+showAmountDebug Amount{..} =+      "Amount {acommodity=" ++ show acommodity ++ ", aquantity=" ++ show aquantity+   ++ ", acost=" ++ showAmountCostDebug acost ++ ", astyle=" ++ show astyle ++ "}"++-- | Get a Text Builder for the string representation of the number part of of an amount,+-- using the display settings from its commodity. Also returns the width of the number.+-- With a true first argument, if there are no decimal digits but there are digit group separators,+-- it shows the amount with a trailing decimal mark to help disambiguate it for parsing.+showAmountQuantity :: Bool -> Amount -> WideBuilder+showAmountQuantity disambiguate amt@Amount{astyle=AmountStyle{asdecimalmark=mdec, asdigitgroups=mgrps}} =+    signB <> intB <> fracB+  where+    Decimal decplaces mantissa = amountRoundedQuantity amt+    numtxt = T.pack . show $ abs mantissa+    numlen = T.length numtxt+    intLen = max 1 $ numlen - fromIntegral decplaces+    dec = fromMaybe '.' mdec+    numtxtwithzero = T.replicate (fromIntegral decplaces + 1 - numlen) "0" <> numtxt+    (intPart, fracPart) = T.splitAt intLen numtxtwithzero+    intB = applyDigitGroupStyle mgrps intLen $ if decplaces == 0 then numtxt else intPart+    signB = if mantissa < 0 then WideBuilder (TB.singleton '-') 1 else mempty+    fracB = if decplaces > 0 || (isshowingdigitgroupseparator && disambiguate)+      then WideBuilder (TB.singleton dec <> TB.fromText fracPart) (1 + fromIntegral decplaces)+      else mempty+      where+        isshowingdigitgroupseparator = case mgrps of+          Just (DigitGroups _ (rightmostgrplen:_)) -> intLen > fromIntegral rightmostgrplen+          _ -> False++-- | Given an integer as text, and its length, apply the given DigitGroupStyle,+-- inserting digit group separators between digit groups where appropriate.+-- Returns a Text builder and the number of digit group separators used.+applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder+applyDigitGroupStyle Nothing                       l s = WideBuilder (TB.fromText s) l+applyDigitGroupStyle (Just (DigitGroups _ []))     l s = WideBuilder (TB.fromText s) l+applyDigitGroupStyle (Just (DigitGroups c (g0:gs0))) l0 s0 = addseps (g0:|gs0) (toInteger l0) s0+  where+    addseps (g1:|gs1) l1 s1+        | l2 > 0    = addseps gs2 l2 rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g1 + 1)+        | otherwise = WideBuilder (TB.fromText s1) (fromInteger l1)+      where+        (rest, part) = T.splitAt (fromInteger l2) s1+        gs2 = fromMaybe (g1:|[]) $ nonEmpty gs1+        l2 = l1 - toInteger g1++-------------------------------------------------------------------------------+-- MixedAmount++instance Semigroup MixedAmount where+  (<>) = maPlus+  sconcat = maSum+  stimes n = multiplyMixedAmount (fromIntegral n)++instance Monoid MixedAmount where+  mempty = nullmixedamt+  mconcat = maSum++instance Num MixedAmount where+    fromInteger = mixedAmount . fromInteger+    negate = maNegate+    (+)    = maPlus+    (*)    = error' "error, mixed amounts do not support multiplication" -- PARTIAL:+    abs    = mapMixedAmount (\amt -> amt { aquantity = abs (aquantity amt)})+    signum = error' "error, mixed amounts do not support signum"++-- | Calculate the key used to store an Amount within a MixedAmount.+amountKey :: Amount -> MixedAmountKey+amountKey amt@Amount{acommodity=c} = case acost amt of+    Nothing             -> MixedAmountKeyNoCost    c+    Just (TotalCost p) -> MixedAmountKeyTotalCost c (acommodity p)+    Just (UnitCost  p) -> MixedAmountKeyUnitCost  c (acommodity p) (aquantity p)++-- | The empty mixed amount.+nullmixedamt :: MixedAmount+nullmixedamt = Mixed mempty++-- | A special mixed amount used as a marker, meaning+-- "no explicit amount provided here, infer it when needed".+missingmixedamt :: MixedAmount+missingmixedamt = mixedAmount missingamt++-- | Does this MixedAmount include the "missing amount" marker ?+-- Note: currently does not test for equality with missingmixedamt,+-- instead it looks for missingamt among the Amounts.+-- missingamt should always be alone, but detect it even if not.+isMissingMixedAmount :: MixedAmount -> Bool+isMissingMixedAmount (Mixed ma) = amountKey missingamt `M.member` ma++-- | Convert amounts in various commodities into a mixed amount.+mixed :: Foldable t => t Amount -> MixedAmount+mixed = maAddAmounts nullmixedamt++-- | Create a MixedAmount from a single Amount.+mixedAmount :: Amount -> MixedAmount+mixedAmount a = Mixed $ M.singleton (amountKey a) a++-- | Add an Amount to a MixedAmount, normalising the result.+-- Amounts with different costs are kept separate.+maAddAmount :: MixedAmount -> Amount -> MixedAmount+maAddAmount (Mixed ma) a = Mixed $ M.insertWith sumSimilarAmountsUsingFirstCost (amountKey a) a ma++-- | Add a collection of Amounts to a MixedAmount, normalising the result.+-- Amounts with different costs are kept separate.+maAddAmounts :: Foldable t => MixedAmount -> t Amount -> MixedAmount+maAddAmounts = foldl' maAddAmount++-- | Negate mixed amount's quantities (and total costs, if any).+maNegate :: MixedAmount -> MixedAmount+maNegate = transformMixedAmount negate++-- | Sum two MixedAmount, keeping the cost of the first if any.+-- Amounts with different costs are kept separate (since 2021).+maPlus :: MixedAmount -> MixedAmount -> MixedAmount+maPlus (Mixed as) (Mixed bs) = Mixed $ M.unionWith sumSimilarAmountsUsingFirstCost as bs++-- | Subtract a MixedAmount from another.+-- Amounts with different costs are kept separate.+maMinus :: MixedAmount -> MixedAmount -> MixedAmount+maMinus a = maPlus a . maNegate++-- | Sum a collection of MixedAmounts.+-- Amounts with different costs are kept separate.+maSum :: Foldable t => t MixedAmount -> MixedAmount+maSum = foldl' maPlus nullmixedamt++-- | Divide a mixed amount's quantities (and total costs, if any) by a constant.+divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount+divideMixedAmount n = transformMixedAmount (/n)++-- | Multiply a mixed amount's quantities (and total costs, if any) by a constant.+multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount+multiplyMixedAmount n = transformMixedAmount (*n)++-- | Apply a function to a mixed amount's quantities (and its total costs, if it has any).+transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount+transformMixedAmount f = mapMixedAmountUnsafe (transformAmount f)++-- | Calculate the average of some mixed amounts.+averageMixedAmounts :: Foldable f => f MixedAmount -> MixedAmount+averageMixedAmounts = snd . sumAndAverageMixedAmounts++-- | Calculate the sum and average of some mixed amounts.+sumAndAverageMixedAmounts :: Foldable f => f MixedAmount -> (MixedAmount, MixedAmount)+sumAndAverageMixedAmounts amts = (total, fromIntegral nAmts `divideMixedAmount` total)+  where+    (nAmts, total) = foldl' (\(n, a) b -> (n + 1, maPlus a b)) (0 :: Int, nullmixedamt) amts++-- | Is this mixed amount negative, if we can tell that unambiguously?+-- Ie when normalised, are all individual commodity amounts negative ?+isNegativeMixedAmount :: MixedAmount -> Maybe Bool+isNegativeMixedAmount m =+  case amounts $ mixedAmountStripCosts m of+    []  -> Just False+    [a] -> Just $ isNegativeAmount a+    as | all isNegativeAmount as -> Just True+    as | not (any isNegativeAmount as) -> Just False+    _ -> Nothing  -- multiple amounts with different signs++-- | Does this mixed amount appear to be zero when rendered with its display precision?+-- See amountLooksZero.+mixedAmountLooksZero :: MixedAmount -> Bool+mixedAmountLooksZero (Mixed ma) = all amountLooksZero ma++-- | Is this mixed amount exactly zero, ignoring its display precision?+-- See amountIsZero.+mixedAmountIsZero :: MixedAmount -> Bool+mixedAmountIsZero (Mixed ma) = all amountIsZero ma++-- | Is this mixed amount exactly zero, ignoring its display precision?+--+-- A convenient alias for mixedAmountIsZero.+maIsZero :: MixedAmount -> Bool+maIsZero = mixedAmountIsZero++-- | Is this mixed amount non-zero, ignoring its display precision?+--+-- A convenient alias for not . mixedAmountIsZero.+maIsNonZero :: MixedAmount -> Bool+maIsNonZero = not . mixedAmountIsZero++-- | Get a mixed amount's component amounts, with some cleanups.+-- The following descriptions are old and possibly wrong:+--+-- * amounts in the same commodity are combined unless they have different costs or total costs+--+-- * multiple zero amounts, all with the same non-null commodity, are replaced by just the last of them, preserving the commodity and amount style (all but the last zero amount are discarded)+--+-- * multiple zero amounts with multiple commodities, or no commodities, are replaced by one commodity-less zero amount+--+-- * an empty amount list is replaced by one commodity-less zero amount+--+-- * the special "missing" mixed amount remains unchanged+--+amounts :: MixedAmount -> [Amount]+amounts (Mixed ma)+  | isMissingMixedAmount (Mixed ma) = [missingamt]+  | M.null nonzeros                 = [newzero]+  | otherwise                       = toList nonzeros+  where+    newzero = fromMaybe nullamt $ find (not . T.null . acommodity) zeros+    (zeros, nonzeros) = M.partition amountIsZero ma++-- | Get a mixed amount's component amounts, with some cleanups.+-- This is a new version of @amounts@, with updated descriptions+-- and optimised for @print@ to show commodityful zeros.+--+-- * If it contains the "missing amount" marker, only that is returned+--   (discarding any additional amounts).+--+-- * Or if it contains any non-zero amounts, only those are returned+--   (discarding any zeroes).+--+-- * Or if it contains any zero amounts (possibly more than one,+--   possibly in different commodities), all of those are returned.+--+-- * Otherwise the null amount is returned.+--+amountsPreservingZeros :: MixedAmount -> [Amount]+amountsPreservingZeros (Mixed ma)+  | isMissingMixedAmount (Mixed ma) = [missingamt]+  | not $ M.null nonzeros           = toList nonzeros+  | not $ M.null zeros              = toList zeros+  | otherwise                       = [nullamt]+  where+    (zeros, nonzeros) = M.partition amountIsZero ma++-- | Get a mixed amount's component amounts without normalising zero and missing+-- amounts. This is used for JSON serialisation, so the order is important. In+-- particular, we want the Amounts given in the order of the MixedAmountKeys,+-- i.e. lexicographically first by commodity, then by cost commodity, then by+-- unit cost from most negative to most positive.+amountsRaw :: MixedAmount -> [Amount]+amountsRaw (Mixed ma) = toList ma++-- | Get this mixed amount's commodities as a set.+-- Returns an empty set if there are no amounts.+maCommodities :: MixedAmount -> S.Set CommoditySymbol+maCommodities = S.fromList . fmap acommodity . amounts'+  where amounts' ma@(Mixed m) = if M.null m then [] else amounts ma++-- | Unify a MixedAmount to a single commodity value if possible.+-- This consolidates amounts of the same commodity and discards zero+-- amounts; but this one insists on simplifying to a single commodity,+-- and will return Nothing if this is not possible.+unifyMixedAmount :: MixedAmount -> Maybe Amount+unifyMixedAmount = foldM combine 0 . amounts+  where+    combine amt result+      | amountIsZero amt                    = Just result+      | amountIsZero result                 = Just amt+      | acommodity amt == acommodity result = Just $ amt + result+      | otherwise                           = Nothing++-- | Sum same-commodity amounts in a lossy way, applying the first+-- cost to the result and discarding any other costs. Only used as a+-- rendering helper.+sumSimilarAmountsUsingFirstCost :: Amount -> Amount -> Amount+sumSimilarAmountsUsingFirstCost a b = (a + b){acost=p}+  where+    p = case (acost a, acost b) of+        (Just (TotalCost ap), Just (TotalCost bp))+          -> Just . TotalCost $ ap{aquantity = aquantity ap + aquantity bp }+        _ -> acost a++-- | Filter a mixed amount's component amounts by a predicate.+filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount+filterMixedAmount p (Mixed ma) = Mixed $ M.filter p ma++-- | Return an unnormalised MixedAmount containing just the amounts in the+-- requested commodity from the original mixed amount.+--+-- The result will contain at least one Amount of the requested commodity,+-- even if the original mixed amount did not (with quantity zero in that case,+-- and this would be discarded when the mixed amount is next normalised).+--+-- The result can contain more than one Amount of the requested commodity,+-- eg because there were several with different costs,+-- or simply because the original mixed amount was was unnormalised.+--+filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount+filterMixedAmountByCommodity c (Mixed ma)+  | M.null ma' = mixedAmount nullamt{acommodity=c}+  | otherwise  = Mixed ma'+  where ma' = M.filter ((c==) . acommodity) ma++-- | Apply a transform to a mixed amount's component 'Amount's.+mapMixedAmount :: (Amount -> Amount) -> MixedAmount -> MixedAmount+mapMixedAmount f (Mixed ma) = mixed . map f $ toList ma++-- | Apply a transform to a mixed amount's component 'Amount's, which does not+-- affect the key of the amount (i.e. doesn't change the commodity, cost+-- commodity, or unit cost amount). This condition is not checked.+mapMixedAmountUnsafe :: (Amount -> Amount) -> MixedAmount -> MixedAmount+mapMixedAmountUnsafe f (Mixed ma) = Mixed $ M.map f ma  -- Use M.map instead of fmap to maintain strictness++-- | Convert all component amounts to cost where possible (see amountCost).+mixedAmountCost :: MixedAmount -> MixedAmount+mixedAmountCost (Mixed ma) =+    foldl' (\m a -> maAddAmount m (amountCost a)) (Mixed noCosts) withCosts+  where (noCosts, withCosts) = M.partition (isNothing . acost) ma++-- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we+-- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there.+-- -- For now, use this when cross-commodity zero equality is important.+-- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool+-- mixedAmountEquals a b = amounts a' == amounts b' || (mixedAmountLooksZero a' && mixedAmountLooksZero b')+--     where a' = mixedAmountStripCosts a+--           b' = mixedAmountStripCosts b++-- Mixed amount styles++-- v1+{-# DEPRECATED canonicaliseMixedAmount "please use mixedAmountSetStyle False (or styleAmounts) instead" #-}+canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount+canonicaliseMixedAmount = styleAmounts++-- v2+{-# DEPRECATED styleMixedAmount "please use styleAmounts instead" #-}+-- | Given a map of standard commodity display styles, find and apply+-- the appropriate style to each individual amount.+styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount+styleMixedAmount = styleAmounts++-- v3+{-# DEPRECATED mixedAmountSetStyles "please use styleAmounts instead" #-}+mixedAmountSetStyles :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount+mixedAmountSetStyles = styleAmounts++-- v4+instance HasAmounts MixedAmount where+  styleAmounts styles = mapMixedAmountUnsafe (styleAmounts styles)+  -- getAmounts = concatMap getAmounts . amounts++instance HasAmounts BalanceData where+  styleAmounts styles balance@BalanceData{bdexcludingsubs,bdincludingsubs} =+    balance{bdexcludingsubs=styleAmounts styles bdexcludingsubs, bdincludingsubs=styleAmounts styles bdincludingsubs}+  -- getAmounts BalanceData{bdexcludingsubs, bdincludingsubs} =+  --   getAmounts bdexcludingsubs <> getAmounts bdincludingsubs++instance HasAmounts a => HasAmounts (PeriodData a) where+  styleAmounts styles = fmap (styleAmounts styles)+  -- getAmounts ++instance HasAmounts a => HasAmounts (Account a) where+  styleAmounts styles acct@Account{adata} =+    acct{adata = styleAmounts styles <$> adata}++-- | Reset each individual amount's display style to the default.+mixedAmountUnstyled :: MixedAmount -> MixedAmount+mixedAmountUnstyled = mapMixedAmountUnsafe amountUnstyled++-- Mixed amount rendering+++-- | Render a mixed amount using its amount display styles and the default amount format,+-- after normalising it (to at most one amount in each of its commodities).+-- See showMixedAmountB for special cases.+showMixedAmount :: MixedAmount -> String+showMixedAmount = wbUnpack . showMixedAmountB defaultFmt++-- | Like showMixedAmount but uses the given amount format.+-- See showMixedAmountB for special cases.+showMixedAmountWith :: AmountFormat -> MixedAmount -> String+showMixedAmountWith fmt = wbUnpack . showMixedAmountB fmt++-- | Get the one-line string representation of a mixed amount (also showing any costs).+-- See showMixedAmountB for special cases.+showMixedAmountOneLine :: MixedAmount -> String+showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayCost=True}++-- | Like showMixedAmount, but zero amounts are shown with their+-- commodity if they have one.+-- See showMixedAmountB for special cases.+showMixedAmountWithZeroCommodity :: MixedAmount -> String+showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB defaultFmt{displayZeroCommodity=True}++-- | Get the string representation of a mixed amount, without showing any costs.+-- With a True argument, adds ANSI codes to show negative amounts in red.+-- See showMixedAmountB for special cases.+showMixedAmountWithoutCost :: Bool -> MixedAmount -> String+showMixedAmountWithoutCost c = wbUnpack . showMixedAmountB noCostFmt{displayColour=c}++-- | Get the one-line string representation of a mixed amount, but without+-- any \@ costs.+-- With a True argument, adds ANSI codes to show negative amounts in red.+-- See showMixedAmountB for special cases.+showMixedAmountOneLineWithoutCost :: Bool -> MixedAmount -> String+showMixedAmountOneLineWithoutCost c = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayColour=c}++-- | Like showMixedAmountOneLineWithoutCost, but show at most the given width,+-- with an elision indicator if there are more.+-- With a True argument, adds ANSI codes to show negative amounts in red.+-- See showMixedAmountB for special cases.+showMixedAmountElided :: Int -> Bool -> MixedAmount -> String+showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayColour=c, displayMaxWidth=Just w}++-- | Get an unambiguous string representation of a mixed amount for debugging.+showMixedAmountDebug :: MixedAmount -> String+showMixedAmountDebug m | m == missingmixedamt = "(missing)"+                       | otherwise       = "Mixed [" ++ as ++ "]"+    where as = intercalate "\n       " $ map showAmountDebug $ amounts m++-- | Render a mixed amount using its amount display styles and the given amount format,+-- as a builder for efficiency.+-- (This can be converted to a Text with wbToText or to a String with wbUnpack).+--+-- Warning: this (and its showMixedAmount aliases above) basically assumes amounts have no costs.+-- It can show misleading costs or not show costs which are there.+--+-- If a maximum width is given then:+--+-- - If displayed on one line, it will display as many Amounts as can+--   fit in the given width, and further Amounts will be elided. There+--   will always be at least one amount displayed, even if this will+--   exceed the requested maximum width.+--+-- - If displayed on multiple lines, any Amounts longer than the+--   maximum width will be elided.+--+-- Zero-equivalent amounts  are shown as just \"0\".+--+-- The special "missing" amount is shown as the empty string (?).+--+showMixedAmountB :: AmountFormat -> MixedAmount -> WideBuilder+showMixedAmountB opts ma+    | displayOneLine opts = showMixedAmountOneLineB opts ma+    | otherwise           = WideBuilder (wbBuilder . mconcat $ intersperse sep ls) width+  where+    ls = showMixedAmountLinesB opts ma+    width = headDef 0 $ map wbWidth ls+    sep = WideBuilder (TB.singleton '\n') 0++-- | Helper for showMixedAmountB (and postingAsLines, ...) to show a list of Amounts on multiple lines.+-- This returns the list of WideBuilders: one for each Amount, and padded/elided to the appropriate width.+-- This does not honour displayOneLine; all amounts will be displayed as if displayOneLine were False.+showMixedAmountLinesB :: AmountFormat -> MixedAmount -> [WideBuilder]+showMixedAmountLinesB opts ma =+    map fst $ showMixedAmountLinesPartsB opts ma++-- | Like 'showMixedAmountLinesB' but also returns+-- the amounts associated with each text builder.+showMixedAmountLinesPartsB :: AmountFormat -> MixedAmount -> [(WideBuilder, Amount)]+showMixedAmountLinesPartsB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma =+    zip (map (adBuilder . pad) elided) amts+  where+    astrs = amtDisplayList (wbWidth sep) (showAmountB opts) amts+    amts = orderedAmounts opts $+              if displayCost opts then ma else mixedAmountStripCosts ma+    sep   = WideBuilder (TB.singleton '\n') 0+    width = maximum $ map (wbWidth . adBuilder) elided++    pad amt+      | Just mw <- mmin =+          let w = (max width mw) - wbWidth (adBuilder amt)+           in amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt }+      | otherwise = amt++    elided = maybe id elideTo mmax astrs+    elideTo m xs = maybeAppend elisionStr short+      where+        elisionStr = elisionDisplay (Just m) (wbWidth sep) (length long) $ lastDef nullAmountDisplay short+        (short, long) = partition ((m>=) . wbWidth . adBuilder) xs++-- | Helper for showMixedAmountB to deal with single line displays. This does not+-- honour displayOneLine: all amounts will be displayed as if displayOneLine+-- were True.+showMixedAmountOneLineB :: AmountFormat -> MixedAmount -> WideBuilder+showMixedAmountOneLineB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma =+    WideBuilder (wbBuilder . pad . mconcat . intersperse sep $ map adBuilder elided)+    . max width $ fromMaybe 0 mmin+  where+    width  = maybe 0 adTotal $ lastMay elided+    astrs  = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $+               if displayCost opts then ma else mixedAmountStripCosts ma+    sep    = WideBuilder (TB.fromString ", ") 2+    n      = length astrs++    pad = (WideBuilder (TB.fromText $ T.replicate w " ") w <>)+      where w = fromMaybe 0 mmin - width++    elided = maybe id elideTo mmax astrs+    elideTo m = addElide . takeFitting m . withElided+    -- Add the last elision string to the end of the display list+    addElide [] = []+    addElide xs = maybeAppend (snd $ last xs) $ map fst xs+    -- Return the elements of the display list which fit within the maximum width+    -- (including their elision strings). Always display at least one amount,+    -- regardless of width.+    takeFitting _ []     = []+    takeFitting m (x:xs) = x : dropWhileRev (\(a,e) -> m < adTotal (fromMaybe a e)) xs+    dropWhileRev p = foldr (\x xs -> if null xs && p x then [] else x:xs) []++    -- Add the elision strings (if any) to each amount+    withElided = zipWith (\n2 amt -> (amt, elisionDisplay Nothing (wbWidth sep) n2 amt)) [n-1,n-2..0]++-- Get a mixed amount's component amounts with a bit of cleanup,+-- optionally preserving multiple zeros in different commodities,+-- optionally sorting them according to a commodity display order.+orderedAmounts :: AmountFormat -> MixedAmount -> [Amount]+orderedAmounts AmountFormat{displayZeroCommodity=preservezeros, displayCommodityOrder=mcommodityorder} =+  if preservezeros then amountsPreservingZeros else amounts+  <&> maybe id (mapM findfirst) mcommodityorder  -- maybe sort them (somehow..)+  where+    -- Find the first amount with the given commodity, otherwise a null amount in that commodity.+    findfirst :: CommoditySymbol -> [Amount] -> Amount+    findfirst c = fromMaybe nullamtc . find ((c==) . acommodity)+      where+        nullamtc = amountWithCommodity c nullamt++data AmountDisplay = AmountDisplay+  { adBuilder :: !WideBuilder  -- ^ String representation of the Amount+  , adTotal   :: !Int            -- ^ Cumulative length of MixedAmount this Amount is part of,+                                --   including separators+  } deriving (Show)++nullAmountDisplay :: AmountDisplay+nullAmountDisplay = AmountDisplay mempty 0++amtDisplayList :: Int -> (Amount -> WideBuilder) -> [Amount] -> [AmountDisplay]+amtDisplayList sep showamt = snd . mapAccumL display (-sep)+  where+    display tot amt = (tot', AmountDisplay str tot')+      where+        str  = showamt amt+        tot' = tot + (wbWidth str) + sep++-- The string "m more", added to the previous running total+elisionDisplay :: Maybe Int -> Int -> Int -> AmountDisplay -> Maybe AmountDisplay+elisionDisplay mmax sep n lastAmt+  | n > 0     = Just $ AmountDisplay (WideBuilder (TB.fromText str) len) (adTotal lastAmt + len)+  | otherwise = Nothing+  where+    fullString = T.pack $ show n ++ " more.."+    -- sep from the separator, 7 from " more..", numDigits n from number+    fullLength = sep + 7 + numDigitsInt n++    str | Just m <- mmax, fullLength > m = T.take (m - 2) fullString <> ".."+        | otherwise                      = fullString+    len = case mmax of Nothing -> fullLength+                       Just m  -> max 2 $ min m fullLength++maybeAppend :: Maybe a -> [a] -> [a]+maybeAppend Nothing  = id+maybeAppend (Just a) = (++[a])++-- | Set the display precision in the amount's commodities.+mixedAmountSetPrecision :: AmountPrecision -> MixedAmount -> MixedAmount+mixedAmountSetPrecision p = mapMixedAmountUnsafe (amountSetPrecision p)++-- | In each component amount, increase the display precision sufficiently+-- to render it exactly (showing all significant decimal digits).+mixedAmountSetFullPrecision :: MixedAmount -> MixedAmount+mixedAmountSetFullPrecision = mapMixedAmountUnsafe amountSetFullPrecision++-- | In each component amount, increase the display precision sufficiently+-- to render it exactly if possible, but not more than the given max precision,+-- and if no max precision is given and the amount has infinite decimals,+-- limit display precision to a hard-coded smaller number (8).+-- See amountSetFullPrecisionUpTo.+mixedAmountSetFullPrecisionUpTo :: Maybe Word8 -> MixedAmount -> MixedAmount+mixedAmountSetFullPrecisionUpTo mmaxp = mapMixedAmountUnsafe (amountSetFullPrecisionUpTo mmaxp)++-- | In each component amount, ensure the display precision is at least the given value.+-- Makes all amounts have an explicit Precision.+mixedAmountSetPrecisionMin :: Word8 -> MixedAmount -> MixedAmount+mixedAmountSetPrecisionMin p = mapMixedAmountUnsafe (amountSetPrecisionMin p)++-- | In each component amount, ensure the display precision is at most the given value.+-- Makes all amounts have an explicit Precision.+mixedAmountSetPrecisionMax :: Word8 -> MixedAmount -> MixedAmount+mixedAmountSetPrecisionMax p = mapMixedAmountUnsafe (amountSetPrecisionMax p)++-- | Remove all costs from a MixedAmount.+mixedAmountStripCosts :: MixedAmount -> MixedAmount+mixedAmountStripCosts (Mixed ma) =+    foldl' (\m a -> maAddAmount m a{acost=Nothing}) (Mixed noCosts) withCosts+  where (noCosts, withCosts) = M.partition (isNothing . acost) ma+++-------------------------------------------------------------------------------+-- tests++tests_Amount = testGroup "Amount" [+   testGroup "Amount" [++     testCase "amountCost" $ do+       amountCost (eur 1) @?= eur 1+       amountCost (eur 2){acost=Just $ UnitCost $ usd 2} @?= usd 4+       amountCost (eur 1){acost=Just $ TotalCost $ usd 2} @?= usd 2+       amountCost (eur (-1)){acost=Just $ TotalCost $ usd (-2)} @?= usd (-2)++    ,testCase "amountLooksZero" $ do+       assertBool "" $ amountLooksZero nullamt+       assertBool "" $ amountLooksZero $ usd 0++    ,testCase "negating amounts" $ do+       negate (usd 1) @?= (usd 1){aquantity= -1}+       let b = (usd 1){acost=Just $ UnitCost $ eur 2} in negate b @?= b{aquantity= -1}++    ,testCase "adding amounts without costs" $ do+       (usd 1.23 + usd (-1.23)) @?= usd 0+       (usd 1.23 + usd (-1.23)) @?= usd 0+       (usd (-1.23) + usd (-1.23)) @?= usd (-2.46)+       sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] @?= usd 0+       -- highest precision is preserved+       asprecision (astyle $ sum [usd 1 `withPrecision` Precision 1, usd 1 `withPrecision` Precision 3]) @?= Precision 3+       asprecision (astyle $ sum [usd 1 `withPrecision` Precision 3, usd 1 `withPrecision` Precision 1]) @?= Precision 3+       -- adding different commodities assumes conversion rate 1+       assertBool "" $ amountLooksZero (usd 1.23 - eur 1.23)++    ,testCase "showAmount" $ do+      showAmount (usd 0 + gbp 0) @?= "0"++  ]++  ,testGroup "MixedAmount" [++     testCase "comparing mixed amounts compares based on quantities" $ do+       let usdpos = mixed [usd 1]+           usdneg = mixed [usd (-1)]+           eurneg = mixed [eur (-12)]+       compare usdneg usdpos @?= LT+       compare eurneg usdpos @?= LT++     ,testCase "adding mixed amounts to zero, the commodity and amount style are preserved" $+      maSum (map mixedAmount+        [usd 1.25+        ,usd (-1) `withPrecision` Precision 3+        ,usd (-0.25)+        ])+        @?= mixedAmount (usd 0 `withPrecision` Precision 3)++    ,testCase "adding mixed amounts with total costs" $ do+      maSum (map mixedAmount+        [usd 1 @@ eur 1+        ,usd (-2) @@ eur 1+        ])+        @?= mixedAmount (usd (-1) @@ eur 2)++    ,testCase "showMixedAmount" $ do+       showMixedAmount (mixedAmount (usd 1)) @?= "$1.00"+       showMixedAmount (mixedAmount (usd 1 `at` eur 2)) @?= "$1.00 @ €2.00"+       showMixedAmount (mixedAmount (usd 0)) @?= "0"+       showMixedAmount nullmixedamt @?= "0"+       showMixedAmount missingmixedamt @?= ""++    ,testCase "showMixedAmountWithoutCost" $ do+      let a = usd 1 `at` eur 2+      showMixedAmountWithoutCost False (mixedAmount (a)) @?= "$1.00"+      showMixedAmountWithoutCost False (mixed [a, -a]) @?= "0"++    ,testGroup "amounts" [+       testCase "a missing amount overrides any other amounts" $+        amounts (mixed [usd 1, missingamt]) @?= [missingamt]+      ,testCase "costless same-commodity amounts are combined" $+        amounts (mixed [usd 0, usd 2]) @?= [usd 2]+      ,testCase "amounts with same unit cost are combined" $+        amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= [usd 2 `at` eur 1]+      ,testCase "amounts with different unit costs are not combined" $+        amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= [usd 1 `at` eur 1, usd 1 `at` eur 2]+      ,testCase "amounts with total costs are combined" $+        amounts (mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2]+    ]++    ,testCase "mixedAmountStripCosts" $ do+       amounts (mixedAmountStripCosts nullmixedamt) @?= [nullamt]+       assertBool "" $ mixedAmountLooksZero $ mixedAmountStripCosts+        (mixed [usd 10+               ,usd 10 @@ eur 7+               ,usd (-10)+               ,usd (-10) @@ eur (-7)+               ])    ]
+ Hledger/Data/BalanceData.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-|+++A 'BalanceData is a data type tracking a number of postings, exclusive, and inclusive balance+for given date ranges.++-}+module Hledger.Data.BalanceData+( mapBalanceData+, opBalanceData++, tests_BalanceData+) where+++import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++import Hledger.Data.Amount+import Hledger.Data.Types+++instance Show BalanceData where+  showsPrec d (BalanceData e i n) =+    showParen (d > 10) $+        showString "BalanceData"+      . showString "{ bdexcludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt e))+      . showString ", bdincludingsubs = " . showString (wbUnpack (showMixedAmountB defaultFmt i))+      . showString ", bdnumpostings = " . shows n+      . showChar '}'++instance Semigroup BalanceData where+  BalanceData e i n <> BalanceData e' i' n' = BalanceData (maPlus e e') (maPlus i i') (n + n')++instance Monoid BalanceData where+  mempty = BalanceData nullmixedamt nullmixedamt 0++-- | Apply an operation to both 'MixedAmount' in an 'BalanceData'.+mapBalanceData :: (MixedAmount -> MixedAmount) -> BalanceData -> BalanceData+mapBalanceData f a = a{bdexcludingsubs = f $ bdexcludingsubs a, bdincludingsubs = f $ bdincludingsubs a}++-- | Merge two 'BalanceData', using the given operation to combine their amounts.+opBalanceData :: (MixedAmount -> MixedAmount -> MixedAmount) -> BalanceData -> BalanceData -> BalanceData+opBalanceData f a b = a{bdexcludingsubs = f (bdexcludingsubs a) (bdexcludingsubs b), bdincludingsubs = f (bdincludingsubs a) (bdincludingsubs b)}+++-- tests++tests_BalanceData = testGroup "BalanceData" [++  testCase "opBalanceData maPlus" $ do+    opBalanceData maPlus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0)+      @?= BalanceData (mixed [usd 4]) (mixed [usd 6]) 5,++  testCase "opBalanceData maMinus" $ do+    opBalanceData maMinus (BalanceData (mixed [usd 1]) (mixed [usd 2]) 5) (BalanceData (mixed [usd 3]) (mixed [usd 4]) 0)+      @?= BalanceData (mixed [usd (-2)]) (mixed [usd (-2)]) 5+  ]
+ Hledger/Data/Balancing.hs view
@@ -0,0 +1,1153 @@+{-|+Functions for ensuring transactions and journals are balanced.+-}++{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++module Hledger.Data.Balancing+( -- * BalancingOpts+  BalancingOpts(..)+, HasBalancingOpts(..)+, defbalancingopts+  -- * transaction balancing+, isTransactionBalanced+, balanceSingleTransaction+, balanceTransactionHelper+  -- * assertion validation+, transactionCheckAssertions+  -- * journal balancing+, journalBalanceTransactions+  -- * tests+, tests_Balancing+)+where++import Control.Monad (forM, forM_, when, unless)+import Control.Monad.Except (ExceptT(..), runExceptT, throwError)+import "extra" Control.Monad.Extra (whenM)+import Control.Monad.Reader as R (ReaderT, reader, runReaderT, ask, asks)+import Control.Monad.ST (ST, runST)+import Control.Monad.Trans.Class (lift)+import Data.Array.ST (STArray, getElems, newListArray, writeArray)+import Data.Bifunctor (second)+import Data.Foldable (asum)+import Data.Function ((&))+import Data.Functor ((<&>), void)+import Data.HashTable.Class qualified as H (toList)+import Data.HashTable.ST.Cuckoo qualified as H+import Data.List (partition, sortOn)+import Data.List.Extra (nubSort)+import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe)+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Time.Calendar (fromGregorian)+import Data.Map qualified as M+import Safe (headErr)+import Text.Printf (printf)++import Hledger.Data.Types+import Hledger.Data.AccountName (isAccountNamePrefixOf)+import Hledger.Data.Amount+import Hledger.Data.Journal+import Hledger.Data.Posting+import Hledger.Data.Transaction+import Hledger.Data.Errors+import Hledger.Utils+++data BalancingOpts = BalancingOpts+  { ignore_assertions_     :: Bool  -- ^ should failing balance assertions be ignored ?+  , infer_balancing_costs_ :: Bool  -- ^ Are we permitted to infer missing costs to balance transactions ?+                                    --   Distinct from InputOpts{infer_costs_}.+  , commodity_styles_      :: Maybe (M.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles+  , txn_balancing_         :: TransactionBalancingPrecision+  , account_types_         :: M.Map AccountName AccountType  -- ^ account type map, passed through for any balancing helpers that need it+  } deriving (Eq, Ord, Show)++defbalancingopts :: BalancingOpts+defbalancingopts = BalancingOpts+  { ignore_assertions_     = False+  , infer_balancing_costs_ = True+  , commodity_styles_      = Nothing+  , txn_balancing_         = TBPExact+  , account_types_         = M.empty+  }++-- | Check that this transaction would appear balanced to a human when displayed.+-- On success, returns the empty list, otherwise one or more error messages.+--+-- In more detail:+-- For the real postings, and separately for the balanced virtual postings:+--+-- 1. Convert amounts to cost where possible+--+-- 2. When there are two or more non-zero amounts+--    (appearing non-zero when displayed, using the given display styles if provided),+--    are they a mix of positives and negatives ?+--    This is checked separately to give a clearer error message.+--    (Best effort; could be confused by postings with multicommodity amounts.)+--+-- 3. Does the amounts' sum appear non-zero when displayed ?+--    (using the given display styles if provided)+--+transactionCheckBalanced :: BalancingOpts -> Transaction -> [String]+transactionCheckBalanced BalancingOpts{commodity_styles_=_mglobalstyles, txn_balancing_} t = errs+  where+    -- get real and balanced virtual postings, to be checked separately+    (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t+      where+        partitionPosting p ~(l, r) = case ptype p of+            RegularPosting         -> (p:l, r)+            BalancedVirtualPosting -> (l, p:r)+            VirtualPosting         -> (l, r)++    -- convert a posting's amount to cost,+    -- unless it has been marked as a redundant cost (equivalent to some nearby equity conversion postings),+    -- in which case ignore it.+    postingBalancingAmount p+      | costPostingTagName `elem` map fst (ptags p) = mixedAmountStripCosts $ pamount p+      | otherwise                                   = mixedAmountCost $ pamount p++    lookszero = case txn_balancing_ of+      TBPOld    -> lookszeroatglobaldisplayprecision+      TBPExact  -> lookszeroatlocaltransactionprecision++    lookszeroatlocaltransactionprecision = mixedAmountLooksZero . styleAmounts (transactionCommodityStylesWith HardRounding t)+    lookszeroatglobaldisplayprecision    = mixedAmountLooksZero . maybe id styleAmounts _mglobalstyles++    -- check that the sum looks like zero+    (rsumcost,  bvsumcost)  = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps)+    (rsumok,    bvsumok)    = (lookszero rsumcost, lookszero bvsumcost)+    (rsumokold, bvsumokold) = (lookszeroatglobaldisplayprecision rsumcost, lookszeroatglobaldisplayprecision bvsumcost)++    -- when there's multiple non-zeros, check they do not all have the same sign+    (rsignsok, bvsignsok)   = (signsOk rps, signsOk bvps)+      where+        signsOk ps = length nonzeros < 2 || length nonzerosigns > 1+          where+            nonzeros = filter (not.lookszero) $ map postingBalancingAmount ps+            nonzerosigns = nubSort $ mapMaybe isNegativeMixedAmount nonzeros++    -- Generate error messages if any. Show amounts with their original precisions.+    errs = filter (not.null) [rmsg, bvmsg]+      where+        rmsg+          | rsumok        = ""+          | not rsignsok  = "The real postings all have the same sign. Consider negating some of them."+          | otherwise     = "The real postings' sum should be 0 but is: " +++              (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $+              mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision+              rsumcost)+              ++ if rsumokold then oldbalancingmsg else ""+        bvmsg+          | bvsumok       = ""+          | not bvsignsok = "The balanced virtual postings all have the same sign. Consider negating some of them."+          | otherwise     = "The balanced virtual postings' sum should be 0 but is: " +++              (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $+              mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision+              bvsumcost)+              ++ if bvsumokold then oldbalancingmsg else ""+        oldbalancingmsg = unlines [+          -- -------------------------------------------------------------------------------+           "\nNote, hledger <1.50 accepted this entry because of the global display precision,"+          ,"but hledger 1.50+ checks more strictly, using the entry's local precision."+          ,"You can use --txn-balancing=old to keep it working, or fix it (recommended);"+          ,"see 'Transaction balancing' in the hledger manual."+          ]++-- | Legacy form of transactionCheckBalanced.+isTransactionBalanced :: BalancingOpts -> Transaction -> Bool+isTransactionBalanced bopts = null . transactionCheckBalanced bopts++-- | Verify that any assertions in this transaction hold +-- when included in the larger journal.+transactionCheckAssertions :: BalancingOpts -> Journal -> Transaction -> Either String Transaction+transactionCheckAssertions bopts j t =+  if (ignore_assertions_ bopts) then Right t else do+    j' <- journalStyleAmounts j +    let newtxns = sortOn tdate (jtxns j' ++ [ t ])+    case journalBalanceTransactions bopts j'{jtxns = newtxns} of+      Right _ -> Right t+      Left e -> Left e++-- | Balance this isolated transaction, ensuring that its postings+-- (and its balanced virtual postings) sum to 0,+-- by inferring a missing amount or conversion price(s) if needed.+-- Or if balancing is not possible, because the amounts don't sum to 0 or+-- because there's more than one missing amount, return an error message.+--+-- Note this is not as accurate as @balanceTransactionInJournal@,+-- which considers the whole journal when calculating balance assignments and balance assertions.+balanceSingleTransaction :: BalancingOpts -> Transaction -> Either String Transaction+balanceSingleTransaction bopts = fmap fst . balanceTransactionHelper bopts++-- | Helper used by balanceSingleTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;+-- use one of those instead.+-- It also returns a list of accounts and amounts that were inferred.+balanceTransactionHelper :: BalancingOpts -> Transaction -> Either String (Transaction, [(AccountName, MixedAmount)])+balanceTransactionHelper bopts t = do+  let lbl = lbl_ "balanceTransactionHelper"+  (t', inferredamtsandaccts) <- t+    & (if infer_balancing_costs_ bopts then transactionInferBalancingCosts else id)+    & dbg9With (lbl "amounts after balancing-cost-inferring".show.map showMixedAmountOneLine.transactionAmounts)+    & transactionInferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) (account_types_ bopts)+    <&> dbg9With (lbl "balancing amounts inferred".show.map (second showMixedAmountOneLine).snd)+  case transactionCheckBalanced bopts t' of+    []   -> Right (txnTieKnot t', inferredamtsandaccts)+    errs -> Left $ transactionBalanceError t' errs'+      where+        ismulticommodity = (length $ transactionCommodities t') > 1+        errs' =+          [ "Automatic commodity conversion is not enabled."+          | ismulticommodity && not (infer_balancing_costs_ bopts)+          ] +++          errs +++          if ismulticommodity+          then+          [ "Consider adjusting this entry's amounts, adding missing postings,"+          , "or recording conversion price(s) with @, @@ or equity postings." +          ]+          else []++transactionCommodities :: Transaction -> S.Set CommoditySymbol+transactionCommodities t = mconcat $ map (maCommodities . pamount) $ tpostings t++-- | Generate a transaction balancing error message, given the transaction+-- and one or more suberror messages.+transactionBalanceError :: Transaction -> [String] -> String+transactionBalanceError t errs = printf "%s:\n%s\n\nThis %stransaction is unbalanced.\n%s"+  (sourcePosPairPretty $ tsourcepos t)+  (textChomp ex)+  (if ismulticommodity then "multi-commodity " else "" :: String)+  (chomp $ unlines errs)+  where+    ismulticommodity = (length $ transactionCommodities t) > 1+    (_f,_l,_mcols,ex) = makeTransactionErrorExcerpt t finderrcols+      where+        finderrcols _ = Nothing+        -- finderrcols t = Just (1, Just w)+        --   where+        --     w = maximumDef 1 $ map T.length $ T.lines $ showTransaction t++-- | Infer up to one missing amount for this transactions's real postings, and+-- likewise for its balanced virtual postings, if needed; or return an error+-- message if we can't. Returns the updated transaction and any inferred posting amounts,+-- with the corresponding accounts, in order).+--+-- We can infer a missing amount when there are multiple postings and exactly+-- one of them is amountless. If the amounts had price(s) the inferred amount+-- have the same price(s), and will be converted to the price commodity.+transactionInferBalancingAmount ::+     M.Map CommoditySymbol AmountStyle -- ^ commodity display styles+  -> M.Map AccountName AccountType     -- ^ account type map (passed through; reserved for future use)+  -> Transaction+  -> Either String (Transaction, [(AccountName, MixedAmount)])+transactionInferBalancingAmount styles _atypes t@Transaction{tpostings=ps}+  | length amountlessrealps > 1+      = Left $ transactionBalanceError t+        ["There can't be more than one real posting with no amount."+        ,"(Remember to put two or more spaces between account and amount.)"]+  | length amountlessbvps > 1+      = Left $ transactionBalanceError t+        ["There can't be more than one balanced virtual posting with no amount."+        ,"(Remember to put two or more spaces between account and amount.)"]+  | otherwise+      = let psandinferredamts = map inferamount ps+            inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts]+        in Right (+           t{tpostings=map fst psandinferredamts}+          ,inferredacctsandamts+           -- & dbg9With (lbl "inferred".show.map (showMixedAmountOneLine.snd))+          )+  where+    lbl = lbl_ "transactionInferBalancingAmount"+    (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t)+    realsum = sumPostings amountfulrealps+      -- & dbg9With (lbl "real balancing amount".showMixedAmountOneLine)+    (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t)+    bvsum = sumPostings amountfulbvps++    inferamount :: Posting -> (Posting, Maybe MixedAmount)+    inferamount p =+      let+        minferredamt = case ptype p of+          RegularPosting         | not (hasAmount p) -> Just realsum+          BalancedVirtualPosting | not (hasAmount p) -> Just bvsum+          VirtualPosting         | not (hasAmount p) -> Just 0+          _                                          -> Nothing+      in+        case minferredamt of+          Nothing -> (p, Nothing)+          Just a  -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a')+            where+              -- Inferred amounts are converted to cost.+              -- Also ensure the new amount has the standard style for its commodity+              -- (since the main amount styling pass happened before this balancing pass);+              a' = maNegate a+                -- & dbg9With (lbl "balancing amount".showMixedAmountOneLine)+                & mixedAmountCost+                -- & dbg9With (lbl "balancing amount converted to cost".showMixedAmountOneLine)+                & styleAmounts (styles+                                -- Needed until we switch to locally-inferred balancing precisions: XXX #2402+                                -- these had hard rounding set to help with balanced-checking;+                                -- set no rounding now to avoid excessive display precision in output+                                & amountStylesSetRounding NoRounding+                                & dbg9With (lbl "balancing amount styles".show))+                & dbg9With (lbl "balancing amount styled".showMixedAmountOneLine)++-- | Infer costs for this transaction's posting amounts, if needed to make+-- the postings balance, and if permitted. This is done once for the real+-- postings and again (separately) for the balanced virtual postings. When+-- it's not possible, the transaction is left unchanged.+--+-- The simplest example is a transaction with two postings, each in a+-- different commodity, with no costs specified. In this case we'll add a+-- cost to the first posting such that it can be converted to the commodity+-- of the second posting (with -B), and such that the postings balance.+--+-- In general, we can infer a cost (conversion rate) when the sum of posting amounts+-- contains exactly two different commodities and no explicit costs.  Also+-- all postings are expected to contain an explicit amount (no missing+-- amounts) in a single commodity. Otherwise no cost inferring is attempted.+--+-- The transaction itself could contain more than two commodities, and/or+-- costs, if they cancel out; what matters is that the sum of posting amounts+-- contains exactly two commodities and zero costs.+--+-- There can also be more than two postings in either of the commodities.+--+-- We want to avoid excessive display of digits when the calculated cost is+-- an irrational number, while hopefully also ensuring the displayed numbers+-- make sense if the user does a manual calculation. This is (mostly) achieved+-- in two ways:+--+-- - when there is only one posting in the "from" commodity, a total cost+--   (@@) is used, and all available decimal digits are shown+--+-- - otherwise, a suitable averaged unit cost (@) is applied to the relevant+--   postings, with display precision equal to the summed display precisions+--   of the two commodities being converted between, or 2, whichever is larger.+--+-- (We don't always calculate a good-looking display precision for unit costs+-- when the commodity display precisions are low, eg when a journal doesn't+-- use any decimal places. The minimum of 2 helps make the costs shown by the+-- print command a bit less surprising in this case. Could do better.)+--+transactionInferBalancingCosts :: Transaction -> Transaction+transactionInferBalancingCosts t@Transaction{tpostings=ps} = t{tpostings=ps'}+  where+    ps' = map (costInferrerFor t BalancedVirtualPosting . costInferrerFor t RegularPosting) ps++-- | Generate a posting update function which assigns a suitable cost to+-- balance the posting, if and as appropriate for the given transaction and+-- posting type (real or balanced virtual) (or if we cannot or should not infer+-- costs, leaves the posting unchanged).+costInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)+costInferrerFor t pt = maybe id infercost inferFromAndTo+  where+    lbl = lbl_ "costInferrerFor"+    postings     = filter ((==pt).ptype) $ tpostings t+    pcommodities = map acommodity $ concatMap (amounts . pamount) postings+    sumamounts   = amounts $ sumPostings postings  -- amounts normalises to one amount per commodity & price++    -- We can infer prices if there are no prices given, exactly two commodities in the normalised+    -- sum of postings in this transaction, and these two have opposite signs. The amount we are+    -- converting from is the first commodity to appear in the ordered list of postings, and the+    -- commodity we are converting to is the other. If we cannot infer prices, return Nothing.+    inferFromAndTo = case sumamounts of+      [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities+        where+          noprices      = all (isNothing . acost) sumamounts+          oppositesigns = signum (aquantity a) /= signum (aquantity b)+          orderIfMatches x | x == acommodity a = Just (a,b)+                           | x == acommodity b = Just (b,a)+                           | otherwise         = Nothing+      _ -> Nothing++    -- For each posting, if the posting type matches, there is only a single amount in the posting,+    -- and the commodity of the amount matches the amount we're converting from,+    -- then set its cost based on the ratio between fromamount and toamount.+    infercost (fromamount, toamount) p+        | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount+            = p{ pamount   = mixedAmount a{acost=Just conversionprice}+                  & dbg9With (lbl "inferred cost".showMixedAmountOneLine)+               , poriginal = Just $ originalPosting p }+        | otherwise = p+      where+        -- If only one Amount in the posting list matches fromamount we can use TotalCost.+        -- Otherwise divide the conversion equally among the Amounts by using a unit price.+        conversionprice = case filter (== acommodity fromamount) pcommodities of+            [_] -> TotalCost $ negate toamount+            _   -> UnitCost  $ negate unitcost `withPrecision` unitprecision++        unitcost     = aquantity fromamount `divideAmount` toamount+        unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of+            (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b+            _                          -> NaturalPrecision+        saturatedAdd a b = if maxBound - a < b then maxBound else a + b+++-- "Transaction balancing", including: inferring missing amounts,+-- applying balance assignments, checking transaction balancedness,+-- checking balance assertions, respecting posting dates. These things+-- are all interdependent.+-- WARN tricky algorithm and code ahead. +--+-- Code overview as of 20190219, this could/should be simplified/documented more:+--  parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), journalAddBudgetGoalTransactions (BudgetReport.hs), tests (BalanceReport.hs)+--   journalBalanceTransactions+--    runST+--     runExceptT+--      balanceSingleTransaction (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)+--   balanceSingleTransaction (Transaction.hs)  XXX hledger add won't allow balance assignments + missing amount ?++-- | 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 where balance assignments may not be used (because of auto posting rules)+  ,bsAssrt        :: Bool                                       -- ^ whether to check balance assertions+   -- mutable+  ,bsBalances     :: H.HashTable s AccountName MixedAmount      -- ^ running account balances, initially empty+  ,bsTransactions :: STArray s Integer Transaction              -- ^ a mutable array of the transactions being balanced+    -- (for efficiency ? journalBalanceTransactions says: not strictly necessary but avoids a sort at the end I think)+  }++-- | Access the current balancing state, and possibly modify the mutable bits,+-- lifting through the Except and Reader layers into the Balancing monad.+withRunningBalance :: (BalancingState s -> ST s a) -> Balancing s a+withRunningBalance f = ask >>= lift . lift . f++-- | Get this account's current exclusive running balance.+getRunningBalanceB :: AccountName -> Balancing s MixedAmount+getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do+  fromMaybe nullmixedamt <$> H.lookup bsBalances acc++-- | Add this amount to this account's exclusive running balance.+-- Returns the new running balance.+addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount+addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do+  old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc+  let new = maPlus old amt+  H.insert bsBalances acc new+  return new++-- | Set this account's exclusive running balance to this amount.+-- Returns the change in exclusive running balance.+setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount+setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do+  old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc+  H.insert bsBalances acc amt+  return $ maMinus amt old++-- | Set this account's exclusive running balance to whatever amount+-- makes its *inclusive* running balance (the sum of exclusive running+-- balances of this account and any subaccounts) be the given amount.+-- Returns the change in exclusive running balance.+setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount+setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do+  oldebal  <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc+  allebals <- H.toList bsBalances+  let subsibal =  -- sum of any subaccounts' running balances+        maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals+  let newebal = maMinus newibal subsibal+  H.insert bsBalances acc newebal+  return $ maMinus newebal oldebal++-- | Update (overwrite) this transaction in the balancing state.+updateTransactionB :: Transaction -> Balancing s ()+updateTransactionB t = withRunningBalance $ \BalancingState{bsTransactions}  ->+  void $ writeArray bsTransactions (tindex t) t++-- | Infer any missing amounts and/or conversion costs+-- (as needed to balance transactions and satisfy balance assignments);+-- and check that all transactions are balanced;+-- and (optional) check that all balance assertions pass.+-- Or, return an error message (just the first error encountered).+--+-- Assumes journalStyleAmounts has been called, since amount styles+-- affect transaction balancing.+--+-- This does multiple things at once because amount inferring, balance+-- assignments, balance assertions and posting dates are interdependent.+--+journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal+journalBalanceTransactions bopts' 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 $+      -- Use all the specified commodity display precisions, with hard rounding, when checking txn balancedness.+      -- XXX Problem, those precisions will also be used when inferring balancing amounts;+      -- it would be better to give those the precision of the amount they are balancing.+      journalCommodityStylesWith HardRounding+      j+    bopts = bopts'{commodity_styles_=styles}+      -- XXX ^ The commodity directive styles and default style and inferred styles+      -- are merged into the command line styles in commodity_styles_ - why ?+      -- Mainly for the precisions, used during amount and cost inference and balanced checking ?+    -- balance assignments are not allowed on accounts affected by auto postings+    autopostingaccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j+  in+    -- Store the transactions in a mutable array, which we'll update as we balance them.+    -- Not strictly necessary but avoids a sort at the end I think.+    runST $ do+      balancedtxns <- newListArray (1, toInteger $ length ts) ts++      -- Process all transactions, or short-circuit with an error.+      runExceptT $ do++        -- Two passes are required:+        -- 1. Step through the transactions, balancing the ones which don't have balance assignments,+        -- postponing those which do until later. The balanced ones are split into their postings,+        -- keeping these and the not-yet-balanced transactions in the same relative order.+        psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case+          t | null $ assignmentPostings t -> case balanceSingleTransaction bopts 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. Step through these items in date order (and preserved same-day order),+        -- keeping running balances for all accounts.+        runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)+        flip runReaderT (BalancingState styles autopostingaccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do+          -- On encountering any not-yet-balanced transaction with a balance assignment,+          -- enact the balance assignment then finish balancing the transaction.+          -- And, check any balance assertions encountered along the way.+          void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts++        -- Return the now fully-balanced and checked transactions.+        ts' <- lift $ getElems balancedtxns+        return j{jtxns=ts'}++-- Before #2039: "Costs are removed, which helps eg assertions.test: 15. Mix different commodities and assignments."++-- | 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).+-- 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.+  -- Cost is ignored when checking balance assertions currently.+  void $ addAmountAndCheckAssertionB $ postingStripCosts p+balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do+  -- make sure we can handle the balance assignments+  mapM_ checkIllegalBalanceAssignmentB ps+  -- for each posting, in date order (though without disturbing their display order),+  -- 1. infer its amount from the balance assignment if applicable,+  -- 2. update the account's running balance, and+  -- 3. check the balance assertion if any.+  ps' <- ps+    & zip [1..]                 -- attach original positions+    & sortOn (postingDate.snd)  -- sort by date+    & mapM addOrAssignAmountAndCheckAssertionB  -- infer amount, check assertion on each one+    <&> sortOn fst              -- restore original order+    <&> map snd                 -- discard positions++  -- infer any remaining missing amounts, and make sure the transaction is now fully balanced+  styles <- R.reader bsStyles+  case balanceTransactionHelper defbalancingopts{commodity_styles_=styles} t{tpostings=ps'} of+    Left err -> throwError err+    Right (t', inferredacctsandamts) -> do+      -- for each amount just inferred, update the running balance+      mapM_ (uncurry addToRunningBalanceB) inferredacctsandamts+      -- and save the balanced transaction.+      updateTransactionB t'++type NumberedPosting = (Integer, Posting)++-- | 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 :: NumberedPosting -> Balancing s NumberedPosting+addOrAssignAmountAndCheckAssertionB (i,p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba})+  -- an explicit posting amount+  | hasAmount p = do+      newbal <- addToRunningBalanceB acc amt+      whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal+      return (i,p)++  -- no explicit posting amount, but there is a balance assignment+  | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do+      newbal <- if batotal+                   -- a total balance assignment (==, all commodities)+                   then return $ mixedAmount baamount+                   -- a partial balance assignment (=, one commodity)+                   else do+                     oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc+                     return $ maAddAmount oldbalothercommodities baamount+      diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal+      let p' = p{pamount=filterMixedAmount (not . amountIsZero) diff, poriginal=Just $ originalPosting p}+      whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal+      return (i,p')++  -- no explicit posting amount, no balance assignment+  | otherwise = return (i,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 <- addToRunningBalanceB (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_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal+  where+    assertedcomm = acommodity baamount+    otheramts | batotal   = map (\a -> a{aquantity=0}) . amountsRaw+                          $ 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, ignoring costs ?+-- 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} assertedcommbal actualbal = do+  let isinclusive = maybe False bainclusive $ pbalanceassertion p+  let istotal     = maybe False batotal     $ pbalanceassertion p+  -- mstyles <- R.reader bsStyles+  -- let styled = maybe id styleAmounts mstyles+  actualbal' <-+    if isinclusive+    then+      -- sum the running balances of this account and any of its subaccounts seen so far+      withRunningBalance $ \BalancingState{bsBalances} ->+        H.foldM+          (\ibal (acc, amt) -> return $+            if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal)+          nullmixedamt+          bsBalances+    else return actualbal+  let+    assertedcomm = acommodity assertedcommbal++    -- The asserted single-commodity balance, without cost+    assertedcommbalcostless = amountStripCost assertedcommbal++    -- The balance in this commodity, from the current multi-commodity running balance at this point.+    -- This is unnormalised, and could include one or more different costs.+    actualcommbal           = filterMixedAmountByCommodity assertedcomm $ actualbal'++    -- The above balance without costs, as a single Amount (Amount's + discards costs).+    actualcommbalcostless   = sum $ amountsRaw actualcommbal++    -- test the assertion+    pass =+      aquantity assertedcommbalcostless+      ==+      aquantity actualcommbalcostless++    errmsg = chomp $ printf (unlines+      [ "%s:",+        "%s\n",+        "Balance assertion failed in %s",+        "%s at this point, %s, ignoring costs,",+        "the asserted balance is:        %s",+        "but the calculated balance is:  %s",+        "(difference: %s)",+        "To troubleshoot, check this account's running balance with assertions disabled, eg:",+        "hledger reg -I '%s'%s"+      ])++      (sourcePosPretty pos)  -- position+      (textChomp ex)  -- journal excerpt+      acct  -- asserted account+      (if istotal then "Across all commodities" else "In commodity " <> assertedcommstr)  -- asserted commodity or all commodities ?+      (if isinclusive then "including subaccounts" else "excluding subaccounts" :: String)  -- inclusive or exclusive balance asserted ?+      (pad assertedstr  -- asserted amount, without cost+        <> if debugLevel >= 2 then " (with cost:  " <> T.pack (showAmountWith fmt assertedcommbal) <> ")" else ""+      )+      (pad actualstr    -- actual amount, without cost+        <> if debugLevel >= 2 then " (with costs: " <> T.pack (showMixedAmountWith fmt actualcommbal) <> ")" else ""+      )+      diffstr  -- their difference+      (acct ++ if isinclusive then "" else "$")  -- query matching the account(s) postings+      (if istotal then "" else (" cur:" ++ quoteForCommandLine (T.unpack assertedcomm)))  -- query matching the commodity(ies)++      where+        acct = T.unpack $ paccount p+        ass = fromJust $ pbalanceassertion p  -- PARTIAL: fromJust won't fail, there is a balance assertion+        pos = baposition ass+        (_,_,_,ex) = makeBalanceAssertionErrorExcerpt p+        assertedcommstr = if T.null assertedcomm then "\"\"" else assertedcomm+        fmt = oneLineFmt{displayZeroCommodity=True}+        assertedstr = showAmountWith fmt assertedcommbalcostless+        actualstr   = showAmountWith fmt actualcommbalcostless+        diffstr     = showAmountWith fmt $ assertedcommbalcostless - actualcommbalcostless+        pad = fitText (Just w) Nothing False False . T.pack where w = max (length assertedstr) (length actualstr)+++  unless pass $ throwError errmsg+{- XXX+When the posting amount has a cost, the highlight region expands to the full line:++*** Exception: Error: /Users/simon/src/hledger/2024-01-21.j:12:69:+   | 2023-12-31 closing balances+12 |     assets:cash:petty:saved:rent       -4.00 EUR @ 2 UAH == 0.00 EUR+   |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+   |     equity:opening/closing balances                8 UAH++Maybe it's better than the normal region ?++*** Exception: Error: /Users/simon/src/hledger/2024-01-21.j:12:61:+   | 2023-12-31 closing balances+12 |     assets:cash:petty:saved:rent          -4.00 EUR == 0.00 EUR @ 3 UAH+   |                                                     ^^^^^^^^^^^^^^^^^^^+   |     equity:opening/closing balances        4.00 EUR++If changed also check flycheck-hledger, which currently highlights the equals:++    assets:cash:petty:saved:rent                  -4.00 EUR @ 2 UAH == 0.00 EUR @ 3 UAH +                                                                    --+-}++-- | 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 $ chomp $ unlines [+       "Balance assignments and custom posting dates may not be combined."+      ,""+      ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p+      ,"Balance assignments may not be used on postings with a custom posting date"+      ,"(it makes balancing the journal impossible)."+      ,"Please write the posting amount explicitly (or remove the posting date)."+      ]++-- | 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 an auto posting rule, 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 $ chomp $ unlines [+       "Balance assignments and auto postings may not be combined."+      ,""+      ,chomp1 $ T.unpack $ maybe (T.unlines $ showPostingLines p) (showTransaction) $ ptransaction p+      ,"Balance assignments may not be used on accounts affected by auto posting rules"+      ,"(it makes balancing the journal impossible)."+      ,"Please write the posting amount explicitly (or remove the auto posting rule(s))."+      ]++-- lenses++makeHledgerClassyLenses ''BalancingOpts++-- tests++tests_Balancing :: TestTree+tests_Balancing =+  testGroup "Balancing" [++      testCase "transactionInferBalancingAmount" $ do+         (fst <$> transactionInferBalancingAmount M.empty M.empty nulltransaction) @?= Right nulltransaction+         (fst <$> transactionInferBalancingAmount M.empty M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?=+           Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]}+         (fst <$> transactionInferBalancingAmount M.empty M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?=+           Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}++    , testGroup "balanceSingleTransaction" [+         testCase "detect unbalanced entry, sign error" $+          assertLeft+            (balanceSingleTransaction defbalancingopts+               (Transaction+                  0+                  ""+                  nullsourcepospair+                  (fromGregorian 2007 01 28)+                  Nothing+                  Unmarked+                  ""+                  "test"+                  ""+                  []+                  [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}]))+        ,testCase "detect unbalanced entry, multiple missing amounts" $+          assertLeft $+             balanceSingleTransaction defbalancingopts+               (Transaction+                  0+                  ""+                  nullsourcepospair+                  (fromGregorian 2007 01 28)+                  Nothing+                  Unmarked+                  ""+                  "test"+                  ""+                  []+                  [ posting {paccount = "a", pamount = missingmixedamt}+                  , posting {paccount = "b", pamount = missingmixedamt}+                  ])+        ,testCase "one missing amount is inferred" $+          (pamount . last . tpostings <$>+           balanceSingleTransaction defbalancingopts+             (Transaction+                0+                ""+                nullsourcepospair+                (fromGregorian 2007 01 28)+                Nothing+                Unmarked+                ""+                ""+                ""+                []+                [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?=+          Right (mixedAmount $ usd (-1))+        ,testCase "conversion price is inferred" $+          (pamount . headErr . tpostings <$>  -- PARTIAL headErr succeeds because non-null postings list+           balanceSingleTransaction defbalancingopts+             (Transaction+                0+                ""+                nullsourcepospair+                (fromGregorian 2007 01 28)+                Nothing+                Unmarked+                ""+                ""+                ""+                []+                [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)}+                , posting {paccount = "b", pamount = mixedAmount (eur (-1))}+                ])) @?=+          Right (mixedAmount $ usd 1.35 @@ eur 1)+        ,testCase "balanceSingleTransaction balances based on cost if there are unit prices" $+          assertRight $+          balanceSingleTransaction defbalancingopts+            (Transaction+               0+               ""+               nullsourcepospair+               (fromGregorian 2011 01 01)+               Nothing+               Unmarked+               ""+               ""+               ""+               []+               [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2}+               , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1}+               ])+        ,testCase "balanceSingleTransaction balances based on cost if there are total prices" $+          assertRight $+          balanceSingleTransaction defbalancingopts+            (Transaction+               0+               ""+               nullsourcepospair+               (fromGregorian 2011 01 01)+               Nothing+               Unmarked+               ""+               ""+               ""+               []+               [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1}+               , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)}+               ])+        ]+    , testGroup "isTransactionBalanced" [+         testCase "detect balanced" $+          assertBool "" $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}+            , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}+            ]+        ,testCase "detect unbalanced" $+          assertBool "" $+          not $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}+            , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))}+            ]+        ,testCase "detect unbalanced, one posting" $+          assertBool "" $+          not $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}]+        ,testCase "one zero posting is considered balanced for now" $+          assertBool "" $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [posting {paccount = "b", pamount = mixedAmount (usd 0)}]+        ,testCase "virtual postings don't need to balance" $+          assertBool "" $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}+            , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}+            , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting}+            ]+        ,testCase "balanced virtual postings need to balance among themselves" $+          assertBool "" $+          not $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}+            , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}+            , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting}+            ]+        ,testCase "balanced virtual postings need to balance among themselves (2)" $+          assertBool "" $+          isTransactionBalanced defbalancingopts $+          Transaction+            0+            ""+            nullsourcepospair+            (fromGregorian 2009 01 01)+            Nothing+            Unmarked+            ""+            "a"+            ""+            []+            [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)}+            , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))}+            , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting}+            , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting}+            ]+        ]++  ,testGroup "journalBalanceTransactions" [++     testCase "missing-amounts" $ do+      let ej = journalBalanceTransactions defbalancingopts $ samplejournalMaybeExplicit False+      assertRight ej+      journalPostings <$> ej @?= Right (journalPostings samplejournal)++    ,testCase "balance-assignment" $ do+      let ej = journalBalanceTransactions defbalancingopts $+            --2019/01/01+            --  (a)            = 1+            nulljournal{ jtxns = [+              transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ]+            ]}+      assertRight ej+      case ej of Right j -> (jtxns j & headErr & tpostings & headErr & pamount & amountsRaw) @?= [num 1]  -- PARTIAL headErrs succeed because non-null txns & postings lists given+                 Left _  -> error' "balance-assignment test: shouldn't happen"++    ,testCase "same-day-1" $ do+      assertRight $ journalBalanceTransactions defbalancingopts $+            --2019/01/01+            --  (a)            = 1+            --2019/01/01+            --  (a)          1 = 2+            nulljournal{ jtxns = [+               transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ]+              ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1)    (balassert (num 2)) ]+            ]}++    ,testCase "same-day-2" $ do+      assertRight $ journalBalanceTransactions defbalancingopts $+            --2019/01/01+            --    (a)                  2 = 2+            --2019/01/01+            --    b                    1+            --    a+            --2019/01/01+            --    a                    0 = 1+            nulljournal{ jtxns = [+               transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 2)    (balassert (num 2)) ]+              ,transaction (fromGregorian 2019 01 01) [+                 post' "b" (num 1)     Nothing+                ,post' "a"  missingamt Nothing+              ]+              ,transaction (fromGregorian 2019 01 01) [ post' "a" (num 0)     (balassert (num 1)) ]+            ]}++    ,testCase "out-of-order" $ do+      assertRight $ journalBalanceTransactions defbalancingopts $+            --2019/1/2+            --  (a)    1 = 2+            --2019/1/1+            --  (a)    1 = 1+            nulljournal{ jtxns = [+               transaction (fromGregorian 2019 01 02) [ vpost' "a" (num 1)    (balassert (num 2)) ]+              ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1)    (balassert (num 1)) ]+            ]}++    ]++    ,testGroup "transactionCheckAssertions" $ [+      testCase "simple assertion on same day" $ do +        assertRight $ +          transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [+            transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ]+            ] } (transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) (balassert (usd 2)) ])++      ,testCase "inclusive assertions" $ do +        assertRight $ +          transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [+            transaction (fromGregorian 2025 01 01) [ vpost' "a:a" (usd 1) Nothing ] +            ,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (usd 2) Nothing]+            ,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing]+            ,transaction (fromGregorian 2025 01 03) [ vpost' "a:d" (eur 10) Nothing]+            ] } (transaction (fromGregorian 2025 01 04) [ vpost' "a" (usd 2) (balassertParInc (usd 10))])++      ,testCase "multicommodity assertion" $ do +        assertRight $ +          transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [+            transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ] +            ,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (eur 2) Nothing ]+            ,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing ]+            ,transaction (fromGregorian 2025 01 03) [ vpost' "a:b" (eur (-2)) Nothing ]+            ] } (transaction (fromGregorian 2025 01 03) [ vpost' "a" (usd 2) (balassertTotInc (usd 8)) ])+    ]++    ,testGroup "commodityStylesFromAmounts" $ [++      -- Journal similar to the one on #1091:+      -- 2019/09/24+      --     (a)            1,000.00+      -- +      -- 2019/09/26+      --     (a)             1000,000+      --+      testCase "1091a" $ do+        commodityStylesFromAmounts [+           nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Precision 3) NoRounding}+          ,nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 2) NoRounding}+          ]+         @?=+          -- The commodity style should have period as decimal mark+          -- and comma as digit group mark.+          Right (M.fromList [+            ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 3) NoRounding)+          ])+        -- same journal, entries in reverse order+      ,testCase "1091b" $ do+        commodityStylesFromAmounts [+           nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 2) NoRounding}+          ,nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Precision 3) NoRounding}+          ]+         @?=+          -- The commodity style should have period as decimal mark+          -- and comma as digit group mark.+          Right (M.fromList [+            ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 3) NoRounding)+          ])++     ]++  ]
− Hledger/Data/Commodity.hs 
@@ -1,81 +0,0 @@-{-|--A 'Commodity' is a symbol representing a currency or some other kind of-thing we are tracking, and some display preferences that tell how to-display 'Amount's of the commodity - is the symbol on the left or right,-are thousands separated by comma, significant decimal places and so on.---}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Hledger.Data.Commodity-where-import Data.Char (isDigit)-import Data.List-import Data.Maybe (fromMaybe)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid-#endif-import qualified Data.Text as T--- import qualified Data.Map as M--import Hledger.Data.Types-import Hledger.Utils----- characters that may not be used in a non-quoted commodity symbol-nonsimplecommoditychars = "0123456789-+.@*;\n \"{}=" :: String--isNonsimpleCommodityChar :: Char -> Bool-isNonsimpleCommodityChar c = isDigit c || c `textElem` otherChars- where-   otherChars = "-+.@*;\n \"{}=" :: T.Text-   textElem = T.any . (==)--quoteCommoditySymbolIfNeeded s | T.any (isNonsimpleCommodityChar) s = "\"" <> s <> "\""-                               | otherwise = s--commodity = ""---- handy constructors for tests--- unknown = commodity--- usd     = "$"--- eur     = "€"--- gbp     = "£"--- hour    = "h"---- Some sample commodity' names and symbols, for use in tests..-commoditysymbols =-  [("unknown","")-  ,("usd","$")-  ,("eur","€")-  ,("gbp","£")-  ,("hour","h")-  ]---- | Look up one of the sample commodities' symbol by name.-comm :: String -> CommoditySymbol-comm name = snd $ fromMaybe-              (error' "commodity lookup failed")-              (find (\n -> fst n == name) commoditysymbols)---- | Find the conversion rate between two commodities. Currently returns 1.-conversionRate :: CommoditySymbol -> CommoditySymbol -> Double-conversionRate _ _ = 1---- -- | Convert a list of commodities to a map from commodity symbols to--- -- unique, display-preference-canonicalised commodities.--- canonicaliseCommodities :: [CommoditySymbol] -> Map.Map String CommoditySymbol--- canonicaliseCommodities cs =---     Map.fromList [(s,firstc{precision=maxp}) | s <- symbols,---                   let cs = commoditymap ! s,---                   let firstc = head cs,---                   let maxp = maximum $ map precision cs---                  ]---   where---     commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols]---     commoditieswithsymbol s = filter ((s==) . symbol) cs---     symbols = nub $ map symbol cs-
+ Hledger/Data/Currency.hs view
@@ -0,0 +1,160 @@+{-|++Currency names, symbols and codes.+Reference:+- https://www.xe.com/symbols+- https://www.xe.com/currency++-}++{-# LANGUAGE OverloadedStrings    #-}++module Hledger.Data.Currency (+  currencies,+  currencySymbolToCode,+  currencyCodeToSymbol,+)+where+import Data.Map qualified as M+import           Data.Text (Text)++-- | An ISO 4217 currency code, like EUR. Usually three upper case letters.+type CurrencyCode = Text++-- | A traditional currency symbol, like $. Usually one character, sometimes more.+-- Different from hledger's more general "CommoditySymbol" type.+type CurrencySymbol = Text++-- | Look for a ISO 4217 currency code corresponding to this currency symbol.+--+-- >>> currencySymbolToCode ""+-- Nothing+-- >>> currencySymbolToCode "$"+-- Just "USD"+currencySymbolToCode :: CurrencySymbol -> Maybe CurrencyCode+currencySymbolToCode s = M.lookup s currencyCodesBySymbol++-- | Look for a currency symbol corresponding to this ISO 4217 currency code.+--+-- >>> currencyCodeToSymbol "CZK"  -- Just "Kč"+-- Just "K\269"+currencyCodeToSymbol :: CurrencyCode -> Maybe CurrencySymbol+currencyCodeToSymbol c = M.lookup c currencySymbolsByCode++currencyCodesBySymbol = M.fromList [(s,c) | (_,c,s) <- currencies]+currencySymbolsByCode = M.fromList [(c,s) | (_,c,s) <- currencies]++currencies = [+  -- country and currency name           ISO 4217 code  symbol+  ("Albania Lek",                               "ALL",  "Lek"),+  ("Afghanistan Afghani",                       "AFN",  "؋"),+  ("Argentina Peso",                            "ARS",  "$"),+  ("Aruba Guilder",                             "AWG",  "ƒ"),+  ("Australia Dollar",                          "AUD",  "$"),+  ("Azerbaijan Manat",                          "AZN",  "₼"),+  ("Bahamas Dollar",                            "BSD",  "$"),+  ("Barbados Dollar",                           "BBD",  "$"),+  ("Belarus Ruble",                             "BYN",  "Br"),+  ("Belize Dollar",                             "BZD",  "BZ$"),+  ("Bermuda Dollar",                            "BMD",  "$"),+  ("Bolivia Bolíviano",                         "BOB",  "$b"),+  ("Bosnia and Herzegovina Convertible Mark",   "BAM",  "KM"),+  ("Botswana Pula",                             "BWP",  "P"),+  ("Bulgaria Lev",                              "BGN",  "лв"),+  ("Brazil Real",                               "BRL",  "R$"),+  ("Brunei Darussalam Dollar",                  "BND",  "$"),+  ("Cambodia Riel",                             "KHR",  "៛"),+  ("Canada Dollar",                             "CAD",  "$"),+  ("Cayman Islands Dollar",                     "KYD",  "$"),+  ("Chile Peso",                                "CLP",  "$"),+  ("China Yuan Renminbi",                       "CNY",  "¥"),+  ("Colombia Peso",                             "COP",  "$"),+  ("Costa Rica Colon",                          "CRC",  "₡"),+  ("Croatia Kuna",                              "HRK",  "kn"),+  ("Cuba Peso",                                 "CUP",  "₱"),+  ("Czech Republic Koruna",                     "CZK",  "Kč"),+  ("Denmark Krone",                             "DKK",  "kr"),+  ("Dominican Republic Peso",                   "DOP",  "RD$"),+  ("East Caribbean Dollar",                     "XCD",  "$"),+  ("Egypt Pound",                               "EGP",  "£"),+  ("El Salvador Colon",                         "SVC",  "$"),+  ("Euro Member Countries",                     "EUR",  "€"),+  ("Falkland Islands (Malvinas) Pound",         "FKP",  "£"),+  ("Fiji Dollar",                               "FJD",  "$"),+  ("Ghana Cedi",                                "GHS",  "¢"),+  ("Gibraltar Pound",                           "GIP",  "£"),+  ("Guatemala Quetzal",                         "GTQ",  "Q"),+  ("Guernsey Pound",                            "GGP",  "£"),+  ("Guyana Dollar",                             "GYD",  "$"),+  ("Honduras Lempira",                          "HNL",  "L"),+  ("Hong Kong Dollar",                          "HKD",  "$"),+  ("Hungary Forint",                            "HUF",  "Ft"),+  ("Iceland Krona",                             "ISK",  "kr"),+  ("India Rupee",                               "INR",  "₹"),+  ("Indonesia Rupiah",                          "IDR",  "Rp"),+  ("Iran Rial",                                 "IRR",  "﷼"),+  ("Isle of Man Pound",                         "IMP",  "£"),+  ("Israel Shekel",                             "ILS",  "₪"),+  ("Jamaica Dollar",                            "JMD",  "J$"),+  ("Japan Yen",                                 "JPY",  "¥"),+  ("Jersey Pound",                              "JEP",  "£"),+  ("Kazakhstan Tenge",                          "KZT",  "лв"),+  ("Korea (North) Won",                         "KPW",  "₩"),+  ("Korea (South) Won",                         "KRW",  "₩"),+  ("Kyrgyzstan Som",                            "KGS",  "лв"),+  ("Laos Kip",                                  "LAK",  "₭"),+  ("Lebanon Pound",                             "LBP",  "£"),+  ("Liberia Dollar",                            "LRD",  "$"),+  ("Macedonia Denar",                           "MKD",  "ден"),+  ("Malaysia Ringgit",                          "MYR",  "RM"),+  ("Mauritius Rupee",                           "MUR",  "₨"),+  ("Mexico Peso",                               "MXN",  "$"),+  ("Mongolia Tughrik",                          "MNT",  "₮"),+  ("Mozambique Metical",                        "MZN",  "MT"),+  ("Namibia Dollar",                            "NAD",  "$"),+  ("Nepal Rupee",                               "NPR",  "₨"),+  ("Netherlands Antilles Guilder",              "ANG",  "ƒ"),+  ("New Zealand Dollar",                        "NZD",  "$"),+  ("Nicaragua Cordoba",                         "NIO",  "C$"),+  ("Nigeria Naira",                             "NGN",  "₦"),+  ("Norway Krone",                              "NOK",  "kr"),+  ("Oman Rial",                                 "OMR",  "﷼"),+  ("Pakistan Rupee",                            "PKR",  "₨"),+  ("Panama Balboa",                             "PAB",  "B/."),+  ("Paraguay Guarani",                          "PYG",  "Gs"),+  ("Peru Sol",                                  "PEN",  "S/."),+  ("Philippines Peso",                          "PHP",  "₱"),+  ("Poland Zloty",                              "PLN",  "zł"),+  ("Qatar Riyal",                               "QAR",  "﷼"),+  ("Romania Leu",                               "RON",  "lei"),+  ("Russia Ruble",                              "RUB",  "₽"),+  ("Saint Helena Pound",                        "SHP",  "£"),+  ("Saudi Arabia Riyal",                        "SAR",  "﷼"),+  ("Serbia Dinar",                              "RSD",  "Дин."),+  ("Seychelles Rupee",                          "SCR",  "₨"),+  ("Singapore Dollar",                          "SGD",  "$"),+  ("Solomon Islands Dollar",                    "SBD",  "$"),+  ("Somalia Shilling",                          "SOS",  "S"),+  ("South Africa Rand",                         "ZAR",  "R"),+  ("Sri Lanka Rupee",                           "LKR",  "₨"),+  ("Sweden Krona",                              "SEK",  "kr"),+  ("Switzerland Franc",                         "CHF",  "CHF"),+  ("Suriname Dollar",                           "SRD",  "$"),+  ("Syria Pound",                               "SYP",  "£"),+  ("Taiwan New Dollar",                         "TWD",  "NT$"),+  ("Thailand Baht",                             "THB",  "฿"),+  ("Trinidad and Tobago Dollar",                "TTD",  "TT$"),+  ("Turkey Lira",                               "TRY",  "₺"),+  ("Tuvalu Dollar",                             "TVD",  "$"),+  ("Ukraine Hryvnia",                           "UAH",  "₴"),+  ("United Kingdom Pound",                      "GBP",  "£"),+  ("United States Dollar",                      "USD",  "$"),+  ("Uruguay Peso",                              "UYU",  "$U"),+  ("Uzbekistan Som",                            "UZS",  "лв"),+  ("Venezuela Bolívar",                         "VEF",  "Bs"),+  ("Viet Nam Dong",                             "VND",  "₫"),+  ("Yemen Rial",                                "YER",  "﷼"),+  ("Zimbabwe Dollar",                           "ZWD",  "Z$")+  ]++-- tests_Currency = testGroup "Currency" []
Hledger/Data/Dates.hs view
@@ -1,1095 +1,1242 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoMonoLocalBinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}-{-|--Date parsing and utilities for hledger.--For date and time values, we use the standard Day and UTCTime types.--A 'SmartDate' is a date which may be partially-specified or relative.-Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year.-We represent these as a triple of strings like (\"2008\",\"12\",\"\"),-(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").--A 'DateSpan' is the span of time between two specific calendar dates, or-an open-ended span where one or both dates are unspecified. (A date span-with both ends unspecified matches all dates.)--An 'Interval' is ledger's \"reporting interval\" - weekly, monthly,-quarterly, etc.--'Period' will probably replace DateSpan in due course.---}---- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?--module Hledger.Data.Dates (-  -- * Misc date handling utilities-  getCurrentDay,-  getCurrentMonth,-  getCurrentYear,-  nulldate,-  spanContainsDate,-  periodContainsDate,-  parsedateM,-  parsedate,-  showDate,-  showDateSpan,-  showDateSpanMonthAbbrev,-  elapsedSeconds,-  prevday,-  periodexprp,-  parsePeriodExpr,-  parsePeriodExpr',-  nulldatespan,-  emptydatespan,-  failIfInvalidYear,-  failIfInvalidMonth,-  failIfInvalidDay,-  datesepchar,-  datesepchars,-  isDateSepChar,-  spanStart,-  spanEnd,-  spansSpan,-  spanIntersect,-  spansIntersect,-  spanIntervalIntersect,-  spanDefaultsFrom,-  spanUnion,-  spansUnion,-  smartdate,-  splitSpan,-  fixSmartDate,-  fixSmartDateStr,-  fixSmartDateStrEither,-  fixSmartDateStrEither',-  daysInSpan,-  maybePeriod,-  mkdatespan,-)-where--import Prelude ()-import "base-compat-batteries" Prelude.Compat-import Control.Applicative.Permutations-import Control.Monad-import "base-compat-batteries" Data.List.Compat-import Data.Default-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-#if MIN_VERSION_time(1,5,0)-import Data.Time.Format hiding (months)-#else-import Data.Time.Format-import System.Locale (TimeLocale, defaultTimeLocale)-#endif-import Data.Time.Calendar-import Data.Time.Calendar.OrdinalDate-import Data.Time.Clock-import Data.Time.LocalTime-import Safe (headMay, lastMay, readMay)-import Text.Megaparsec-import Text.Megaparsec.Char-import Text.Megaparsec.Custom-import Text.Printf--import Hledger.Data.Types-import Hledger.Data.Period-import Hledger.Utils----- Help ppShow parse and line-wrap DateSpans better in debug output.-instance Show DateSpan where-    show s = "DateSpan " ++ showDateSpan s-    -- show s = "DateSpan \"" ++ showDateSpan s ++ "\"" -- quotes to help pretty-show--showDate :: Day -> String-showDate = formatTime defaultTimeLocale "%0C%y/%m/%d"---- | Render a datespan as a display string, abbreviating into a--- compact form if possible.-showDateSpan :: DateSpan -> String-showDateSpan = showPeriod . dateSpanAsPeriod---- | Like showDateSpan, but show month spans as just the abbreviated month name--- in the current locale.-showDateSpanMonthAbbrev :: DateSpan -> String-showDateSpanMonthAbbrev = showPeriodMonthAbbrev . dateSpanAsPeriod---- | Get the current local date.-getCurrentDay :: IO Day-getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime---- | Get the current local month number.-getCurrentMonth :: IO Int-getCurrentMonth = second3 . toGregorian <$> getCurrentDay---- | Get the current local year.-getCurrentYear :: IO Integer-getCurrentYear = first3 . toGregorian <$> getCurrentDay--elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a-elapsedSeconds t1 = realToFrac . diffUTCTime t1--spanStart :: DateSpan -> Maybe Day-spanStart (DateSpan d _) = d--spanEnd :: DateSpan -> Maybe Day-spanEnd (DateSpan _ d) = d---- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra---- | Get overall span enclosing multiple sequentially ordered spans.-spansSpan :: [DateSpan] -> DateSpan-spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans)---- | Split a DateSpan into consecutive whole spans of the specified interval--- which fully encompass the original span (and a little more when necessary).--- If no interval is specified, the original span is returned.--- If the original span is the null date span, ie unbounded, the null date span is returned.--- If the original span is empty, eg if the end date is <= the start date, no spans are returned.--- ------ ==== Examples:--- >>> let t i d1 d2 = splitSpan i $ mkdatespan d1 d2--- >>> t NoInterval "2008/01/01" "2009/01/01"--- [DateSpan 2008]--- >>> t (Quarters 1) "2008/01/01" "2009/01/01"--- [DateSpan 2008q1,DateSpan 2008q2,DateSpan 2008q3,DateSpan 2008q4]--- >>> splitSpan (Quarters 1) nulldatespan--- [DateSpan -]--- >>> t (Days 1) "2008/01/01" "2008/01/01"  -- an empty datespan--- []--- >>> t (Quarters 1) "2008/01/01" "2008/01/01"--- []--- >>> t (Months 1) "2008/01/01" "2008/04/01"--- [DateSpan 2008/01,DateSpan 2008/02,DateSpan 2008/03]--- >>> t (Months 2) "2008/01/01" "2008/04/01"--- [DateSpan 2008/01/01-2008/02/29,DateSpan 2008/03/01-2008/04/30]--- >>> t (Weeks 1) "2008/01/01" "2008/01/15"--- [DateSpan 2007/12/31w01,DateSpan 2008/01/07w02,DateSpan 2008/01/14w03]--- >>> t (Weeks 2) "2008/01/01" "2008/01/15"--- [DateSpan 2007/12/31-2008/01/13,DateSpan 2008/01/14-2008/01/27]--- >>> t (DayOfMonth 2) "2008/01/01" "2008/04/01"--- [DateSpan 2007/12/02-2008/01/01,DateSpan 2008/01/02-2008/02/01,DateSpan 2008/02/02-2008/03/01,DateSpan 2008/03/02-2008/04/01]--- >>> t (WeekdayOfMonth 2 4) "2011/01/01" "2011/02/15"--- [DateSpan 2010/12/09-2011/01/12,DateSpan 2011/01/13-2011/02/09,DateSpan 2011/02/10-2011/03/09]--- >>> t (DayOfWeek 2) "2011/01/01" "2011/01/15"--- [DateSpan 2010/12/28-2011/01/03,DateSpan 2011/01/04-2011/01/10,DateSpan 2011/01/11-2011/01/17]--- >>> t (DayOfYear 11 29) "2011/10/01" "2011/10/15"--- [DateSpan 2010/11/29-2011/11/28]--- >>> t (DayOfYear 11 29) "2011/12/01" "2012/12/15"--- [DateSpan 2011/11/29-2012/11/28,DateSpan 2012/11/29-2013/11/28]----splitSpan :: Interval -> DateSpan -> [DateSpan]-splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]-splitSpan _ s | isEmptySpan s = []-splitSpan NoInterval     s = [s]-splitSpan (Days n)       s = splitspan startofday     (applyN n nextday)     s-splitSpan (Weeks n)      s = splitspan startofweek    (applyN n nextweek)    s-splitSpan (Months n)     s = splitspan startofmonth   (applyN n nextmonth)   s-splitSpan (Quarters n)   s = splitspan startofquarter (applyN n nextquarter) s-splitSpan (Years n)      s = splitspan startofyear    (applyN n nextyear)    s-splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (nthdayofmonth n . nextmonth) s-splitSpan (WeekdayOfMonth n wd) s = splitspan (nthweekdayofmonthcontaining n wd) (advancetonthweekday n wd . nextmonth) s-splitSpan (DayOfWeek n)  s = splitspan (nthdayofweekcontaining n)  (applyN (n-1) nextday . nextweek)  s-splitSpan (DayOfYear m n) s = splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s--- splitSpan (WeekOfYear n)    s = splitspan startofweek    (applyN n nextweek)    s--- splitSpan (MonthOfYear n)   s = splitspan startofmonth   (applyN n nextmonth)   s--- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s---- Split the given span using the provided helper functions:--- start is applied to the span's start date to get the first sub-span's start date--- next is applied to a sub-span's start date to get the next sub-span's start date-splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]-splitspan _ _ (DateSpan Nothing Nothing) = []-splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e))-splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s))-splitspan start next span@(DateSpan (Just s) (Just e))-    | s == e = [span]-    | otherwise = splitspan' start next span-    where-      splitspan' start next (DateSpan (Just s) (Just e))-          | s >= e = []-          | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e))-          where subs = start s-                sube = next subs-      splitspan' _ _ _ = error' "won't happen, avoids warnings"---- | Count the days in a DateSpan, or if it is open-ended return Nothing.-daysInSpan :: DateSpan -> Maybe Integer-daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1-daysInSpan _ = Nothing---- | Is this an empty span, ie closed with the end date on or before the start date ?-isEmptySpan :: DateSpan -> Bool-isEmptySpan s = case daysInSpan s of-                  Just n  -> n < 1-                  Nothing -> False---- | Does the span include the given date ?-spanContainsDate :: DateSpan -> Day -> Bool-spanContainsDate (DateSpan Nothing Nothing)   _ = True-spanContainsDate (DateSpan Nothing (Just e))  d = d < e-spanContainsDate (DateSpan (Just b) Nothing)  d = d >= b-spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e---- | Does the period include the given date ?--- (Here to avoid import cycle).-periodContainsDate :: Period -> Day -> Bool-periodContainsDate p = spanContainsDate (periodAsDateSpan p)---- | Calculate the intersection of a number of datespans.-spansIntersect [] = nulldatespan-spansIntersect [d] = d-spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds)---- | Calculate the intersection of two datespans.------ For non-intersecting spans, gives an empty span beginning on the second's start date:--- >>> mkdatespan "2018-01-01" "2018-01-03" `spanIntersect` mkdatespan "2018-01-03" "2018-01-05"--- DateSpan 2018/01/03-2018/01/02-spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e-    where-      b = latest b1 b2-      e = earliest e1 e2---- | Calculate the intersection of two DateSpans, adjusting the start date so--- the interval is preserved.------ >>> let intervalIntersect = spanIntervalIntersect (Days 3)--- >>> mkdatespan "2018-01-01" "2018-01-03" `intervalIntersect` mkdatespan "2018-01-01" "2018-01-05"--- DateSpan 2018/01/01-2018/01/02--- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-02" "2018-01-05"--- DateSpan 2018/01/04--- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-03" "2018-01-05"--- DateSpan 2018/01/04--- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2018-01-04" "2018-01-05"--- DateSpan 2018/01/04--- >>> mkdatespan "2018-01-01" "2018-01-05" `intervalIntersect` mkdatespan "2017-12-01" "2018-01-05"--- DateSpan 2018/01/01-2018/01/04-spanIntervalIntersect :: Interval -> DateSpan -> DateSpan -> DateSpan-spanIntervalIntersect (Days n) (DateSpan (Just b1) e1) sp2@(DateSpan (Just b2) _) =-      DateSpan (Just b) e1 `spanIntersect` sp2-    where-      b = if b1 < b2 then addDays (diffDays b1 b2 `mod` toInteger n) b2 else b1-spanIntervalIntersect _ sp1 sp2 = sp1 `spanIntersect` sp2---- | Fill any unspecified dates in the first span with the dates from--- the second one. Sort of a one-way spanIntersect.-spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b-    where a = if isJust a1 then a1 else a2-          b = if isJust b1 then b1 else b2---- | Calculate the union of a number of datespans.-spansUnion [] = nulldatespan-spansUnion [d] = d-spansUnion (d:ds) = d `spanUnion` (spansUnion ds)---- | Calculate the union of two datespans.-spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e-    where-      b = earliest b1 b2-      e = latest e1 e2--latest d Nothing = d-latest Nothing d = d-latest (Just d1) (Just d2) = Just $ max d1 d2--earliest d Nothing = d-earliest Nothing d = d-earliest (Just d1) (Just d2) = Just $ min d1 d2---- | Parse a period expression to an Interval and overall DateSpan using--- the provided reference date, or return a parse error.-parsePeriodExpr-  :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)-parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)---- | Like parsePeriodExpr, but call error' on failure.-parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)-parsePeriodExpr' refdate s =-  either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $-  parsePeriodExpr refdate s--maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)-maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate---- | Show a DateSpan as a human-readable pseudo-period-expression string.--- dateSpanAsText :: DateSpan -> String--- dateSpanAsText (DateSpan Nothing Nothing)   = "all"--- dateSpanAsText (DateSpan Nothing (Just e))  = printf "to %s" (show e)--- dateSpanAsText (DateSpan (Just b) Nothing)  = printf "from %s" (show b)--- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)---- | Convert a single smart date string to a date span using the provided--- reference date, or raise an error.--- spanFromSmartDateString :: Day -> String -> DateSpan--- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate---     where---       sdate = fromparse $ parsewith smartdateonly s--spanFromSmartDate :: Day -> SmartDate -> DateSpan-spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)-    where-      (ry,rm,_) = toGregorian refdate-      (b,e) = span sdate-      span :: SmartDate -> (Day,Day)-      span ("","","today")       = (refdate, nextday refdate)-      span ("","this","day")     = (refdate, nextday refdate)-      span ("","","yesterday")   = (prevday refdate, refdate)-      span ("","last","day")     = (prevday refdate, refdate)-      span ("","","tomorrow")    = (nextday refdate, addDays 2 refdate)-      span ("","next","day")     = (nextday refdate, addDays 2 refdate)-      span ("","last","week")    = (prevweek refdate, thisweek refdate)-      span ("","this","week")    = (thisweek refdate, nextweek refdate)-      span ("","next","week")    = (nextweek refdate, startofweek $ addDays 14 refdate)-      span ("","last","month")   = (prevmonth refdate, thismonth refdate)-      span ("","this","month")   = (thismonth refdate, nextmonth refdate)-      span ("","next","month")   = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)-      span ("","last","quarter") = (prevquarter refdate, thisquarter refdate)-      span ("","this","quarter") = (thisquarter refdate, nextquarter refdate)-      span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)-      span ("","last","year")    = (prevyear refdate, thisyear refdate)-      span ("","this","year")    = (thisyear refdate, nextyear refdate)-      span ("","next","year")    = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)-      span ("","",d)             = (day, nextday day) where day = fromGregorian ry rm (read d)-      span ("",m,"")             = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1-      span ("",m,d)              = (day, nextday day) where day = fromGregorian ry (read m) (read d)-      span (y,"","")             = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1-      span (y,m,"")              = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1-      span (y,m,d)               = (day, nextday day) where day = fromGregorian (read y) (read m) (read d)---- showDay :: Day -> String--- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day---- | Convert a smart date string to an explicit yyyy\/mm\/dd string using--- the provided reference date, or raise an error.-fixSmartDateStr :: Day -> Text -> String-fixSmartDateStr d s =-  either (error' . printf "could not parse date %s %s" (show s) . show) id $-  (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)---- | A safe version of fixSmartDateStr.-fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) String-fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d--fixSmartDateStrEither'-  :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day-fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of-                               Right sd -> Right $ fixSmartDate d sd-                               Left e -> Left e---- | Convert a SmartDate to an absolute date using the provided reference date.------ ==== Examples:--- >>> :set -XOverloadedStrings--- >>> let t = fixSmartDateStr (parsedate "2008/11/26")--- >>> t "0000-01-01"--- "0000/01/01"--- >>> t "1999-12-02"--- "1999/12/02"--- >>> t "1999.12.02"--- "1999/12/02"--- >>> t "1999/3/2"--- "1999/03/02"--- >>> t "19990302"--- "1999/03/02"--- >>> t "2008/2"--- "2008/02/01"--- >>> t "0020/2"--- "0020/02/01"--- >>> t "1000"--- "1000/01/01"--- >>> t "4/2"--- "2008/04/02"--- >>> t "2"--- "2008/11/02"--- >>> t "January"--- "2008/01/01"--- >>> t "feb"--- "2008/02/01"--- >>> t "today"--- "2008/11/26"--- >>> t "yesterday"--- "2008/11/25"--- >>> t "tomorrow"--- "2008/11/27"--- >>> t "this day"--- "2008/11/26"--- >>> t "last day"--- "2008/11/25"--- >>> t "next day"--- "2008/11/27"--- >>> t "this week"  -- last monday--- "2008/11/24"--- >>> t "last week"  -- previous monday--- "2008/11/17"--- >>> t "next week"  -- next monday--- "2008/12/01"--- >>> t "this month"--- "2008/11/01"--- >>> t "last month"--- "2008/10/01"--- >>> t "next month"--- "2008/12/01"--- >>> t "this quarter"--- "2008/10/01"--- >>> t "last quarter"--- "2008/07/01"--- >>> t "next quarter"--- "2009/01/01"--- >>> t "this year"--- "2008/01/01"--- >>> t "last year"--- "2007/01/01"--- >>> t "next year"--- "2009/01/01"------ t "last wed"--- "2008/11/19"--- t "next friday"--- "2008/11/28"--- t "next january"--- "2009/01/01"----fixSmartDate :: Day -> SmartDate -> Day-fixSmartDate refdate = fix-  where-    fix :: SmartDate -> Day-    fix ("", "", "today") = fromGregorian ry rm rd-    fix ("", "this", "day") = fromGregorian ry rm rd-    fix ("", "", "yesterday") = prevday refdate-    fix ("", "last", "day") = prevday refdate-    fix ("", "", "tomorrow") = nextday refdate-    fix ("", "next", "day") = nextday refdate-    fix ("", "last", "week") = prevweek refdate-    fix ("", "this", "week") = thisweek refdate-    fix ("", "next", "week") = nextweek refdate-    fix ("", "last", "month") = prevmonth refdate-    fix ("", "this", "month") = thismonth refdate-    fix ("", "next", "month") = nextmonth refdate-    fix ("", "last", "quarter") = prevquarter refdate-    fix ("", "this", "quarter") = thisquarter refdate-    fix ("", "next", "quarter") = nextquarter refdate-    fix ("", "last", "year") = prevyear refdate-    fix ("", "this", "year") = thisyear refdate-    fix ("", "next", "year") = nextyear refdate-    fix ("", "", d) = fromGregorian ry rm (read d)-    fix ("", m, "") = fromGregorian ry (read m) 1-    fix ("", m, d) = fromGregorian ry (read m) (read d)-    fix (y, "", "") = fromGregorian (read y) 1 1-    fix (y, m, "") = fromGregorian (read y) (read m) 1-    fix (y, m, d) = fromGregorian (read y) (read m) (read d)-    (ry, rm, rd) = toGregorian refdate--prevday :: Day -> Day-prevday = addDays (-1)-nextday = addDays 1-startofday = id--thisweek = startofweek-prevweek = startofweek . addDays (-7)-nextweek = startofweek . addDays 7-startofweek day = fromMondayStartWeek y w 1-    where-      (y,_,_) = toGregorian day-      (w,_) = mondayStartWeek day--thismonth = startofmonth-prevmonth = startofmonth . addGregorianMonthsClip (-1)-nextmonth = startofmonth . addGregorianMonthsClip 1-startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day-nthdayofmonth d day = fromGregorian y m d where (y,m,_) = toGregorian day--thisquarter = startofquarter-prevquarter = startofquarter . addGregorianMonthsClip (-3)-nextquarter = startofquarter . addGregorianMonthsClip 3-startofquarter day = fromGregorian y (firstmonthofquarter m) 1-    where-      (y,m,_) = toGregorian day-      firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1--thisyear = startofyear-prevyear = startofyear . addGregorianYearsClip (-1)-nextyear = startofyear . addGregorianYearsClip 1-startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day---- | For given date d find year-long interval that starts on given--- MM/DD of year and covers it.--- The given MM and DD should be basically valid (1-12 & 1-31),--- or an error is raised.------ Examples: lets take 2017-11-22. Year-long intervals covering it that--- starts before Nov 22 will start in 2017. However--- intervals that start after Nov 23rd should start in 2016:--- >>> let wed22nd = parsedate "2017-11-22"          --- >>> nthdayofyearcontaining 11 21 wed22nd--- 2017-11-21          --- >>> nthdayofyearcontaining 11 22 wed22nd--- 2017-11-22          --- >>> nthdayofyearcontaining 11 23 wed22nd--- 2016-11-23          --- >>> nthdayofyearcontaining 12 02 wed22nd--- 2016-12-02          --- >>> nthdayofyearcontaining 12 31 wed22nd--- 2016-12-31          --- >>> nthdayofyearcontaining 1 1 wed22nd--- 2017-01-01          -nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day-nthdayofyearcontaining m md date-  | not (validMonth $ show m)  = error' $ "nthdayofyearcontaining: invalid month "++show m-  | not (validDay   $ show md) = error' $ "nthdayofyearcontaining: invalid day "  ++show md-  | mmddOfSameYear <= date = mmddOfSameYear-  | otherwise = mmddOfPrevYear-  where mmddOfSameYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth s-        mmddOfPrevYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth $ prevyear s-        s = startofyear date---- | For given date d find month-long interval that starts on nth day of month--- and covers it. --- The given day of month should be basically valid (1-31), or an error is raised.------ Examples: lets take 2017-11-22. Month-long intervals covering it that--- start on 1st-22nd of month will start in Nov. However--- intervals that start on 23rd-30th of month should start in Oct:--- >>> let wed22nd = parsedate "2017-11-22"          --- >>> nthdayofmonthcontaining 1 wed22nd--- 2017-11-01          --- >>> nthdayofmonthcontaining 12 wed22nd--- 2017-11-12          --- >>> nthdayofmonthcontaining 22 wed22nd--- 2017-11-22          --- >>> nthdayofmonthcontaining 23 wed22nd--- 2017-10-23          --- >>> nthdayofmonthcontaining 30 wed22nd--- 2017-10-30          -nthdayofmonthcontaining :: MonthDay -> Day -> Day-nthdayofmonthcontaining md date-  | not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day "  ++show md-  | nthOfSameMonth <= date = nthOfSameMonth-  | otherwise = nthOfPrevMonth-  where nthOfSameMonth = nthdayofmonth md s-        nthOfPrevMonth = nthdayofmonth md $ prevmonth s-        s = startofmonth date---- | For given date d find week-long interval that starts on nth day of week--- and covers it. ------ Examples: 2017-11-22 is Wed. Week-long intervals that cover it and--- start on Mon, Tue or Wed will start in the same week. However--- intervals that start on Thu or Fri should start in prev week:          --- >>> let wed22nd = parsedate "2017-11-22"          --- >>> nthdayofweekcontaining 1 wed22nd--- 2017-11-20          --- >>> nthdayofweekcontaining 2 wed22nd--- 2017-11-21--- >>> nthdayofweekcontaining 3 wed22nd--- 2017-11-22          --- >>> nthdayofweekcontaining 4 wed22nd--- 2017-11-16          --- >>> nthdayofweekcontaining 5 wed22nd--- 2017-11-17          -nthdayofweekcontaining :: WeekDay -> Day -> Day-nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek-                           | otherwise = nthOfPrevWeek-    where nthOfSameWeek = addDays (fromIntegral n-1) s-          nthOfPrevWeek = addDays (fromIntegral n-1) $ prevweek s-          s = startofweek d---- | For given date d find month-long interval that starts on nth weekday of month--- and covers it. ------ Examples: 2017-11-22 is 3rd Wed of Nov. Month-long intervals that cover it and--- start on 1st-4th Wed will start in Nov. However--- intervals that start on 4th Thu or Fri or later should start in Oct:          --- >>> let wed22nd = parsedate "2017-11-22"          --- >>> nthweekdayofmonthcontaining 1 3 wed22nd--- 2017-11-01--- >>> nthweekdayofmonthcontaining 3 2 wed22nd--- 2017-11-21--- >>> nthweekdayofmonthcontaining 4 3 wed22nd--- 2017-11-22--- >>> nthweekdayofmonthcontaining 4 4 wed22nd--- 2017-10-26--- >>> nthweekdayofmonthcontaining 4 5 wed22nd--- 2017-10-27-nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day-nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d  = nthWeekdaySameMonth-                                   | otherwise = nthWeekdayPrevMonth-    where nthWeekdaySameMonth = advancetonthweekday n wd $ startofmonth d-          nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth d---- | Advance to nth weekday wd after given start day s-advancetonthweekday :: Int -> WeekDay -> Day -> Day-advancetonthweekday n wd s = -  maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s-  where-    err = error' "advancetonthweekday: should not happen"-    addWeeks k = addDays (7 * fromIntegral k)-    firstMatch p = headMay . dropWhile (not . p) -    firstweekday = addDays (fromIntegral wd-1) . startofweek--------------------------------------------------------------------------- parsing---- -- | Parse a couple of date-time string formats to a time type.--- parsedatetimeM :: String -> Maybe LocalTime--- parsedatetimeM s = firstJust [---     parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,---     parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s---     ]--parsetime :: ParseTime t => TimeLocale -> String -> String -> Maybe t-parsetime =-#if MIN_VERSION_time(1,5,0)-     parseTimeM True-#else-     parseTime-#endif----- | Parse a couple of date string formats to a time type.-parsedateM :: String -> Maybe Day-parsedateM s = firstJust [-     parsetime defaultTimeLocale "%Y/%m/%d" s,-     parsetime defaultTimeLocale "%Y-%m-%d" s-     ]----- -- | Parse a date-time string to a time type, or raise an error.--- parsedatetime :: String -> LocalTime--- parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"")---                             (parsedatetimeM s)---- | Parse a YYYY-MM-DD or YYYY/MM/DD date string to a Day, or raise an error. For testing/debugging.------ >>> parsedate "2008/02/03"--- 2008-02-03-parsedate :: String -> Day-parsedate s =  fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"")-                         (parsedateM s)--- doctests I haven't been able to make compatible with both GHC 7 and 8--- -- >>> parsedate "2008/02/03/"--- -- *** Exception: could not parse date "2008/02/03/"--- #if MIN_VERSION_base(4,9,0)--- -- ...--- #endif--- #if MIN_VERSION_time(1,6,0)--- -- >>> parsedate "2008/02/30"  -- with time >= 1.6, invalid dates are rejected--- -- *** Exception: could not parse date "2008/02/30"--- #if MIN_VERSION_base(4,9,0)--- -- ...--- #endif--- #else--- -- >>> parsedate "2008/02/30"  -- with time < 1.6, they are silently adjusted--- -- 2008-02-29--- #endif--{-|-Parse a date in any of the formats allowed in Ledger's period expressions, and some others.-Assumes any text in the parse stream has been lowercased.-Returns a SmartDate, to be converted to a full date later (see fixSmartDate).--Examples:--> 2004                                        (start of year, which must have 4+ digits)-> 2004/10                                     (start of month, which must be 1-12)-> 2004/10/1                                   (exact date, day must be 1-31)-> 10/1                                        (month and day in current year)-> 21                                          (day in current month)-> october, oct                                (start of month in current year)-> yesterday, today, tomorrow                  (-1, 0, 1 days from today)-> last/this/next day/week/month/quarter/year  (-1, 0, 1 periods from the current period)-> 20181201                                    (8 digit YYYYMMDD with valid year month and day)-> 201812                                      (6 digit YYYYMM with valid year and month)--Note malformed digit sequences might give surprising results:--> 201813                                      (6 digits with an invalid month is parsed as start of 6-digit year)-> 20181301                                    (8 digits with an invalid month is parsed as start of 8-digit year)-> 20181232                                    (8 digits with an invalid day gives an error)-> 201801012                                   (9+ digits beginning with a valid YYYYMMDD gives an error)--Eg:--YYYYMMDD is parsed as year-month-date if those parts are valid-(>=4 digits, 1-12, and 1-31 respectively):->>> parsewith (smartdate <* eof) "20181201"-Right ("2018","12","01")--YYYYMM is parsed as year-month-01 if year and month are valid:->>> parsewith (smartdate <* eof) "201804"-Right ("2018","04","01")--With an invalid month, it's parsed as a year:->>> parsewith (smartdate <* eof) "201813"-Right ("201813","","")--A 9+ digit number beginning with valid YYYYMMDD gives an error:->>> parsewith (smartdate <* eof) "201801012"-Left (...)--Big numbers not beginning with a valid YYYYMMDD are parsed as a year:->>> parsewith (smartdate <* eof) "201813012"-Right ("201813012","","")---}-smartdate :: TextParser m SmartDate-smartdate = do-  -- XXX maybe obscures date errors ? see ledgerdate-  (y,m,d) <- choice' [yyyymmdd, yyyymm, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]-  return (y,m,d)---- | Like smartdate, but there must be nothing other than whitespace after the date.-smartdateonly :: TextParser m SmartDate-smartdateonly = do-  d <- smartdate-  skipMany spacenonewline-  eof-  return d--datesepchars :: String-datesepchars = "/-."--datesepchar :: TextParser m Char-datesepchar = satisfy isDateSepChar--isDateSepChar :: Char -> Bool-isDateSepChar c = c == '/' || c == '-' || c == '.'--validYear, validMonth, validDay :: String -> Bool-validYear s = length s >= 4 && isJust (readMay s :: Maybe Year)-validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s-validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s--failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m ()-failIfInvalidYear s  = unless (validYear s)  $ fail $ "bad year number: " ++ s-failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s-failIfInvalidDay s   = unless (validDay s)   $ fail $ "bad day number: " ++ s--yyyymmdd :: TextParser m SmartDate-yyyymmdd = do-  y <- count 4 digitChar-  m <- count 2 digitChar-  failIfInvalidMonth m-  d <- count 2 digitChar-  failIfInvalidDay d-  return (y,m,d)--yyyymm :: TextParser m SmartDate-yyyymm = do-  y <- count 4 digitChar-  m <- count 2 digitChar-  failIfInvalidMonth m-  return (y,m,"01")--ymd :: TextParser m SmartDate-ymd = do-  y <- some digitChar-  failIfInvalidYear y-  sep <- datesepchar-  m <- some digitChar-  failIfInvalidMonth m-  char sep-  d <- some digitChar-  failIfInvalidDay d-  return $ (y,m,d)--ym :: TextParser m SmartDate-ym = do-  y <- some digitChar-  failIfInvalidYear y-  datesepchar-  m <- some digitChar-  failIfInvalidMonth m-  return (y,m,"")--y :: TextParser m SmartDate-y = do-  y <- some digitChar-  failIfInvalidYear y-  return (y,"","")--d :: TextParser m SmartDate-d = do-  d <- some digitChar-  failIfInvalidDay d-  return ("","",d)--md :: TextParser m SmartDate-md = do-  m <- some digitChar-  failIfInvalidMonth m-  datesepchar-  d <- some digitChar-  failIfInvalidDay d-  return ("",m,d)---- These are compared case insensitively, and should all be kept lower case. -months         = ["january","february","march","april","may","june",-                  "july","august","september","october","november","december"]-monthabbrevs   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]-weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]-weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]---- | Convert a case insensitive english month name to a month number.-monthIndex name = maybe 0 (+1) $ T.toLower name `elemIndex` months---- | Convert a case insensitive english three-letter month abbreviation to a month number.-monIndex   name = maybe 0 (+1) $ T.toLower name `elemIndex` monthabbrevs--month :: TextParser m SmartDate-month = do-  m <- choice $ map (try . string') months-  let i = monthIndex m-  return ("",show i,"")--mon :: TextParser m SmartDate-mon = do-  m <- choice $ map (try . string') monthabbrevs-  let i = monIndex m-  return ("",show i,"")--weekday :: TextParser m Int-weekday = do-  wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)-  case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of-    (i:_) -> return (i+1)-    []    -> fail  $ "weekday: should not happen: attempted to find " <> -                      show wday <> " in " <> show (weekdays ++ weekdayabbrevs) --today,yesterday,tomorrow :: TextParser m SmartDate-today     = string' "today"     >> return ("","","today")-yesterday = string' "yesterday" >> return ("","","yesterday")-tomorrow  = string' "tomorrow"  >> return ("","","tomorrow")--lastthisnextthing :: TextParser m SmartDate-lastthisnextthing = do-  r <- choice $ map string' [-        "last"-       ,"this"-       ,"next"-      ]-  skipMany spacenonewline  -- make the space optional for easier scripting-  p <- choice $ map string' [-        "day"-       ,"week"-       ,"month"-       ,"quarter"-       ,"year"-      ]--- XXX support these in fixSmartDate---       ++ (map string' $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)--  return ("", T.unpack r, T.unpack p)---- |--- >>> let p = parsePeriodExpr (parsedate "2008/11/26")--- >>> p "from Aug to Oct"--- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)--- >>> p "aug to oct"--- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)--- >>> p "every 3 days in Aug"--- Right (Days 3,DateSpan 2008/08)--- >>> p "daily from aug"--- Right (Days 1,DateSpan 2008/08/01-)--- >>> p "every week to 2009"--- Right (Weeks 1,DateSpan -2008/12/31)--- >>> p "every 2nd day of month"--- Right (DayOfMonth 2,DateSpan -)--- >>> p "every 2nd day"--- Right (DayOfMonth 2,DateSpan -)--- >>> p "every 2nd day 2009-"--- Right (DayOfMonth 2,DateSpan 2009/01/01-)  --- >>> p "every 29th Nov"--- Right (DayOfYear 11 29,DateSpan -)--- >>> p "every 29th nov -2009"--- Right (DayOfYear 11 29,DateSpan -2008/12/31)--- >>> p "every nov 29th"--- Right (DayOfYear 11 29,DateSpan -)--- >>> p "every Nov 29th 2009-"--- Right (DayOfYear 11 29,DateSpan 2009/01/01-)--- >>> p "every 11/29 from 2009"--- Right (DayOfYear 11 29,DateSpan 2009/01/01-)--- >>> p "every 2nd Thursday of month to 2009"--- Right (WeekdayOfMonth 2 4,DateSpan -2008/12/31)--- >>> p "every 1st monday of month to 2009"--- Right (WeekdayOfMonth 1 1,DateSpan -2008/12/31)--- >>> p "every tue"--- Right (DayOfWeek 2,DateSpan -)--- >>> p "every 2nd day of week"--- Right (DayOfWeek 2,DateSpan -)--- >>> p "every 2nd day of month"--- Right (DayOfMonth 2,DateSpan -)--- >>> p "every 2nd day"--- Right (DayOfMonth 2,DateSpan -)--- >>> p "every 2nd day 2009-"--- Right (DayOfMonth 2,DateSpan 2009/01/01-)--- >>> p "every 2nd day of month 2009-"--- Right (DayOfMonth 2,DateSpan 2009/01/01-)-periodexprp :: Day -> TextParser m (Interval, DateSpan)-periodexprp rdate = do-  skipMany spacenonewline-  choice $ map try [-                    intervalanddateperiodexprp rdate,-                    (,) NoInterval <$> periodexprdatespanp rdate-                   ]--intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)-intervalanddateperiodexprp rdate = do-  i <- reportingintervalp-  s <- option def . try $ do-      skipMany spacenonewline-      periodexprdatespanp rdate-  return (i,s)---- Parse a reporting interval.-reportingintervalp :: TextParser m Interval-reportingintervalp = choice' [-                       tryinterval "day"     "daily"     Days,-                       tryinterval "week"    "weekly"    Weeks,-                       tryinterval "month"   "monthly"   Months,-                       tryinterval "quarter" "quarterly" Quarters,-                       tryinterval "year"    "yearly"    Years,-                       do string' "biweekly"-                          return $ Weeks 2,-                       do string' "bimonthly"-                          return $ Months 2,-                       do string' "every"-                          skipMany spacenonewline-                          n <- nth-                          skipMany spacenonewline-                          string' "day"-                          of_ "week"-                          return $ DayOfWeek n,-                       do string' "every"-                          skipMany spacenonewline-                          DayOfWeek <$> weekday,-                       do string' "every"-                          skipMany spacenonewline-                          n <- nth-                          skipMany spacenonewline-                          string' "day"-                          optOf_ "month"-                          return $ DayOfMonth n,-                       do string' "every"-                          let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m)-                          d_o_y <- runPermutation $-                            DayOfYear <$> toPermutation (try (skipMany spacenonewline *> mnth))-                                      <*> toPermutation (try (skipMany spacenonewline *> nth))-                          optOf_ "year"-                          return d_o_y,-                       do string' "every"-                          skipMany spacenonewline-                          ("",m,d) <- md-                          optOf_ "year"-                          return $ DayOfYear (read m) (read d),-                       do string' "every"-                          skipMany spacenonewline-                          n <- nth-                          skipMany spacenonewline-                          wd <- weekday-                          optOf_ "month"-                          return $ WeekdayOfMonth n wd-                    ]-    where-      of_ period = do-        skipMany spacenonewline-        string' "of"-        skipMany spacenonewline-        string' period-        -      optOf_ period = optional $ try $ of_ period-      -      nth = do n <- some digitChar-               choice' $ map string' ["st","nd","rd","th"]-               return $ read n--      -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".-      tryinterval :: String -> String -> (Int -> Interval) -> TextParser m Interval-      tryinterval singular compact intcons =-        choice' [-          do string' compact'-             return $ intcons 1,-          do string' "every"-             skipMany spacenonewline-             string' singular'-             return $ intcons 1,-          do string' "every"-             skipMany spacenonewline-             n <- read <$> some digitChar-             skipMany spacenonewline-             string' plural'-             return $ intcons n-          ]-        where-          compact'  = T.pack compact-          singular' = T.pack singular-          plural'   = T.pack $ singular ++ "s"--periodexprdatespanp :: Day -> TextParser m DateSpan-periodexprdatespanp rdate = choice $ map try [-                            doubledatespanp rdate,-                            fromdatespanp rdate,-                            todatespanp rdate,-                            justdatespanp rdate-                           ]---- |--- -- >>> parsewith (doubledatespan (parsedate "2018/01/01") <* eof) "20180101-201804"--- Right DateSpan 2018/01/01-2018/04/01-doubledatespanp :: Day -> TextParser m DateSpan-doubledatespanp rdate = do-  optional (string' "from" >> skipMany spacenonewline)-  b <- smartdate-  skipMany spacenonewline-  optional (choice [string' "to", string' "-"] >> skipMany spacenonewline)-  DateSpan (Just $ fixSmartDate rdate b) . Just . fixSmartDate rdate <$> smartdate--fromdatespanp :: Day -> TextParser m DateSpan-fromdatespanp rdate = do-  b <- choice [-    do-      string' "from" >> skipMany spacenonewline-      smartdate-    ,-    do-      d <- smartdate-      string' "-"-      return d-    ]-  return $ DateSpan (Just $ fixSmartDate rdate b) Nothing--todatespanp :: Day -> TextParser m DateSpan-todatespanp rdate = do-  choice [string' "to", string' "-"] >> skipMany spacenonewline-  DateSpan Nothing . Just . fixSmartDate rdate <$> smartdate--justdatespanp :: Day -> TextParser m DateSpan-justdatespanp rdate = do-  optional (string' "in" >> skipMany spacenonewline)-  spanFromSmartDate rdate <$> smartdate---- | Make a datespan from two valid date strings parseable by parsedate--- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\".-mkdatespan :: String -> String -> DateSpan-mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate--nulldatespan :: DateSpan-nulldatespan = DateSpan Nothing Nothing---- | A datespan of zero length, that matches no date.-emptydatespan :: DateSpan-emptydatespan = DateSpan (Just $ addDays 1 nulldate) (Just nulldate)+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE NoMonoLocalBinds    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-|++Date parsing and utilities for hledger.++For date and time values, we use the standard Day and UTCTime types.++A 'SmartDate' is a date which may be partially-specified or relative.+Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year,+in 5 days, in -3 quarters.+We represent these as a triple of strings like (\"2008\",\"12\",\"\"),+(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").++A 'DateSpan' is the span of time between two specific calendar dates, or+an open-ended span where one or both dates are unspecified. (A date span+with both ends unspecified matches all dates.)++An 'Interval' is ledger's \"reporting interval\" - weekly, monthly,+quarterly, etc.++'Period' will probably replace DateSpan in due course.++-}++-- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?++module Hledger.Data.Dates (+  -- * Misc date handling utilities+  fromEFDay,+  modifyEFDay,+  getCurrentDay,+  getCurrentMonth,+  getCurrentYear,+  nulldate,+  spanContainsDate,+  periodContainsDate,+  parsedate,+  showDate,+  showEFDate,+  showDateSpan,+  showDateSpanDebug,+  showDateSpanAbbrev,+  elapsedSeconds,+  prevday,+  periodexprp,+  parsePeriodExpr,+  parsePeriodExpr',+  nulldatespan,+  emptydatespan,+  datesepchar,+  datesepchars,+  isDateSepChar,+  spanStart,+  spanEnd,+  spanStartYear,+  spanEndYear,+  spanYears,+  spansSpan,+  spanIntersect,+  spansIntersect,+  spanDefaultsFrom,+  spanValidDefaultsFrom,+  spanExtend,+  spanUnion,+  spansUnion,+  daysSpan,+  latestSpanContaining,+  smartdate,+  groupByDateSpan,+  fixSmartDate,+  fixSmartDateStr,+  fixSmartDateStrEither,+  fixSmartDateStrEither',+  yearp,+  daysInSpan,++  -- Temp exports+  startofyear,+  startofquarter,+  startofmonth,+  startofweek,+  nextday,+  nextweek,+  nextmonthandday,+  nextnthdayofmonth,+  prevNthWeekdayOfMonth,+  nthdayofweekcontaining,+  addGregorianMonthsToMonthday,+  advanceToNthWeekday,+  nextNthWeekdayOfMonth,+  isEmptySpan+) where++import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..))+import Control.Applicative.Permutations+import Control.Monad (guard, unless)+import Control.Monad.Fail qualified as Fail (MonadFail, fail)+import Data.Char (digitToInt, isDigit)+import Data.Default (def)+import Data.Foldable (asum)+import Data.Function (on)+import Data.Functor (($>))+import Data.List (elemIndex, group, sort, sortBy)+import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)+import Data.Ord (comparing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Format hiding (months)+import Data.Time.Calendar+    (Day, addDays, addGregorianYearsClip, addGregorianMonthsClip, diffDays,+     fromGregorian, fromGregorianValid, toGregorian)+import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek)+import Data.Time.Clock (UTCTime, diffUTCTime)+import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime)+import Safe (headErr, headMay, lastMay, maximumMay, minimumMay)+import Text.Megaparsec+import Text.Megaparsec.Char (char, char', digitChar, string, string')+import Text.Megaparsec.Char.Lexer (decimal, signed)+import Text.Printf (printf)++import Hledger.Data.Types+import Hledger.Data.Period+import Hledger.Utils+++-- Help ppShow parse and line-wrap DateSpans better in debug output.+instance Show DateSpan where+    show s = "DateSpan " ++ T.unpack (showDateSpan s)++showDate :: Day -> Text+showDate = T.pack . show++showEFDate :: EFDay -> Text+showEFDate = showDate . fromEFDay++-- | Render a datespan as a display string, abbreviating into a+-- compact form if possible.+-- Warning, hides whether dates are Exact or Flex.+showDateSpan :: DateSpan -> Text+showDateSpan = showPeriod . dateSpanAsPeriod++-- | Show a DateSpan with its begin/end dates, exact or flex.+showDateSpanDebug :: DateSpan -> String+showDateSpanDebug (DateSpan b e)= "DateSpan (" <> show b <> ") (" <> show e <> ")"++-- | Like showDateSpan, but show month spans as just the abbreviated month name+-- in the current locale.+showDateSpanAbbrev :: DateSpan -> Text+showDateSpanAbbrev = showPeriodAbbrev . dateSpanAsPeriod++-- | Get the current local date.+getCurrentDay :: IO Day+getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime++-- | Get the current local month number.+getCurrentMonth :: IO Int+getCurrentMonth = second3 . toGregorian <$> getCurrentDay++-- | Get the current local year.+getCurrentYear :: IO Integer+getCurrentYear = first3 . toGregorian <$> getCurrentDay++elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a+elapsedSeconds t1 = realToFrac . diffUTCTime t1++spanStart :: DateSpan -> Maybe Day+spanStart (DateSpan d _) = fromEFDay <$> d++spanEnd :: DateSpan -> Maybe Day+spanEnd (DateSpan _ d) = fromEFDay <$> d++spanStartDate :: DateSpan -> Maybe EFDay+spanStartDate (DateSpan d _) = d++spanEndDate :: DateSpan -> Maybe EFDay+spanEndDate (DateSpan _ d) = d++spanStartYear :: DateSpan -> Maybe Year+spanStartYear (DateSpan d _) = fmap (first3 . toGregorian . fromEFDay) d++spanEndYear :: DateSpan -> Maybe Year+spanEndYear (DateSpan d _) = fmap (first3 . toGregorian. fromEFDay) d++-- | Get the 0-2 years mentioned explicitly in a DateSpan.+spanYears :: DateSpan -> [Year]+spanYears (DateSpan ma mb) = mapMaybe (fmap (first3 . toGregorian. fromEFDay)) [ma,mb]++-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra++-- | Get overall span enclosing multiple sequentially ordered spans.+-- The start and end date will be exact or flexible depending on+-- the first span's start date and last span's end date.+spansSpan :: [DateSpan] -> DateSpan+spansSpan spans = DateSpan (spanStartDate =<< headMay spans) (spanEndDate =<< lastMay spans)++-- Like addGregorianMonthsClip, add one month to the given date, clipping when needed+-- to fit it within the next month's length. But also, keep a target day of month in mind,+-- and revert to that or as close to it as possible in subsequent longer months.+-- Eg, using it to step through 31sts gives 1/31, 2/28, 3/31, 4/30, 5/31..+addGregorianMonthsToMonthday :: MonthDay -> Integer -> Day -> Day+addGregorianMonthsToMonthday dom n d =+  let (y,m,_) = toGregorian $ addGregorianMonthsClip n d+  in fromGregorian y m dom++-- | Count the days in a DateSpan, or if it is open-ended return Nothing.+daysInSpan :: DateSpan -> Maybe Integer+daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays (fromEFDay d2) (fromEFDay d1)+daysInSpan _ = Nothing++-- | Is this an empty span, ie closed with the end date on or before the start date ?+isEmptySpan :: DateSpan -> Bool+isEmptySpan (DateSpan (Just s) (Just e)) = e <= s+isEmptySpan _                            = False++-- | Does the span include the given date ?+spanContainsDate :: DateSpan -> Day -> Bool+spanContainsDate (DateSpan Nothing Nothing)   _ = True+spanContainsDate (DateSpan Nothing (Just e))  d = d < fromEFDay e+spanContainsDate (DateSpan (Just b) Nothing)  d = d >= fromEFDay b+spanContainsDate (DateSpan (Just b) (Just e)) d = d >= fromEFDay b && d < fromEFDay e++-- | Does the period include the given date ?+-- (Here to avoid import cycle).+periodContainsDate :: Period -> Day -> Bool+periodContainsDate p = spanContainsDate (periodAsDateSpan p)++-- | Group elements based on where they fall in a list of 'DateSpan's without+-- gaps. The precondition is not checked.+groupByDateSpan :: Bool -> (a -> Day) -> [DateSpan] -> [a] -> [(DateSpan, [a])]+groupByDateSpan showempty date colspans =+      groupByCols colspans+    . dropWhile (beforeStart . fst)+    . sortBy (comparing fst)+    . map (\x -> (date x, x))+  where+    groupByCols []     _  = []+    groupByCols (c:cs) [] = if showempty then (c, []) : groupByCols cs [] else []+    groupByCols (c:cs) ps = (c, map snd colps) : groupByCols cs laterps+      where (colps, laterps) = span ((spanEnd c >) . Just . fst) ps++    beforeStart = maybe (const False) (>) $ spanStart =<< headMay colspans++-- | Calculate the intersection of a number of datespans.+spansIntersect [] = nulldatespan+spansIntersect [d] = d+spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds)++-- | Calculate the union of a number of datespans.+spansUnion [] = nulldatespan+spansUnion [d] = d+spansUnion (d:ds) = d `spanUnion` (spansUnion ds)++-- | Calculate the intersection of two datespans.+--+-- For non-intersecting spans, gives an empty span beginning on the second's start date:+-- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05)+-- DateSpan 2018-01-03..2018-01-02+spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (laterDefinite b1 b2) (earlierDefinite e1 e2)++-- | Fill any unspecified dates in the first span with the dates from+-- the second one (if specified there). Sort of a one-way spanIntersect.+-- This one can create an invalid span that'll always be empty.+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) Nothing+--  `spanDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2024-01-01+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing+--  `spanDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2025-01-01..2024-01-01+--+spanDefaultsFrom :: DateSpan -> DateSpan -> DateSpan+spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b+    where a = if isJust a1 then a1 else a2+          b = if isJust b1 then b1 else b2++-- | A smarter version of spanDefaultsFrom that avoids creating invalid+-- spans ending before they begin. Kept separate for now to reduce risk.+--+-- >>> :{+--  DateSpan (Just $ Exact $ fromGregorian 2025 1 1) Nothing+--  `spanValidDefaultsFrom`+--  DateSpan (Just $ Exact $ fromGregorian 2024 1 1) (Just $ Exact $ fromGregorian 2024 1 2)+-- :}+-- DateSpan 2025-01-01..+--+spanValidDefaultsFrom :: DateSpan -> DateSpan -> DateSpan+spanValidDefaultsFrom s1 s2 =+  case s1 `spanDefaultsFrom` s2 of+    DateSpan b e | b >= e -> s1+    s -> s++-- | Calculate the union of two datespans.+-- If either span is open-ended, the union will be too.+--+-- >>> ys2024 = fromGregorian 2024 01 01+-- >>> ys2025 = fromGregorian 2025 01 01+-- >>> to2024 = DateSpan Nothing               (Just $ Exact ys2024)+-- >>> in2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)+-- >>> spanUnion to2024 in2024+-- DateSpan ..2024-12-31+-- >>> spanUnion in2024 to2024+-- DateSpan ..2024-12-31+spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlier b1 b2) (later e1 e2)++-- | Extend the definite start/end dates of the first span, if needed,+-- to include the definite start/end dates of the second span.+-- And/or, replace open start/end dates in the first span with+-- definite start/end dates from the second.+-- Unlike spanUnion, open start/end dates in the second are ignored.+--+-- >>> ys2024 = fromGregorian 2024 01 01+-- >>> ys2025 = fromGregorian 2025 01 01+-- >>> to2024 = DateSpan Nothing               (Just $ Exact ys2024)+-- >>> all2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025)+-- >>> partof2024 = DateSpan (Just $ Exact $ fromGregorian 2024 03 01) (Just $ Exact $ fromGregorian 2024 09 01)+-- >>> spanExtend to2024 all2024+-- DateSpan 2024+-- >>> spanExtend all2024 to2024+-- DateSpan 2024+-- >>> spanExtend partof2024 all2024+-- DateSpan 2024+-- >>> spanExtend all2024 partof2024+-- DateSpan 2024+--+spanExtend (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlierDefinite b1 b2) (laterDefinite e1 e2)++-- | Pick the earlier of two DateSpan starts, treating Nothing as infinitely early.+-- An Exact and Flex with the same date are considered equal; the first argument wins.+earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay+earlier = min++-- | Pick the later of two DateSpan starts, treating Nothing as infinitely late.+-- An Exact and Flex with the same date are considered equal; the second argument wins.+later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay+later _ Nothing = Nothing+later Nothing _ = Nothing+later d1 d2     = max d1 d2++-- | Pick the earlier of two DateSpan ends that is a definite date (if any).+-- An Exact and Flex with the same date are considered equal; the first argument wins.+earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay+earlierDefinite d1 Nothing = d1+earlierDefinite Nothing d2 = d2+earlierDefinite d1 d2      = min d1 d2++-- | Pick the later of two DateSpan ends that is a definite date (if any).+-- An Exact and Flex with the same date are considered equal; the second argument wins.+laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay+laterDefinite d1 Nothing = d1+laterDefinite Nothing d2 = d2+laterDefinite d1 d2      = max d1 d2++-- | Calculate the minimal DateSpan containing all of the given Days (in the+-- usual exclusive-end-date sense: beginning on the earliest, and ending on+-- the day after the latest).+daysSpan :: [Day] -> DateSpan+daysSpan ds = DateSpan (Exact <$> minimumMay ds) (Exact . addDays 1 <$> maximumMay ds)++-- | Select the DateSpan containing a given Day, if any, from a given list of+-- DateSpans.+--+-- If the DateSpans are non-overlapping, this returns the unique containing+-- DateSpan, if it exists. If the DateSpans are overlapping, it will return the+-- containing DateSpan with the latest start date, and then latest end date.++-- Note: This will currently return `DateSpan (Just s) (Just e)` before it will+-- return `DateSpan (Just s) Nothing`. It's unclear which behaviour is desired.+-- This is irrelevant at the moment as it's never applied to any list with+-- overlapping DateSpans.+latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan+latestSpanContaining datespans = go+  where+    go day = do+        spn <- Set.lookupLT supSpan spanSet+        guard $ spanContainsDate spn day+        return spn+      where+        -- The smallest DateSpan larger than any DateSpan containing day.+        supSpan = DateSpan (Just $ Exact $ addDays 1 day) Nothing++    spanSet = Set.fromList $ filter (not . isEmptySpan) datespans++-- | Parse a period expression to an Interval and overall DateSpan using+-- the provided reference date, or return a parse error.+parsePeriodExpr+  :: Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)+parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)++-- | Like parsePeriodExpr, but call error' on failure.+parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)+parsePeriodExpr' refdate s =+  either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $  -- PARTIAL:+  parsePeriodExpr refdate s++-- | Show a DateSpan as a human-readable pseudo-period-expression string.+-- dateSpanAsText :: DateSpan -> String+-- dateSpanAsText (DateSpan Nothing Nothing)   = "all"+-- dateSpanAsText (DateSpan Nothing (Just e))  = printf "to %s" (show e)+-- dateSpanAsText (DateSpan (Just b) Nothing)  = printf "from %s" (show b)+-- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)++-- | Convert a single smart date string to a date span using the provided+-- reference date, or raise an error.+-- spanFromSmartDateString :: Day -> String -> DateSpan+-- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate+--     where+--       sdate = fromparse $ parsewith smartdateonly s++spanFromSmartDate :: Day -> SmartDate -> DateSpan+spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)+    where+      (ry,rm,_) = toGregorian refdate+      (b,e) = span' sdate+        where+          span' :: SmartDate -> (EFDay, EFDay)+          span' (SmartCompleteDate day)       = (Exact day, Exact $ nextday day)+          span' (SmartAssumeStart y Nothing)  = (Flex $ startofyear day, Flex $ nextyear day) where day = fromGregorian y 1 1+          span' (SmartAssumeStart y (Just m)) = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian y m 1+          span' (SmartFromReference m d)      = (Exact day, Exact $ nextday day) where day = fromGregorian ry (fromMaybe rm m) d+          span' (SmartMonth m)                = (Flex $ startofmonth day, Flex $ nextmonth day) where day = fromGregorian ry m 1+          span' (SmartRelative n Day)         = (Exact $ addDays n refdate, Exact $ addDays (n+1) refdate)+          span' (SmartRelative n Week)        = (Flex $ addDays (7*n) d, Flex $ addDays (7*n+7) d) where d = thisweek refdate+          span' (SmartRelative n Month)       = (Flex $ addGregorianMonthsClip n d, Flex $ addGregorianMonthsClip (n+1) d) where d = thismonth refdate+          span' (SmartRelative n Quarter)     = (Flex $ addGregorianMonthsClip (3*n) d, Flex $ addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate+          span' (SmartRelative n Year)        = (Flex $ addGregorianYearsClip n d, Flex $ addGregorianYearsClip (n+1) d) where d = thisyear refdate+          span' (SmartRelativeMonth   LT m)   = (Flex d, Flex $ nextmonth d) where d = prevnamedmonth m refdate+          span' (SmartRelativeMonth   EQ m)   = (Flex d, Flex $ nextmonth d) where d = thisnamedmonth m refdate+          span' (SmartRelativeMonth   GT m)   = (Flex d, Flex $ nextmonth d) where d = nextnamedmonth m refdate+          span' (SmartRelativeWeekDay LT wd)  = (Exact d, Exact $ nextday d) where d = prevnamedweekday wd refdate+          span' (SmartRelativeWeekDay EQ wd)  = (Exact d, Exact $ nextday d) where d = thisnamedweekday wd refdate+          span' (SmartRelativeWeekDay GT wd)  = (Exact d, Exact $ nextday d) where d = nextnamedweekday wd refdate++-- showDay :: Day -> String+-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day++-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using+-- the provided reference date, or raise an error.+fixSmartDateStr :: Day -> Text -> Text+fixSmartDateStr d s =+  either (error' . printf "could not parse date %s %s" (show s) . show) id $  -- PARTIAL:+  (fixSmartDateStrEither d s :: Either HledgerParseErrors Text)++-- | A safe version of fixSmartDateStr.+fixSmartDateStrEither :: Day -> Text -> Either HledgerParseErrors Text+fixSmartDateStrEither d = fmap showEFDate . fixSmartDateStrEither' d++fixSmartDateStrEither' :: Day -> Text -> Either HledgerParseErrors EFDay+fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of+                               Right sd -> Right $ fixSmartDate d sd+                               Left e -> Left e++-- | Convert a SmartDate to a specific date using the provided reference date.+-- This date will be exact or flexible depending on whether the day was+-- specified exactly. (Missing least-significant parts produces a flex date.)+--+-- ==== Examples:+-- >>> :set -XOverloadedStrings+-- >>> let t = fixSmartDateStr (fromGregorian 2008 11 26)+-- >>> t "0000-01-01"+-- "0000-01-01"+-- >>> t "1999-12-02"+-- "1999-12-02"+-- >>> t "1999.12.02"+-- "1999-12-02"+-- >>> t "1999/3/2"+-- "1999-03-02"+-- >>> t "19990302"+-- "1999-03-02"+-- >>> t "2008/2"+-- "2008-02-01"+-- >>> t "0020/2"+-- "0020-02-01"+-- >>> t "1000"+-- "1000-01-01"+-- >>> t "4/2"+-- "2008-04-02"+-- >>> t "2"+-- "2008-11-02"+-- >>> t "January"+-- "2008-01-01"+-- >>> t "feb"+-- "2008-02-01"+-- >>> t "today"+-- "2008-11-26"+-- >>> t "yesterday"+-- "2008-11-25"+-- >>> t "tomorrow"+-- "2008-11-27"+-- >>> t "this day"+-- "2008-11-26"+-- >>> t "last day"+-- "2008-11-25"+-- >>> t "next day"+-- "2008-11-27"+-- >>> t "this week"  -- last monday+-- "2008-11-24"+-- >>> t "last week"  -- previous monday+-- "2008-11-17"+-- >>> t "next week"  -- next monday+-- "2008-12-01"+-- >>> t "this month"+-- "2008-11-01"+-- >>> t "last month"+-- "2008-10-01"+-- >>> t "next month"+-- "2008-12-01"+-- >>> t "this quarter"+-- "2008-10-01"+-- >>> t "last quarter"+-- "2008-07-01"+-- >>> t "next quarter"+-- "2009-01-01"+-- >>> t "this year"+-- "2008-01-01"+-- >>> t "last year"+-- "2007-01-01"+-- >>> t "next year"+-- "2009-01-01"+--+-- refdate is Wednesday, 2008-11-26+-- >>> t "last wednesday"+-- "2008-11-19"+-- >>> t "this wednesday"+-- "2008-12-03"+-- >>> t "next wednesday"+-- "2008-12-03"+-- >>> t "last january"+-- "2008-01-01"+-- >>> t "this january"+-- "2009-01-01"+-- >>> t "next january"+-- "2009-01-01"+-- >>> t "last november"+-- "2007-11-01"+-- >>> t "this november"+-- "2009-11-01"+-- >>> t "next november"+-- "2009-11-01"+--+-- >>> t "in 5 days"+-- "2008-12-01"+-- >>> t "in 7 months"+-- "2009-06-01"+-- >>> t "in -2 weeks"+-- "2008-11-10"+-- >>> t "1 quarter ago"+-- "2008-07-01"+-- >>> t "1 week ahead"+-- "2008-12-01"+fixSmartDate :: Day -> SmartDate -> EFDay+fixSmartDate refdate = fix+  where+    fix :: SmartDate -> EFDay+    fix (SmartCompleteDate d)     = Exact d+    fix (SmartAssumeStart y m)    = Flex  $ fromGregorian y (fromMaybe 1 m) 1+    fix (SmartFromReference m d)  = Exact $ fromGregorian ry (fromMaybe rm m) d+    fix (SmartMonth m)            = Flex  $ fromGregorian ry m 1+    fix (SmartRelative n Day)     = Exact $ addDays n refdate+    fix (SmartRelative n Week)    = Flex  $ addDays (7*n) $ thisweek refdate+    fix (SmartRelative n Month)   = Flex  $ addGregorianMonthsClip n $ thismonth refdate+    fix (SmartRelative n Quarter) = Flex  $ addGregorianMonthsClip (3*n) $ thisquarter refdate+    fix (SmartRelative n Year)    = Flex  $ addGregorianYearsClip n $ thisyear refdate+    fix (SmartRelativeMonth LT m)    = Flex $ prevnamedmonth m refdate+    fix (SmartRelativeMonth EQ m)    = Flex $ thisnamedmonth m refdate+    fix (SmartRelativeMonth GT m)    = Flex $ nextnamedmonth m refdate+    fix (SmartRelativeWeekDay LT wd) = Exact $ prevnamedweekday wd refdate+    fix (SmartRelativeWeekDay EQ wd) = Exact $ thisnamedweekday wd refdate+    fix (SmartRelativeWeekDay GT wd) = Exact $ nextnamedweekday wd refdate+    (ry, rm, _) = toGregorian refdate++prevday :: Day -> Day+prevday = addDays (-1)+nextday = addDays 1++thisweek = startofweek+prevweek = startofweek . addDays (-7)+nextweek = startofweek . addDays 7+startofweek day = fromMondayStartWeek y w 1+    where+      (y,_,_) = toGregorian day+      (w,_) = mondayStartWeek day++thismonth = startofmonth+prevmonth = startofmonth . addGregorianMonthsClip (-1)+nextmonth = startofmonth . addGregorianMonthsClip 1+startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day+nthdayofmonth d day = fromGregorian y m d where (y,m,_) = toGregorian day++prevnamedmonth :: Month -> Day -> Day+prevnamedmonth targetmonth refdate = fromGregorian y' targetmonth 1+  where+    (y, m, _) = toGregorian refdate+    y' = if targetmonth < m then y else y - 1++nextnamedmonth :: Month -> Day -> Day+nextnamedmonth targetmonth refdate = fromGregorian y' targetmonth 1+  where+    (y, m, _) = toGregorian refdate+    y' = if targetmonth > m then y else y + 1++thisnamedmonth :: Month -> Day -> Day+thisnamedmonth = nextnamedmonth  -- "this" and "next" both mean next occurrence after current month++prevnamedweekday :: WeekDay -> Day -> Day+prevnamedweekday targetwd refdate = addDays (negate $ fromIntegral daysback) refdate+  where+    (_, curwd) = mondayStartWeek refdate+    daysback = 1 + (curwd - targetwd - 1) `mod` 7++nextnamedweekday :: WeekDay -> Day -> Day+nextnamedweekday targetwd refdate = addDays (fromIntegral daysforward) refdate+  where+    (_, curwd) = mondayStartWeek refdate+    daysforward = 1 + (targetwd - curwd - 1) `mod` 7++thisnamedweekday :: WeekDay -> Day -> Day+thisnamedweekday = nextnamedweekday  -- "this" and "next" both mean next occurrence after today++thisquarter = startofquarter+startofquarter day = fromGregorian y (firstmonthofquarter m) 1+    where+      (y,m,_) = toGregorian day+      firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1++thisyear = startofyear+-- prevyear = startofyear . addGregorianYearsClip (-1)+nextyear = startofyear . addGregorianYearsClip 1+startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day++-- | Find the next occurrence of the specified month and day of month, on or after the given date.+-- The month should be 1-12 and the day of month should be 1-31, or an error will be raised.+--+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> nextmonthandday 11 21 wed22nd+-- 2018-11-21+-- >>> nextmonthandday 11 22 wed22nd+-- 2017-11-22+-- >>> nextmonthandday 11 23 wed22nd+-- 2017-11-23+nextmonthandday :: Month -> MonthDay -> Day -> Day+nextmonthandday m n date+  -- PARTIAL:+  | not (validMonth m) = error' $ "nextmonthandday: month should be 1..12, not "++show m+  | not (validDay   n) = error' $ "nextmonthandday: day should be 1..31, not "  ++show n+  | mdthisyear >= date = mdthisyear+  | otherwise          = mdnextyear+  where+    s = startofyear date+    advancetomonth = applyN (m-1) nextmonth+    advancetoday = addDays (toInteger n-1)+    mdthisyear = advancetoday $ advancetomonth s+    mdnextyear = advancetoday $ advancetomonth $ nextyear s++-- | Find the next occurrence of the specified day of month, on or after the given date.+-- The day of month should be 1-31, or an error will be raised.+--+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> nextnthdayofmonth 21 wed22nd+-- 2017-12-21+-- >>> nextnthdayofmonth 22 wed22nd+-- 2017-11-22+-- >>> nextnthdayofmonth 23 wed22nd+-- 2017-11-23+nextnthdayofmonth :: MonthDay -> Day -> Day+nextnthdayofmonth n date+  -- PARTIAL:+  | not (validDay n)       = error' $ "nextnthdayofmonth: day should be 1..31, not "  ++show n+  | nthofthismonth >= date = nthofthismonth+  | otherwise              = nthofnextmonth+  where+    s = startofmonth date+    nthofthismonth = nthdayofmonth n s+    nthofnextmonth = nthdayofmonth n $ nextmonth s++-- | For given date d find week-long interval that starts on nth day of week+-- and covers it.+--+-- Examples: 2017-11-22 is Wed. Week-long intervals that cover it and+-- start on Mon, Tue or Wed will start in the same week. However+-- intervals that start on Thu or Fri should start in prev week:+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> nthdayofweekcontaining 1 wed22nd+-- 2017-11-20+-- >>> nthdayofweekcontaining 2 wed22nd+-- 2017-11-21+-- >>> nthdayofweekcontaining 3 wed22nd+-- 2017-11-22+-- >>> nthdayofweekcontaining 4 wed22nd+-- 2017-11-16+-- >>> nthdayofweekcontaining 5 wed22nd+-- 2017-11-17+nthdayofweekcontaining :: WeekDay -> Day -> Day+nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek+                           | otherwise = nthOfPrevWeek+    where nthOfSameWeek = addDays (toInteger n-1) s+          nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s+          s = startofweek d++-- -- | Find the next occurrence of some weekday, on or after the given date d.+-- --+-- -- >>> let wed22nd = fromGregorian 2017 11 22+-- -- >>> nextnthdayofweek 1 wed22nd+-- -- 2017-11-20+-- -- >>> nextnthdayofweek 2 wed22nd+-- -- 2017-11-21+-- -- >>> nextnthdayofweek 3 wed22nd+-- -- 2017-11-22+-- -- >>> nextnthdayofweek 4 wed22nd+-- -- 2017-11-16+-- -- >>> nextnthdayofweek 5 wed22nd+-- -- 2017-11-17+-- nextdayofweek :: WeekDay -> Day -> Day+-- nextdayofweek n d | nthOfSameWeek <= d = nthOfSameWeek+--                            | otherwise = nthOfPrevWeek+--     where nthOfSameWeek = addDays (toInteger n-1) s+--           nthOfPrevWeek = addDays (toInteger n-1) $ prevweek s+--           s = startofweek d++-- | Find the next occurrence of some nth weekday of a month, on or after the given date d.+--+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> nextNthWeekdayOfMonth 3 3 wed22nd  -- next third wednesday+-- 2017-12-20+-- >>> nextNthWeekdayOfMonth 4 3 wed22nd  -- next fourth wednesday+-- 2017-11-22+-- >>> nextNthWeekdayOfMonth 5 3 wed22nd  -- next fifth wednesday+-- 2017-11-29+nextNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day+nextNthWeekdayOfMonth n wd d+  | nthweekdaythismonth >= d = nthweekdaythismonth+  | otherwise                = nthweekdaynextmonth+  where+    nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d+    nthweekdaynextmonth = advanceToNthWeekday n wd $ nextmonth d++-- | Find the previous occurrence of some nth weekday of a month, on or before the given date d.+--+-- >>> let wed22nd = fromGregorian 2017 11 22+-- >>> prevNthWeekdayOfMonth 4 3 wed22nd+-- 2017-11-22+-- >>> prevNthWeekdayOfMonth 5 2 wed22nd+-- 2017-10-31+prevNthWeekdayOfMonth :: Int -> WeekDay -> Day -> Day+prevNthWeekdayOfMonth n wd d+  | nthweekdaythismonth <= d = nthweekdaythismonth+  | otherwise                = nthweekdayprevmonth+  where+    nthweekdaythismonth = advanceToNthWeekday n wd $ startofmonth d+    nthweekdayprevmonth = advanceToNthWeekday n wd $ prevmonth d++-- | Advance to the nth occurrence of the given weekday, on or after the given date.+-- Can call error.+advanceToNthWeekday :: Int -> WeekDay -> Day -> Day+advanceToNthWeekday n wd s =+  -- PARTIAL:+  maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s+  where+    err = error' "advanceToNthWeekday: should not happen"+    addWeeks k = addDays (7 * toInteger k)+    firstMatch p = headMay . dropWhile (not . p)+    firstweekday = addDays (toInteger wd-1) . startofweek++----------------------------------------------------------------------+-- parsing++-- -- | Parse a couple of date-time string formats to a time type.+-- parsedatetime :: String -> Maybe LocalTime+-- parsedatetime s = asum [+--     parseTimeM TruedefaultTimeLocale "%Y/%m/%d %H:%M:%S" s,+--     parseTimeM TruedefaultTimeLocale "%Y-%m-%d %H:%M:%S" s+--     ]++-- | A simple date parsing helper: parses these YMD date string formats:+-- `YYYY-MM-DD`, `YYYY/MM/DD`, `YYYY.MM.DD` or `YYYYMMDD`,+-- where the month and day each have two digits and the year has one or more.+--+-- This is different from the Smart Dates of the CLI and period expressions ("smartdate", below)+-- and not quite the same as the Simple Dates of the journal ("datep", in Hledger.Read.Common).+-- It's mainly for internal or interactive use, eg when debugging - +-- but currently is also used in a few user-facing places, such as:+-- parsing --value's argument, +-- parsing .latest files,+-- and parsing hledger's --version output (which uses unseparated dates).+--+-- Unseparated dates were added in 2025 for convenience.+-- Note it means many integers will now parse successfully.+--+-- >>> parsedate "2008/02/03"+-- Just 2008-02-03+-- >>> parsedate "2008/02/03/"+-- Nothing+-- >>> parsedate "2008/02/30"+-- Nothing+-- >>> parsedate "2025-01-01"+-- Just 2025-01-01+-- >>> parsedate "2025.01.01"+-- Just 2025-01-01+-- >>> parsedate "20250101"+-- Just 2025-01-01+-- >>> parsedate "00101"+-- Just 0000-01-01+parsedate :: String -> Maybe Day+parsedate s = asum [+     parseTimeM True defaultTimeLocale "%Y-%m-%d" s,+     parseTimeM True defaultTimeLocale "%Y/%m/%d" s,+     parseTimeM True defaultTimeLocale "%Y.%m.%d" s,+     parseTimeM True defaultTimeLocale "%Y%m%d" s+     ]++{-|+Parse a date in any of the formats allowed in Ledger's period expressions, and some others.+Assumes any text in the parse stream has been lowercased.+Returns a SmartDate, to be converted to a full date later (see fixSmartDate).++Examples:++> 2004                                        (start of year, which must have 4+ digits)+> 2004/10                                     (start of month, which must be 1-12)+> 2004/10/1                                   (exact date, day must be 1-31)+> 10/1                                        (month and day in current year)+> 21                                          (day in current month)+> october, oct                                (start of month in current year)+> yesterday, today, tomorrow                  (-1, 0, 1 days from today)+> last/this/next day/week/month/quarter/year  (-1, 0, 1 periods from the current period)+> last/this/next monday/mon                   (the previous or next named weekday; this=next)+> last/next january/jan                       (previous or next start of named month; this disallowed to avoid confusion)+> in n days/weeks/months/quarters/years       (n periods from the current period)+> n days/weeks/months/quarters/years ago      (-n periods from the current period)+> 20181201                                    (8 digit YYYYMMDD with valid year month and day)+> 201812                                      (6 digit YYYYMM with valid year and month)++Note malformed digit sequences might give surprising results:++> 201813                                      (6 digits with an invalid month is parsed as start of 6-digit year)+> 20181301                                    (8 digits with an invalid month is parsed as start of 8-digit year)+> 20181232                                    (8 digits with an invalid day gives an error)+> 201801012                                   (9+ digits beginning with a valid YYYYMMDD gives an error)++Eg:++YYYYMMDD is parsed as year-month-date if those parts are valid+(>=4 digits, 1-12, and 1-31 respectively):+>>> parsewith (smartdate <* eof) "20181201"+Right (SmartCompleteDate 2018-12-01)++YYYYMM is parsed as year-month-01 if year and month are valid:+>>> parsewith (smartdate <* eof) "201804"+Right (SmartAssumeStart 2018 (Just 4))++With an invalid month, it's parsed as a year:+>>> parsewith (smartdate <* eof) "201813"+Right (SmartAssumeStart 201813 Nothing)++A 9+ digit number beginning with valid YYYYMMDD gives an error:+>>> parsewith (smartdate <* eof) "201801012"+Left (...)++Big numbers not beginning with a valid YYYYMMDD are parsed as a year:+>>> parsewith (smartdate <* eof) "201813012"+Right (SmartAssumeStart 201813012 Nothing)++-}+smartdate :: TextParser m SmartDate+smartdate = choice'+  -- XXX maybe obscures date errors ? see ledgerdate+    [ relativeinterval+    , relativemonth+    , relativeweekday+    , yyyymmdd+    , ymd+    , (\(m,d) -> SmartFromReference (Just m) d) <$> md+    , failIfInvalidDate . SmartFromReference Nothing =<< decimal+    , SmartMonth <$> (month <|> mon)+    , SmartRelative (-1) Day <$ string' "yesterday"+    , SmartRelative 0    Day <$ string' "today"+    , SmartRelative 1    Day <$ string' "tomorrow"+    ]+  where+    relativeinterval = do+        optional $ string' "in" <* skipNonNewlineSpaces+        num      <- relativenump <* skipNonNewlineSpaces+        interval <- intervalp <* skipNonNewlineSpaces+        sign     <- choice [negate <$ string' "ago", id <$ string' "ahead", pure id]+        return $ SmartRelative (sign num) interval+        where+          relativenump = choice [ 0 <$ string' "this", -1 <$ string' "last", 1 <$ string' "next", signed skipNonNewlineSpaces decimal ]+          intervalp    = choice [ Day <$ string' "day", Week <$ string' "week", Month <$ string' "month"+                                , Quarter <$ string' "quarter", Year <$ string' "year" ] <* optional (char' 's')+    relativemonth = do+      dir <- choice [LT <$ string' "last", EQ <$ string' "this", GT <$ string' "next"]+      skipNonNewlineSpaces+      m <- (month <|> mon)+      return $ SmartRelativeMonth dir m+    relativeweekday = do+      dir <- choice [LT <$ string' "last", EQ <$ string' "this", GT <$ string' "next"]+      skipNonNewlineSpaces+      w <- weekday+      return $ SmartRelativeWeekDay dir w++-- | Like smartdate, but there must be nothing other than whitespace after the date.+smartdateonly :: TextParser m SmartDate+smartdateonly = smartdate <* skipNonNewlineSpaces <* eof++datesepchars :: String+datesepchars = "/-."++datesepchar :: TextParser m Char+datesepchar = satisfy isDateSepChar++isDateSepChar :: Char -> Bool+isDateSepChar c = c == '-' || c == '/' || c == '.'++validMonth, validDay :: Int -> Bool+validMonth n = n >= 1 && n <= 12+validDay n = n >= 1 && n <= 31++failIfInvalidDate :: Fail.MonadFail m => SmartDate -> m SmartDate+failIfInvalidDate s = unless isValid (Fail.fail $ "bad smart date: " ++ show s) $> s+  where isValid = case s of+            SmartAssumeStart _ (Just m) -> validMonth m+            SmartFromReference mm d     -> isJust $ fromGregorianValid 2004 (fromMaybe 1 mm) d+            SmartMonth m                -> validMonth m+            _                           -> True++showBadDate :: Integer -> Int -> Int -> String+showBadDate y m d = "bad smart date: " ++ show y ++ "-" ++ show m ++ "-" ++ show d++yyyymmdd :: TextParser m SmartDate+yyyymmdd = do+  y <- read <$> count 4 digitChar+  m <- read <$> count 2 digitChar+  mdy <- optional $ read <$> count 2 digitChar+  case mdy of+      Nothing -> failIfInvalidDate $ SmartAssumeStart y (Just m)+      Just d  -> maybe (Fail.fail $ showBadDate y m d) (return . SmartCompleteDate) $+                   fromGregorianValid y m d++ymd :: TextParser m SmartDate+ymd = do+    y <- yearp+    emd <- optional . try $ do+        sep <- datesepchar+        m <- decimal+        unless (validMonth m) $ Fail.fail ("Bad month " <> show m)+        option (Left m) . try $ Right <$> do+            _ <- char sep+            d <- decimal+            maybe (Fail.fail $ showBadDate y m d) return $ fromGregorianValid y m d+    return $ case emd of+        Nothing          -> SmartAssumeStart y Nothing+        Just (Left m)    -> SmartAssumeStart y (Just m)+        Just (Right day) -> SmartCompleteDate day++md :: TextParser m (Month, MonthDay)+md = do+  m <- decimal+  datesepchar+  d <- decimal+  _ <- failIfInvalidDate $ SmartFromReference (Just m) d+  return (m, d)++-- | Parse a year number from a Text, making sure that at least four digits are+-- used.+yearp :: TextParser m Integer+yearp = do+  year <- takeWhile1P (Just "year") isDigit+  unless (T.length year >= 4) . Fail.fail $ "Year must contain at least 4 digits: " <> T.unpack year+  return $ readDecimal year++-- These are compared case insensitively, and should all be kept lower case.+months         = ["january","february","march","april","may","june",+                  "july","august","september","october","november","december"]+monthabbrevs   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]+weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]+weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]++month, mon :: TextParser m Month+month = choice $ zipWith (\i m -> i <$ string' m) [1..12] months+mon   = choice $ zipWith (\i m -> i <$ string' m) [1..12] monthabbrevs++weekday :: TextParser m Int+weekday = do+  wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)+  case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of+    (i:_) -> return (i+1)+    []    -> Fail.fail $ "weekday: should not happen: attempted to find " <>+                         show wday <> " in " <> show (weekdays ++ weekdayabbrevs)++weekdaysp :: TextParser m [Int]+weekdaysp = fmap headErr . group . sort <$> sepBy1 weekday (string' ",")  -- PARTIAL headErr will succeed because of sepBy1++-- | Parse a period expression, specifying a date span and optionally+-- a reporting interval. Requires a reference "today" date for+-- resolving any relative start/end dates (only; it is not needed for+-- parsing the reporting interval).+--+-- >>> let p = parsePeriodExpr (fromGregorian 2008 11 26)+-- >>> p "from Aug to Oct"+-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)+-- >>> p "aug to oct"+-- Right (NoInterval,DateSpan 2008-08-01..2008-09-30)+-- >>> p "2009q2"+-- Right (NoInterval,DateSpan 2009Q2)+-- >>> p "Q3"+-- Right (NoInterval,DateSpan 2008Q3)+-- >>> p "every 3 days in Aug"+-- Right (Days 3,DateSpan 2008-08)+-- >>> p "daily from aug"+-- Right (Days 1,DateSpan 2008-08-01..)+-- >>> p "every week to 2009"+-- Right (Weeks 1,DateSpan ..2008-12-31)+-- >>> p "every 2nd day of month"+-- Right (MonthDay 2,DateSpan ..)+-- >>> p "every 2nd day"+-- Right (MonthDay 2,DateSpan ..)+-- >>> p "every 2nd day 2009.."+-- Right (MonthDay 2,DateSpan 2009-01-01..)+-- >>> p "every 2nd day 2009-"+-- Right (MonthDay 2,DateSpan 2009-01-01..)+-- >>> p "every 29th Nov"+-- Right (MonthAndDay 11 29,DateSpan ..)+-- >>> p "every 29th nov ..2009"+-- Right (MonthAndDay 11 29,DateSpan ..2008-12-31)+-- >>> p "every nov 29th"+-- Right (MonthAndDay 11 29,DateSpan ..)+-- >>> p "every Nov 29th 2009.."+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)+-- >>> p "every 11/29 from 2009"+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)+-- >>> p "every 11/29 since 2009"+-- Right (MonthAndDay 11 29,DateSpan 2009-01-01..)+-- >>> p "every 2nd Thursday of month to 2009"+-- Right (NthWeekdayOfMonth 2 4,DateSpan ..2008-12-31)+-- >>> p "every 1st monday of month to 2009"+-- Right (NthWeekdayOfMonth 1 1,DateSpan ..2008-12-31)+-- >>> p "every tue"+-- Right (DaysOfWeek [2],DateSpan ..)+-- >>> p "every 2nd day of week"+-- Right (DaysOfWeek [2],DateSpan ..)+-- >>> p "every 2nd day of month"+-- Right (MonthDay 2,DateSpan ..)+-- >>> p "every 2nd day"+-- Right (MonthDay 2,DateSpan ..)+-- >>> p "every 2nd day 2009.."+-- Right (MonthDay 2,DateSpan 2009-01-01..)+-- >>> p "every 2nd day of month 2009.."+-- Right (MonthDay 2,DateSpan 2009-01-01..)+periodexprp :: Day -> TextParser m (Interval, DateSpan)+periodexprp rdate = do+  skipNonNewlineSpaces+  choice' [ intervalanddateperiodexprp rdate+          , (,) NoInterval <$> periodexprdatespanp rdate+          ]++-- Parse a reporting interval and a date span.+intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)+intervalanddateperiodexprp rdate = do+  i <- reportingintervalp+  s <- option def . try $ do+      skipNonNewlineSpaces+      periodexprdatespanp rdate+  return (i,s)++-- Parse a reporting interval.+reportingintervalp :: TextParser m Interval+reportingintervalp = choice'+    [ tryinterval "day"     "daily"     Days+    , tryinterval "month"   "monthly"   Months+    , tryinterval "quarter" "quarterly" Quarters+    , tryinterval "year"    "yearly"    Years+    , Weeks 2 <$ string' "biweekly"+    , Weeks 2 <$ string' "fortnightly"+    , Months 2 <$ string' "bimonthly"+    , string' "every" *> skipNonNewlineSpaces *> choice'+        [ DaysOfWeek . pure <$> (nth <* skipNonNewlineSpaces <* string' "day" <* of_ "week")+        , MonthDay <$> (nth <* skipNonNewlineSpaces <* string' "day" <* optOf_ "month")+        , liftA2 NthWeekdayOfMonth nth $ skipNonNewlineSpaces *> weekday <* optOf_ "month"+        , uncurry MonthAndDay <$> (md <* optOf_ "year")+        , DaysOfWeek <$> weekdaysp+        , DaysOfWeek [1..5] <$ string' "weekday"+        , DaysOfWeek [6..7] <$ string' "weekendday"+        , d_o_y <* optOf_ "year"+        ]+    -- NB: the ordering is important here since the parse for `every weekday`+    -- would match the `tryinterval` first and then error on `d`. Perhaps it+    -- would be clearer to factor some of this into the `every` choice or other+    -- left-factorings.+    , tryinterval "week"    "weekly"    Weeks+    ]+  where+    of_ period =+      skipNonNewlineSpaces *> string' "of" *> skipNonNewlineSpaces *> string' period++    optOf_ period = optional . try $ of_ period++    nth = decimal <* choice (map string' ["st","nd","rd","th"])+    d_o_y = runPermutation $ liftA2 MonthAndDay (toPermutation $ (month <|> mon) <* skipNonNewlineSpaces)+                                                (toPermutation $ nth <* skipNonNewlineSpaces)++    -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".+    tryinterval :: Text -> Text -> (Int -> Interval) -> TextParser m Interval+    tryinterval singular compact intcons = intcons <$> choice'+        [ 1 <$ string' compact+        , string' "every" *> skipNonNewlineSpaces *> choice+            [ 1 <$ string' singular+            , decimal <* skipNonNewlineSpaces <* string' (singular <> "s")+            ]+        ]++periodexprdatespanp :: Day -> TextParser m DateSpan+periodexprdatespanp rdate = choice' [+                            doubledatespanp rdate,+                            fromdatespanp rdate,+                            todatespanp rdate,+                            indatespanp rdate+                           ]++-- |+-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "20180101-201804"+-- Right DateSpan 2018Q1+-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017..2018"+-- Right DateSpan 2017+-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-2018"+-- Right DateSpan 2017+-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-2018"+-- Right DateSpan 2017+-- >>> parsewith (doubledatespanp (fromGregorian 2018 01 01) <* eof) "2017-01-01-2018"+-- Right DateSpan 2017+doubledatespanp :: Day -> TextParser m DateSpan+doubledatespanp rdate = liftA2 fromToSpan+    (optional ((string' "from" <|> string' "since") *> skipNonNewlineSpaces) *> smartdateorquarterstartp rdate)+    (skipNonNewlineSpaces *> choice [string' "to", string "..", string "-"]+    *> skipNonNewlineSpaces *> smartdateorquarterstartp rdate)+  where+    fromToSpan = DateSpan `on` (Just . fixSmartDate rdate)++-- |+-- >>> let p = parsewith (fromdatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "2025-01-01.."+-- Right DateSpan 2025-01-01..+-- >>> p "2025Q1.."+-- Right DateSpan 2025-01-01..+-- >>> p "from q2"+-- Right DateSpan 2024-04-01..+fromdatespanp :: Day -> TextParser m DateSpan+fromdatespanp rdate = fromSpan <$> choice+  [ (string' "from" <|> string' "since") *> skipNonNewlineSpaces *> smartdateorquarterstartp rdate+  , smartdateorquarterstartp rdate <* choice [string "..", string "-"]+  ]+  where+    fromSpan b = DateSpan (Just $ fixSmartDate rdate b) Nothing++-- |+-- >>> let p = parsewith (todatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "..2025-01-01"+-- Right DateSpan ..2024-12-31+-- >>> p "..2025Q1"+-- Right DateSpan ..2024-12-31+-- >>> p "to q2"+-- Right DateSpan ..2024-03-31+todatespanp :: Day -> TextParser m DateSpan+todatespanp rdate =+  choice [string' "to", string' "until", string "..", string "-"]+  *> skipNonNewlineSpaces+  *> (DateSpan Nothing . Just . fixSmartDate rdate <$> smartdateorquarterstartp rdate)++-- |j+-- >>> let p = parsewith (indatespanp (fromGregorian 2024 02 02) <* eof)+-- >>> p "2025-01-01"+-- Right DateSpan 2025-01-01+-- >>> p "2025q1"+-- Right DateSpan 2025Q1+-- >>> p "in Q2"+-- Right DateSpan 2024Q2+indatespanp :: Day -> TextParser m DateSpan+indatespanp rdate =+  optional (string' "in" *> skipNonNewlineSpaces)+  *> choice' [+    quarterspanp rdate,+    spanFromSmartDate rdate <$> smartdate+  ]++-- Helper: parse a quarter number, optionally preceded by a year.+quarterp :: Day -> TextParser m (Year, Int)+quarterp rdate = do+  y <- yearp <|> pure (first3 $ toGregorian rdate)+  n <- char' 'q' *> satisfy (`elem` ['1' .. '4']) >>= return . digitToInt+  return (y, n)++-- | Parse a single quarter (YYYYqN or qN, case insensitive q) as a date span.+--+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "q1"+-- Right DateSpan 2018Q1+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "Q1"+-- Right DateSpan 2018Q1+-- >>> parsewith (quarterspanp (fromGregorian 2018 01 01) <* eof) "2020q4"+-- Right DateSpan 2020Q4+quarterspanp :: Day -> TextParser m DateSpan+quarterspanp rdate = do+  (y,q) <- quarterp rdate+  return . periodAsDateSpan $ QuarterPeriod y q++-- | Parse a quarter (YYYYqN or qN, case insensitive q) as its start date.+--+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "q1"+-- Right 2025-01-01+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "Q2"+-- Right 2025-04-01+-- >>> parsewith (quarterstartp (fromGregorian 2025 02 02) <* eof) "2025q4"+-- Right 2025-10-01+quarterstartp :: Day -> TextParser m Day+quarterstartp rdate = do+  (y,q) <- quarterp rdate+  return $+    fromMaybe (error' "Hledger.Data.Dates.quarterstartp: invalid date found") $  -- PARTIAL, shouldn't happen+    periodStart $ QuarterPeriod y q++smartdateorquarterstartp :: Day -> TextParser m SmartDate+smartdateorquarterstartp rdate = choice' [SmartCompleteDate <$> quarterstartp rdate, smartdate]++nulldatespan :: DateSpan+nulldatespan = DateSpan Nothing Nothing++-- | An exact datespan of zero length, that matches no date.+emptydatespan :: DateSpan+emptydatespan = DateSpan (Just $ Exact $ addDays 1 nulldate) (Just $ Exact nulldate)  nulldate :: Day nulldate = fromGregorian 0 1 1
+ Hledger/Data/DayPartition.hs view
@@ -0,0 +1,285 @@+{-|+A partition of time into contiguous spans, for defining reporting periods.+-}+module Hledger.Data.DayPartition+( DayPartition+-- * constructors+, boundariesToDayPartition+, boundariesToMaybeDayPartition+-- * conversions+, dayPartitionToNonEmpty+, dayPartitionToList+, dayPartitionToDateSpans+, dayPartitionToPeriodData+, maybeDayPartitionToDateSpans+-- * operations+, unionDayPartitions+, dayPartitionStartEnd+, dayPartitionFind+, splitSpan+, intervalBoundaryBefore+-- * tests+, tests_DayPartition+) where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Map qualified as M+import Data.Time (Day (..), addDays, addGregorianMonthsClip, addGregorianYearsClip, fromGregorian)++import Hledger.Data.Dates+import Hledger.Data.PeriodData+import Hledger.Data.Types+import Hledger.Utils+++-- | A partition of time into one or more contiguous periods,+-- plus a historical period that precedes them.+-- Note 'DayPartition' does not store per-period data - only the periods' start/end dates.++-- Each period is at least one day in length.+-- The historical period is open ended, with no start date.+-- The last period has an end date, but note some queries (like 'dayPartitionFind') ignore that, acting as if the last period is open ended.+-- Only smart constructors are exported, so that a DayPartition always satisfies these invariants.+--+-- This is implemented as a newtype wrapper around 'PeriodData Day', which is a map from date to date.+-- The map's keys are the period start dates, and the values are the corresponding period end dates.+-- Note unlike 'DateSpan', which stores exclusive end dates ( @[start, end)@ ),+-- here both start and end dates are inclusive ( @[start, end]@ ).+--+newtype DayPartition = DayPartition { dayPartitionToPeriodData :: PeriodData Day } deriving (Eq, Ord, Show)+++-- constructors:++-- | Construct a 'DayPartition' from a non-empty list of period boundary dates (start dates plus a final exclusive end date).+--+-- >>> boundariesToDayPartition (fromGregorian 2025 01 01 :| [fromGregorian 2025 02 01])+-- DayPartition {dayPartitionToPeriodData = PeriodData{ pdpre = 2024-12-31, pdperiods = fromList [(2025-01-01,2025-01-31)]}}+--+boundariesToDayPartition :: NonEmpty Day -> DayPartition+boundariesToDayPartition xs = DayPartition . periodDataFromList (addDays (-1) b) $ case bs of+    []  -> [(b, b)]  -- If only one boundary is supplied, it ends on the same day+    _:_ -> zip (b:bs) $ map (addDays (-1)) bs  -- Guaranteed non-empty+  where b:|bs = NE.nub $ NE.sort xs++-- | Construct a 'DayPartition' from a list of period boundary dates (start dates plus a final exclusive end date),+-- if it's a non-empty list.+boundariesToMaybeDayPartition :: [Day] -> Maybe DayPartition+boundariesToMaybeDayPartition = fmap boundariesToDayPartition . NE.nonEmpty+++-- conversions:++-- | Convert 'DayPartition' to a non-empty list of period start and end dates (both inclusive).+-- Each end date will be one day before the next period's start date.+dayPartitionToNonEmpty :: DayPartition -> NonEmpty (Day, Day)+dayPartitionToNonEmpty (DayPartition xs) = NE.fromList . snd $ periodDataToList xs  -- Constructors guarantee this is non-empty++-- | Convert 'DayPartition' to a list (which will always be non-empty) of period start and end dates (both inclusive).+-- Each end date will be one day before the next period's start date.+dayPartitionToList :: DayPartition -> [(Day, Day)]+dayPartitionToList = NE.toList . dayPartitionToNonEmpty++-- | Convert 'DayPartition' to a list of 'DateSpan's.+-- Each span will end one day before the next span begins+-- (the span's exclusive end date will be equal to the next span's start date).+dayPartitionToDateSpans :: DayPartition -> [DateSpan]+dayPartitionToDateSpans = map toDateSpan . dayPartitionToList+  where+    toDateSpan (s, e) = DateSpan (toEFDay s) (toEFDay $ addDays 1 e)+    toEFDay = Just . Exact++-- Convert a 'Maybe DayPartition' to a list of one or more 'DateSpans'.+-- Each span will end one day before the next span begins+-- (the span's exclusive end date will be equal to the next span's start date).+-- If given Nothing, it returns a single open-ended span.+maybeDayPartitionToDateSpans :: Maybe DayPartition -> [DateSpan]+maybeDayPartitionToDateSpans = maybe [DateSpan Nothing Nothing] dayPartitionToDateSpans+++-- operations:++-- | Check that a DayPartition has been constructed correctly,+-- with internal invariants satisfied, as well as the external ones described in 'DayPartition'.+-- Internally, all constructors must guarantee:+-- 1. The pdperiods map contains at least one key and value.+-- 2. The value stored in pdpre is one day before pdperiods' smallest key.+-- 3. Each value stored in pdperiods is one day before the next largest key,+--    (except for the value associated with the largest key).+isValidDayPartition :: DayPartition -> Bool+isValidDayPartition (DayPartition pd) = case ds of+  [] -> False+  xs -> and $ zipWith isContiguous ((nulldate, h) : xs) xs+ where+  (h, ds) = periodDataToList pd+  isContiguous (_, e) (s, _) = addDays 1 e == s++-- | Return the union of two 'DayPartition's if that is a valid 'DayPartition',+-- or 'Nothing' otherwise.+unionDayPartitions :: DayPartition -> DayPartition -> Maybe DayPartition+unionDayPartitions (DayPartition (PeriodData h as)) (DayPartition (PeriodData h' as')) =+  if equalIntersection as as' && isValidDayPartition union then Just union else Nothing+ where+  union = DayPartition . PeriodData (min h h') $ as <> as'+  equalIntersection x y = and $ M.intersectionWith (==) x y++-- | Get this DayPartition's overall start date and end date (both inclusive).+dayPartitionStartEnd :: DayPartition -> (Day, Day)+dayPartitionStartEnd (DayPartition (PeriodData _ ds)) =+  -- Guaranteed not to error because the IntMap is non-empty.+  (fst $ M.findMin ds, snd $ M.findMax ds)++-- | Find the start and end dates of the period within a 'DayPartition' which contains a given day.+-- If the day is after the end of the last period, it is assumed to be within the last period.+-- If the day is before the start of the first period (ie, in the historical period),+-- only the historical period's end date is returned.+dayPartitionFind :: Day -> DayPartition -> (Maybe Day, Day)+dayPartitionFind d (DayPartition xs) = lookupPeriodDataOrHistorical d xs++-- | Split a 'DateSpan' into a 'DayPartition' consisting of consecutive exact+-- spans of the specified Interval, or `Nothing` if the span is invalid.+-- If no interval is specified, the original span is returned.+-- If the original span is the null date span, ie unbounded, `Nothing` is returned.+-- If the original span is empty, eg if the end date is <= the start date, `Nothing` is returned.+--+-- ==== Date adjustment+-- Some intervals respect the "adjust" flag (years, quarters, months, weeks, every Nth weekday+-- of month seem to be the ones that need it). This will move the start date earlier, if needed,+-- to the previous natural interval boundary (first of year, first of quarter, first of month,+-- monday, previous Nth weekday of month). Related: #1982 #2218+--+-- The end date is always moved later if needed to the next natural interval boundary,+-- so that the last period is the same length as the others.+--+-- ==== Examples+-- >>> let t i y1 m1 d1 y2 m2 d2 = fmap dayPartitionToNonEmpty . splitSpan True i $ DateSpan (Just $ Flex $ fromGregorian y1 m1 d1) (Just $ Flex $ fromGregorian y2 m2 d2)+-- >>> t NoInterval 2008 01 01 2009 01 01+-- Just ((2008-01-01,2008-12-31) :| [])+-- >>> t (Quarters 1) 2008 01 01 2009 01 01+-- Just ((2008-01-01,2008-03-31) :| [(2008-04-01,2008-06-30),(2008-07-01,2008-09-30),(2008-10-01,2008-12-31)])+-- >>> splitSpan True (Quarters 1) nulldatespan+-- Nothing+-- >>> t (Days 1) 2008 01 01 2008 01 01  -- an empty datespan+-- Nothing+-- >>> t (Quarters 1) 2008 01 01 2008 01 01+-- Nothing+-- >>> t (Months 1) 2008 01 01 2008 04 01+-- Just ((2008-01-01,2008-01-31) :| [(2008-02-01,2008-02-29),(2008-03-01,2008-03-31)])+-- >>> t (Months 2) 2008 01 01 2008 04 01+-- Just ((2008-01-01,2008-02-29) :| [(2008-03-01,2008-04-30)])+-- >>> t (Weeks 1) 2008 01 01 2008 01 15+-- Just ((2007-12-31,2008-01-06) :| [(2008-01-07,2008-01-13),(2008-01-14,2008-01-20)])+-- >>> t (Weeks 2) 2008 01 01 2008 01 15+-- Just ((2007-12-31,2008-01-13) :| [(2008-01-14,2008-01-27)])+-- >>> t (MonthDay 2) 2008 01 01 2008 04 01+-- Just ((2008-01-02,2008-02-01) :| [(2008-02-02,2008-03-01),(2008-03-02,2008-04-01)])+-- >>> t (NthWeekdayOfMonth 2 4) 2011 01 01 2011 02 15+-- Just ((2010-12-09,2011-01-12) :| [(2011-01-13,2011-02-09),(2011-02-10,2011-03-09)])+-- >>> t (DaysOfWeek [2]) 2011 01 01 2011 01 15+-- Just ((2010-12-28,2011-01-03) :| [(2011-01-04,2011-01-10),(2011-01-11,2011-01-17)])+-- >>> t (MonthAndDay 11 29) 2012 10 01 2013 10 15+-- Just ((2012-11-29,2013-11-28) :| [])+splitSpan :: Bool -> Interval -> DateSpan -> Maybe DayPartition+splitSpan _      _                        (DateSpan Nothing Nothing) = Nothing+splitSpan _      _                        ds | isEmptySpan ds = Nothing+splitSpan _      NoInterval               (DateSpan (Just s) (Just e)) = Just $ boundariesToDayPartition (fromEFDay s :| [fromEFDay e])+splitSpan _      NoInterval               _  = Nothing+splitSpan _      (Days n)                 ds = splitspan id addDays n ds+splitSpan adjust (Weeks n)                ds = splitspan (if adjust then startofweek    else id) addDays                 (7*n) ds+splitSpan adjust (Months n)               ds = splitspan (if adjust then startofmonth   else id) addGregorianMonthsClip  n     ds+splitSpan adjust (Quarters n)             ds = splitspan (if adjust then startofquarter else id) addGregorianMonthsClip  (3*n) ds+splitSpan adjust (Years n)                ds = splitspan (if adjust then startofyear    else id) addGregorianYearsClip   n     ds+splitSpan adjust (NthWeekdayOfMonth n wd) ds = splitspan (startWeekdayOfMonth n wd)              advancemonths           1     ds+  where+    startWeekdayOfMonth = if adjust then prevNthWeekdayOfMonth else nextNthWeekdayOfMonth+    advancemonths 0 = id+    advancemonths m = advanceToNthWeekday n wd . startofmonth . addGregorianMonthsClip m+splitSpan _      (MonthDay dom)           ds = splitspan (nextnthdayofmonth dom) (addGregorianMonthsToMonthday dom) 1 ds+splitSpan _      (MonthAndDay m d)        ds = splitspan (nextmonthandday m d)   addGregorianYearsClip              1 ds+splitSpan _      (DaysOfWeek [])          _  = Nothing+splitSpan _      (DaysOfWeek days@(n:_))  ds = do+    (s, e) <- dateSpanSplitLimits (nthdayofweekcontaining n) nextday ds+    let -- can't show this when debugging, it'll hang:+        bdrys = concatMap (\d -> map (addDays d) starts) [0,7..]+        -- The first representative of each weekday+        starts = map (\d -> addDays (toInteger $ d - n) $ nthdayofweekcontaining n s) days+    spansFromBoundaries e bdrys++-- | Fill in missing start/end dates for calculating 'splitSpan'.+dateSpanSplitLimits :: (Day -> Day) -> (Day -> Day) -> DateSpan -> Maybe (Day, Day)+dateSpanSplitLimits _     _    (DateSpan Nothing   Nothing) = Nothing+dateSpanSplitLimits _     _    ds | isEmptySpan ds          = Nothing+dateSpanSplitLimits start _    (DateSpan (Just s) (Just e)) = Just (start $ fromEFDay s, fromEFDay e)+dateSpanSplitLimits start next (DateSpan (Just s) Nothing)  = Just (start $ fromEFDay s, next $ start $ fromEFDay s)+dateSpanSplitLimits start next (DateSpan Nothing  (Just e)) = Just (start $ fromEFDay e, next $ start $ fromEFDay e)++-- Split the given span into exact spans using the provided helper functions:+--+-- 1. The start function is used to adjust the provided span's start date to get the first sub-span's start date.+--+-- 2. The next function is used to calculate subsequent sub-spans' start dates, possibly with stride increased by a multiplier.+--    It should handle spans of varying length, eg when splitting on "every 31st of month",+--    it adjusts to 28/29/30 in short months but returns to 31 in the long months.+splitspan :: (Day -> Day) -> (Integer -> Day -> Day) -> Int -> DateSpan -> Maybe DayPartition+splitspan start next mult ds = do+    (s, e) <- dateSpanSplitLimits start (next (toInteger mult)) ds+    let bdrys = mapM (next . toInteger) [0,mult..] $ start s+    spansFromBoundaries e bdrys++-- | Construct a list of exact 'DateSpan's from a list of boundaries, which fit within a given range.+spansFromBoundaries :: Day -> [Day] -> Maybe DayPartition+spansFromBoundaries _ []     = Nothing+spansFromBoundaries e (x:_)  | x >= e = Nothing+spansFromBoundaries e (x:xs) = Just . boundariesToDayPartition $ takeUntilFailsNE (<e) (x:|xs)++-- | Get the natural start for the given interval that falls on or before the given day,+-- when applicable. Works for Weeks, Months, Quarters, Years, eg.+intervalBoundaryBefore :: Interval -> Day -> Day+intervalBoundaryBefore i d =+  case dayPartitionToNonEmpty <$> splitSpan True i (DateSpan (Just $ Exact d) (Just . Exact $ addDays 1 d)) of+    Just ((start, _) :| _ ) -> start+    _ -> d+++-- tests:++tests_DayPartition =+  testGroup "splitSpan" [+      testCase "weekday" $ do+        fmap dayPartitionToNonEmpty (splitSpan False (DaysOfWeek [1..5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08)))+          @?= Just ( (fromGregorian 2021 06 28, fromGregorian 2021 06 28) :|+                   [ (fromGregorian 2021 06 29, fromGregorian 2021 06 29)+                   , (fromGregorian 2021 06 30, fromGregorian 2021 06 30)+                   , (fromGregorian 2021 07 01, fromGregorian 2021 07 01)+                   , (fromGregorian 2021 07 02, fromGregorian 2021 07 04)+                   -- next week+                   , (fromGregorian 2021 07 05, fromGregorian 2021 07 05)+                   , (fromGregorian 2021 07 06, fromGregorian 2021 07 06)+                   , (fromGregorian 2021 07 07, fromGregorian 2021 07 07)+                   ])++        fmap dayPartitionToNonEmpty (splitSpan False (DaysOfWeek [1, 5]) (DateSpan (Just $ Exact $ fromGregorian 2021 07 01) (Just $ Exact $ fromGregorian 2021 07 08)))+          @?= Just ( (fromGregorian 2021 06 28, fromGregorian 2021 07 01) :|+                   [ (fromGregorian 2021 07 02, fromGregorian 2021 07 04)+                   -- next week+                   , (fromGregorian 2021 07 05, fromGregorian 2021 07 08)+                   ])++    , testCase "match dayOfWeek" $ do+        let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1+            matchdow ds day = splitSpan False (DaysOfWeek [day]) ds @?= dayofweek day ds+            ys2021 = fromGregorian 2021 01 01+            ye2021 = fromGregorian 2021 12 31+            ys2022 = fromGregorian 2022 01 01+        mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ye2021))) [1..7]+        mapM_ (matchdow (DateSpan (Just $ Exact ys2021) (Just $ Exact ys2022))) [1..7]+        mapM_ (matchdow (DateSpan (Just $ Exact ye2021) (Just $ Exact ys2022))) [1..7]++        mapM_ (matchdow (DateSpan (Just $ Exact ye2021) Nothing)) [1..7]+        mapM_ (matchdow (DateSpan (Just $ Exact ys2022) Nothing)) [1..7]++        mapM_ (matchdow (DateSpan Nothing (Just $ Exact ye2021))) [1..7]+        mapM_ (matchdow (DateSpan Nothing (Just $ Exact ys2022))) [1..7]++    ]
+ Hledger/Data/Errors.hs view
@@ -0,0 +1,226 @@+{-|+Helpers for making error messages.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Hledger.Data.Errors (+  makeAccountTagErrorExcerpt,+  makePriceDirectiveErrorExcerpt,+  makeTransactionErrorExcerpt,+  makePostingErrorExcerpt,+  makePostingAccountErrorExcerpt,+  makeBalanceAssertionErrorExcerpt,+  transactionFindPostingIndex,+)+where++import Data.Function ((&))+import Data.List (find)+import Data.Text (Text)+import Data.Text qualified as T++import Hledger.Data.Transaction (showTransaction)+import Hledger.Data.Posting (postingStripCosts)+import Hledger.Data.Types+import Hledger.Utils+import Data.Maybe+import Safe (headMay)+import Hledger.Data.Posting (isVirtual)+import Hledger.Data.Dates (showDate)+import Hledger.Data.Amount (showCommoditySymbol, showAmount)+++-- | Given an account name and its account directive, and a problem tag within the latter:+-- render it as a megaparsec-style excerpt, showing the original line number and+-- marked column or region.+-- Returns the file path, line number, column(s) if known,+-- and the rendered excerpt, or as much of these as is possible.+-- The returned columns will be accurate for the rendered error message but not for the original journal data.+makeAccountTagErrorExcerpt :: (AccountName, AccountDeclarationInfo) -> TagName -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makeAccountTagErrorExcerpt (a, adi) _t = (f, l, merrcols, ex)+  -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form+  where+    SourcePos f pos _ = adisourcepos adi+    l = unPos pos+    txt   = showAccountDirective (a, adi) & textChomp & (<>"\n")+    ex = decorateExcerpt l merrcols txt+    -- Calculate columns which will help highlight the region in the excerpt+    -- (but won't exactly match the real data, so won't be shown in the main error line)+    merrcols = Nothing+      -- don't bother for now+      -- Just (col, Just col2)+      -- where+      --   col  = undefined -- T.length (showTransactionLineFirstPart t') + 2+      --   col2 = undefined -- col + T.length tagname - 1      ++showAccountDirective (a, AccountDeclarationInfo{..}) =+  "account " <> a+  <> (if not $ T.null adicomment then "    ; " <> adicomment else "")++-- | Decorate a data excerpt with megaparsec-style left margin, line number,+-- and marker/underline for the column(s) if known, for inclusion in an error message.+decorateExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text+decorateExcerpt l mcols txt =+  T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms+  where+    (ls,ms) = splitAt 1 $ T.lines txt+    ls' = map ((T.pack (show l) <> " | ") <>) ls+    colmarkerline =+      [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^"+      | Just (col, mendcol) <- [mcols]+      , let regionw = maybe 1 (subtract col) mendcol + 1+      ]+    lineprefix = T.replicate marginw " " <> "| "+      where  marginw = length (show l) + 1++-- | Given a problem price directive,+-- and maybe a function to calculate the error region's column(s) (currently ignored):+-- generate a megaparsec-style error message with highlighted excerpt.+-- Returns the source file path, line number, column(s) if known, and the rendered excerpt,+-- or as much of these as possible.+-- Columns will be accurate for the rendered error message, not for the original journal entry.+makePriceDirectiveErrorExcerpt :: PriceDirective -> Maybe (PriceDirective -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makePriceDirectiveErrorExcerpt pd _finderrorcolumns = (file, line, merrcols, excerpt)+  where+    SourcePos file pos _ = pdsourcepos pd+    line = unPos pos+    merrcols = Nothing+    excerpt = decorateExcerpt line merrcols $ showPriceDirective pd <> "\n"++showPriceDirective :: PriceDirective -> Text+showPriceDirective PriceDirective{..} = T.unwords [+   "P"+  ,showDate pddate+  ,showCommoditySymbol pdcommodity+  ,T.pack $ showAmount pdamount +  ]++-- | Given a problem transaction and a function calculating the best+-- column(s) for marking the error region:+-- render it as a megaparsec-style excerpt, showing the original line number+-- on the transaction line, and a column(s) marker.+-- Returns the file path, line number, column(s) if known,+-- and the rendered excerpt, or as much of these as is possible.+-- The returned columns will be accurate for the rendered error message but not for the original journal data.+makeTransactionErrorExcerpt :: Transaction -> (Transaction -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex)+  -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form+  where+    SourcePos f tpos _ = fst $ tsourcepos t+    tl = unPos tpos+    txntxt = showTransaction t & textChomp & (<>"\n")+    merrcols = findtxnerrorcolumns t+    ex = decorateTransactionErrorExcerpt tl merrcols txntxt++-- | Add megaparsec-style left margin, line number, and optional column marker(s).+decorateTransactionErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text+decorateTransactionErrorExcerpt l mcols txt =+  T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms+  where+    (ls,ms) = splitAt 1 $ T.lines txt+    ls' = map ((T.pack (show l) <> " | ") <>) ls+    colmarkerline =+      [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^"+      | Just (col, mendcol) <- [mcols]+      , let regionw = maybe 1 (subtract col) mendcol + 1+      ]+    lineprefix = T.replicate marginw " " <> "| "+      where  marginw = length (show l) + 1++-- | Given a problem posting and a function calculating the best+-- column(s) for marking the error region:+-- look up error info from the parent transaction, and render the transaction+-- as a megaparsec-style excerpt, showing the original line number+-- on the problem posting's line, and a column indicator.+-- Returns the file path, line number, column(s) if known,+-- and the rendered excerpt, or as much of these as is possible.+-- A limitation: columns will be accurate for the rendered error message but not for the original journal data.+makePostingErrorExcerpt :: Posting -> (Posting -> Transaction -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makePostingErrorExcerpt p findpostingerrorcolumns =+  case ptransaction p of+    Nothing -> ("-", 0, Nothing, "")+    Just t  -> (f, errabsline, merrcols, ex)+      where+        (SourcePos f tl _) = fst $ tsourcepos t+        -- p had cost removed in balanceTransactionAndCheckAssertionsB,+        -- must remove them from t's postings too (#2083)+        mpindex = transactionFindPostingIndex ((==p).postingStripCosts) t+        errrelline = case mpindex of+          Nothing -> 0+          Just pindex ->+            commentExtraLines (tcomment t) + +            sum (map postingLines $ take pindex $ tpostings t)+            where+              -- How many lines are used to render this posting ?+              postingLines p' = 1 + commentExtraLines (pcomment p')+              -- How many extra lines does this comment add to a transaction or posting rendering ?+              commentExtraLines c = max 0 (length (T.lines c) - 1)+        errabsline = unPos tl + errrelline+        txntxt = showTransaction t & textChomp & (<>"\n")+        merrcols = findpostingerrorcolumns p t txntxt+        ex = decoratePostingErrorExcerpt errabsline errrelline merrcols txntxt++-- | Add megaparsec-style left margin, line number, and optional column marker(s).+decoratePostingErrorExcerpt :: Int -> Int -> Maybe (Int, Maybe Int) -> Text -> Text+decoratePostingErrorExcerpt absline relline mcols txt =+  T.unlines $ js' <> ks' <> colmarkerline <> ms'+  where+    (ls,ms) = splitAt (relline+1) $ T.lines txt+    (js,ks) = splitAt (length ls - 1) ls+    (js',ks') = case ks of+      [k] -> (map (lineprefix<>) js, [T.pack (show absline) <> " | " <> k])+      _   -> ([], [])+    ms' = map (lineprefix<>) ms+    colmarkerline =+      [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^"+      | Just (col, mendcol) <- [mcols]+      , let regionw = 1 + maybe 0 (subtract col) mendcol+      ]+    lineprefix = T.replicate marginw " " <> "| "+      where  marginw = length (show absline) + 1++-- | Find the 1-based index of the first posting in this transaction+-- satisfying the given predicate.+transactionFindPostingIndex :: (Posting -> Bool) -> Transaction -> Maybe Int+transactionFindPostingIndex ppredicate = +  fmap fst . find (ppredicate.snd) . zip [1..] . tpostings++-- | From the given posting, make an error excerpt showing the transaction with+-- this posting's account part highlighted.+makePostingAccountErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makePostingAccountErrorExcerpt p = makePostingErrorExcerpt p finderrcols+  where+    -- Calculate columns suitable for highlighting the synthetic excerpt.+    finderrcols p' _ _ = Just (col, Just col2)+      where+        col = 5 + if isVirtual p' then 1 else 0+        col2 = col + T.length (paccount p') - 1++-- | From the given posting, make an error excerpt showing the transaction with+-- the balance assertion highlighted.+makeBalanceAssertionErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text)+makeBalanceAssertionErrorExcerpt p = makePostingErrorExcerpt p finderrcols+  where+    finderrcols p' t trendered = Just (col, Just col2)+      where+        -- Analyse the rendering to find the columns to highlight.+        tlines = dbg5 "tlines" $ max 1 $ length $ T.lines $ tcomment t  -- transaction comment can generate extra lines+        (col, col2) =+          let def = (5, maximum (map T.length $ T.lines trendered))  -- fallback: underline whole posting. Shouldn't happen.+          in+            case transactionFindPostingIndex (==p') t of+              Nothing  -> def+              Just idx -> fromMaybe def $ do+                let+                  beforeps = take (idx-1) $ tpostings t+                  beforepslines = dbg5 "beforepslines" $ sum $ map (max 1 . length . T.lines . pcomment) beforeps   -- posting comment can generate extra lines (assume only one commodity shown)+                assertionline <- dbg5 "assertionline" $ headMay $ drop (tlines + beforepslines) $ T.lines trendered+                let+                  col2' = T.length assertionline+                  l = dropWhile (/= '=') $ reverse $ T.unpack assertionline+                  l' = dropWhile (`elem` ['=','*']) l+                  col' = length l' + 1+                return (col', col2')+
Hledger/Data/Journal.hs view
@@ -1,1309 +1,1378 @@-{-# 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-  addMarketPrice,-  addTransactionModifier,-  addPeriodicTransaction,-  addTransaction,-  journalBalanceTransactions,-  journalApplyCommodityStyles,-  commodityStylesFromAmounts,-  journalCommodityStyles,-  journalConvertAmountsToCost,-  journalReverse,-  journalSetLastReadTime,-  journalPivot,-  -- * Filtering-  filterJournalTransactions,-  filterJournalPostings,-  filterJournalAmounts,-  filterTransactionAmounts,-  filterTransactionPostings,-  filterPostingAmount,-  -- * Querying-  journalAccountNamesUsed,-  journalAccountNamesImplied,-  journalAccountNamesDeclared,-  journalAccountNamesDeclaredOrUsed,-  journalAccountNamesDeclaredOrImplied,-  journalAccountNames,-  -- journalAmountAndPriceCommodities,-  journalAmounts,-  overJournalAmounts,-  traverseJournalAmounts,-  -- journalCanonicalCommodities,-  journalDateSpan,-  journalDescriptions,-  journalFilePath,-  journalFilePaths,-  journalTransactionAt,-  journalNextTransaction,-  journalPrevTransaction,-  journalPostings,-  -- * 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.Applicative (Const(..))-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 Data.Functor.Identity (Identity(..))-import qualified Data.HashTable.ST.Cuckoo as H-import Data.List-import Data.List.Extra (groupSort)-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 $ jmarketprices 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-    ,jmarketprices              = jmarketprices              j1 <> jmarketprices              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-  ,jmarketprices              = []-  ,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 }--addMarketPrice :: MarketPrice -> Journal -> Journal-addMarketPrice h j = j { jmarketprices = h : jmarketprices j }---- | 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 = nub . sort . 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 = nub . sort . map fst . jdeclaredaccounts---- | Sorted unique account names declared by account directives or posted to--- by transactions in this journal.-journalAccountNamesDeclaredOrUsed :: Journal -> [AccountName]-journalAccountNamesDeclaredOrUsed j = nub $ sort $ 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 = nub $ sort $ 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}---{------------------------------------------------------------------------------------ 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 parsed data to normal order. This is used for post-parse--- processing, since data is added to the head of the list during--- parsing.-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-    ,jmarketprices     = reverse $ jmarketprices 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.-journalApplyCommodityStyles :: Journal -> Journal-journalApplyCommodityStyles j@Journal{jtxns=ts, jmarketprices=mps} = j''-    where-      j' = journalInferCommodityStyles j-      styles = journalCommodityStyles j'-      j'' = j'{jtxns=map fixtransaction ts, jmarketprices=map fixmarketprice mps}-      fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}-      fixposting p@Posting{pamount=a} = p{pamount=styleMixedAmount styles a}-      fixmarketprice mp@MarketPrice{mpamount=a} = mp{mpamount=styleAmount styles a}---- | Get all the amount styles defined in this journal, either declared by --- a commodity directive or inferred from amounts, as a map from symbol to style. --- Styles declared by commodity directives take precedence, and these also are--- guaranteed to know their decimal point character.-journalCommodityStyles :: Journal -> M.Map CommoditySymbol AmountStyle-journalCommodityStyles j = declaredstyles <> inferredstyles-  where-    declaredstyles = M.mapMaybe cformat $ jcommodities 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".-journalInferCommodityStyles :: Journal -> Journal-journalInferCommodityStyles j =-  j{jinferredcommodities =-    commodityStylesFromAmounts $-    dbg8 "journalInferCommmodityStyles using amounts" $ journalAmounts j}---- | Given a list of amounts in parse order, build a map from their commodity names--- to standard commodity display formats.-commodityStylesFromAmounts :: [Amount] -> M.Map CommoditySymbol AmountStyle-commodityStylesFromAmounts amts = M.fromList commstyles-  where-    commamts = groupSort [(acommodity as, as) | as <- amts]-    commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]---- | Given an ordered list of amount styles, choose a canonical style.--- That is: the style of the first, and the maximum precision of all.-canonicalStyleFrom :: [AmountStyle] -> AmountStyle-canonicalStyleFrom [] = amountstyle-canonicalStyleFrom ss@(first:_) = first {asprecision = prec, asdecimalpoint = mdec, asdigitgroups = mgrps}-  where-    mgrps = headMay $ mapMaybe asdigitgroups ss-    -- precision is maximum of all precisions-    prec = maximumStrict $ map asprecision ss-    mdec = Just $ headDef '.' $ mapMaybe asdecimalpoint ss-    -- precision is that of first amount with a decimal point-    -- (mdec, prec) =-    --   case filter (isJust . asdecimalpoint) ss of-    --   (s:_) -> (asdecimalpoint s, asprecision s)-    --   []    -> (Just '.', 0)---- -- | Apply this journal's historical price records to unpriced amounts where possible.--- journalApplyMarketPrices :: Journal -> Journal--- journalApplyMarketPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}---     where---       fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}---        where---         fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}---         fixmixedamount (Mixed as) = Mixed $ map fixamount as---         fixamount = fixprice---         fixprice a@Amount{price=Just _} = a---         fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalMarketPriceFor j d c}---- -- | Get the price for a commodity on the specified day from the price database, if known.--- -- Does only one lookup step, ie will not look up the price of a price.--- journalMarketPriceFor :: Journal -> Day -> CommoditySymbol -> Maybe MixedAmount--- journalMarketPriceFor j d CommoditySymbol{symbol=s} = do---   let ps = reverse $ filter ((<= d).mpdate) $ filter ((s==).hsymbol) $ sortBy (comparing mpdate) $ jmarketprices j---   case ps of (MarketPrice{mpamount=a}:_) -> Just a---              _ -> Nothing---- | Convert all this journal's amounts to cost by applying their prices, if any.-journalConvertAmountsToCost :: Journal -> Journal-journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}-    where-      -- similar to journalApplyCommodityStyles-      fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}-      fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}-      fixmixedamount (Mixed as) = Mixed $ map fixamount as-      fixamount = styleAmount styles . costOfAmount-      styles = journalCommodityStyles j---- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.--- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol--- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j---- -- | Get all this journal's amounts' commodities, in the order parsed.--- journalAmountCommodities :: Journal -> [CommoditySymbol]--- journalAmountCommodities = map acommodity . concatMap amounts . journalAmounts---- -- | Get all this journal's amount and price commodities, in the order parsed.--- journalAmountAndPriceCommodities :: Journal -> [CommoditySymbol]--- journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts---- -- | Get this amount's commodity and any commodities referenced in its price.--- amountCommodities :: Amount -> [CommoditySymbol]--- amountCommodities Amount{acommodity=c,aprice=p} =---     case p of Nothing -> [c]---               Just (UnitPrice ma)  -> c:(concatMap amountCommodities $ amounts ma)---               Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma)---- | Get an ordered list of the amounts in this journal which will--- influence amount style canonicalisation. These are:------ * amounts in market price directives (in parse order)--- * amounts in postings (in parse order)------ Amounts in default commodity directives also influence--- canonicalisation, but earlier, as amounts are parsed.--- Amounts in posting prices are not used for canonicalisation.----journalAmounts :: Journal -> [Amount]-journalAmounts = getConst . traverseJournalAmounts (Const . (:[]))---- | Maps over all of the amounts in the journal-overJournalAmounts :: (Amount -> Amount) -> Journal -> Journal-overJournalAmounts f = runIdentity . traverseJournalAmounts (Identity . f)---- | Traverses over all ofthe amounts in the journal, in the order--- indicated by 'journalAmounts'.-traverseJournalAmounts-    :: Applicative f-    => (Amount -> f Amount)-    -> Journal -> f Journal-traverseJournalAmounts f j =-    recombine <$> (traverse . mpa) f (jmarketprices j)-              <*> (traverse . tp . traverse . pamt . maa . traverse) f (jtxns j)-  where-    recombine mps txns = j { jmarketprices = mps, jtxns = txns }-    -- a bunch of traversals-    mpa  g mp = (\amt -> mp { mpamount  = amt }) <$> g (mpamount mp)-    tp   g t  = (\ps  -> t  { tpostings = ps  }) <$> g (tpostings t)-    pamt g p  = (\amt -> p  { pamount   = amt }) <$> g (pamount p)-    maa  g (Mixed as) = Mixed <$> g as---- | The fully specified date span enclosing the dates (primary or secondary)--- of all this journal's transactions and postings, or DateSpan Nothing Nothing--- if there are none.-journalDateSpan :: Bool -> Journal -> DateSpan-journalDateSpan secondary j-    | null ts   = DateSpan Nothing Nothing-    | otherwise = DateSpan (Just earliest) (Just $ addDays 1 latest)-    where-      earliest = minimumStrict dates-      latest   = maximumStrict dates-      dates    = pdates ++ tdates-      tdates   = map (if secondary then transactionDate2 else tdate) ts-      pdates   = concatMap (mapMaybe (if secondary then (Just . postingDate2) else pdate) . tpostings) ts-      ts       = jtxns j---- | Apply the pivot transformation to all postings in a journal,--- replacing their account name by their value for the given field or tag.-journalPivot :: Text -> Journal -> Journal-journalPivot fieldortagname j = j{jtxns = map (transactionPivot fieldortagname) . jtxns $ j}---- | Replace this transaction's postings' account names with the value--- of the given field or tag, if any.-transactionPivot :: Text -> Transaction -> Transaction         -transactionPivot fieldortagname t = t{tpostings = map (postingPivot fieldortagname) . tpostings $ t}---- | Replace this posting's account name with the value--- of the given field or tag, if any, otherwise the empty string.-postingPivot :: Text -> Posting -> Posting         -postingPivot fieldortagname p = p{paccount = pivotedacct, poriginal = Just $ originalPosting p}-  where-    pivotedacct-      | Just t <- ptransaction p, fieldortagname == "code"        = tcode t  -      | Just t <- ptransaction p, fieldortagname == "description" = tdescription t  -      | Just t <- ptransaction p, fieldortagname == "payee"       = transactionPayee t  -      | Just t <- ptransaction p, fieldortagname == "note"        = transactionNote t  -      | Just (_, value) <- postingFindTag fieldortagname p        = value-      | otherwise                                                 = ""--postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)         -postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p---- Misc helpers---- | Check if a set of hledger account/description filter patterns matches the--- given account name or entry description.  Patterns are case-insensitive--- regular expressions. Prefixed with not:, they become anti-patterns.-matchpats :: [String] -> String -> Bool-matchpats pats str =-    (null positives || any match positives) && (null negatives || not (any match negatives))-    where-      (negatives,positives) = partition isnegativepat pats-      match "" = True-      match pat = regexMatchesCI (abspat pat) str--negateprefix = "not:"--isnegativepat = (negateprefix `isPrefixOf`)--abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat---- debug helpers--- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a--- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps---- tests---- A sample journal for testing, similar to examples/sample.journal:------ 2008/01/01 income---     assets:bank:checking  $1---     income:salary------ 2008/06/01 gift---     assets:bank:checking  $1---     income:gifts------ 2008/06/02 save---     assets:bank:saving  $1---     assets:bank:checking------ 2008/06/03 * eat & shop---     expenses:food      $1---     expenses:supplies  $1---     assets:cash------ 2008/10/01 take a loan---     assets:bank:checking $1---     liabilities:debts    $-1------ 2008/12/31 * pay off---     liabilities:debts  $1---     assets:bank:checking----Right samplejournal = journalBalanceTransactions False $-         nulljournal-         {jtxns = [-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/01/01",-             tdate2=Nothing,-             tstatus=Unmarked,-             tcode="",-             tdescription="income",-             tcomment="",-             ttags=[],-             tpostings=-                 ["assets:bank:checking" `post` usd 1-                 ,"income:salary" `post` missingamt-                 ],-             tprecedingcomment=""-           }-          ,-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/06/01",-             tdate2=Nothing,-             tstatus=Unmarked,-             tcode="",-             tdescription="gift",-             tcomment="",-             ttags=[],-             tpostings=-                 ["assets:bank:checking" `post` usd 1-                 ,"income:gifts" `post` missingamt-                 ],-             tprecedingcomment=""-           }-          ,-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/06/02",-             tdate2=Nothing,-             tstatus=Unmarked,-             tcode="",-             tdescription="save",-             tcomment="",-             ttags=[],-             tpostings=-                 ["assets:bank:saving" `post` usd 1-                 ,"assets:bank:checking" `post` usd (-1)-                 ],-             tprecedingcomment=""-           }-          ,-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/06/03",-             tdate2=Nothing,-             tstatus=Cleared,-             tcode="",-             tdescription="eat & shop",-             tcomment="",-             ttags=[],-             tpostings=["expenses:food" `post` usd 1-                       ,"expenses:supplies" `post` usd 1-                       ,"assets:cash" `post` missingamt-                       ],-             tprecedingcomment=""-           }-          ,-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/10/01",-             tdate2=Nothing,-             tstatus=Unmarked,-             tcode="",-             tdescription="take a loan",-             tcomment="",-             ttags=[],-             tpostings=["assets:bank:checking" `post` usd 1-                       ,"liabilities:debts" `post` usd (-1)-                       ],-             tprecedingcomment=""-           }-          ,-           txnTieKnot $ Transaction {-             tindex=0,-             tsourcepos=nullsourcepos,-             tdate=parsedate "2008/12/31",-             tdate2=Nothing,-             tstatus=Unmarked,-             tcode="",-             tdescription="pay off",-             tcomment="",-             ttags=[],-             tpostings=["liabilities:debts" `post` usd 1-                       ,"assets:bank:checking" `post` usd (-1)-                       ],-             tprecedingcomment=""-           }-          ]-         }--tests_Journal = tests "Journal" [--   test "journalDateSpan" $-    journalDateSpan True nulljournal{-      jtxns = [nulltransaction{tdate = parsedate "2014/02/01"-                              ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}]-                              }-              ,nulltransaction{tdate = parsedate "2014/09/01"-                              ,tpostings = [posting{pdate2=Just (parsedate "2014/10/10")}]-                              }-              ]-      }-    `is` (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))--  ,tests "standard account type queries" $-    let-      j = samplejournal-      journalAccountNamesMatching :: Query -> Journal -> [AccountName]-      journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames-      namesfrom qfunc = journalAccountNamesMatching (qfunc j) j-    in [-       test "assets"      $ expectEq (namesfrom journalAssetAccountQuery)     ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]-      ,test "liabilities" $ expectEq (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"]-      ,test "equity"      $ expectEq (namesfrom journalEquityAccountQuery)    []-      ,test "income"      $ expectEq (namesfrom journalRevenueAccountQuery)    ["income","income:gifts","income:salary"]-      ,test "expenses"    $ expectEq (namesfrom journalExpenseAccountQuery)   ["expenses","expenses:food","expenses:supplies"]-    ]--  ,tests "journalBalanceTransactions" [--     test "balance-assignment" $ do-      let ej = journalBalanceTransactions True $-            --2019/01/01-            --  (a)            = 1-            nulljournal{ jtxns = [-              transaction "2019/01/01" [ vpost' "a" missingamt (balassert (num 1)) ]-            ]}-      expectRight ej-      let Right j = ej-      (jtxns j & head & tpostings & head & pamount) `is` Mixed [num 1]--    ,test "same-day-1" $ do-      expectRight $ journalBalanceTransactions True $-            --2019/01/01-            --  (a)            = 1-            --2019/01/01-            --  (a)          1 = 2-            nulljournal{ jtxns = [-               transaction "2019/01/01" [ vpost' "a" missingamt (balassert (num 1)) ]-              ,transaction "2019/01/01" [ vpost' "a" (num 1)    (balassert (num 2)) ]-            ]}--    ,test "same-day-2" $ do-      expectRight $ journalBalanceTransactions True $-            --2019/01/01-            --    (a)                  2 = 2-            --2019/01/01-            --    b                    1-            --    a-            --2019/01/01-            --    a                    0 = 1-            nulljournal{ jtxns = [-               transaction "2019/01/01" [ vpost' "a" (num 2)    (balassert (num 2)) ]-              ,transaction "2019/01/01" [-                 post' "b" (num 1)     Nothing  -                ,post' "a"  missingamt Nothing  -              ]-              ,transaction "2019/01/01" [ post' "a" (num 0)     (balassert (num 1)) ]-            ]}--    ,test "out-of-order" $ do-      expectRight $ journalBalanceTransactions True $-            --2019/1/2-            --  (a)    1 = 2-            --2019/1/1-            --  (a)    1 = 1-            nulljournal{ jtxns = [-               transaction "2019/01/02" [ vpost' "a" (num 1)    (balassert (num 2)) ]-              ,transaction "2019/01/01" [ vpost' "a" (num 1)    (balassert (num 1)) ]-            ]}--    ]-+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE RecordWildCards     #-}++{-|++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+  JournalParser,+  ErroringJournalParser,+  addPriceDirective,+  addTransactionModifier,+  addPeriodicTransaction,+  addTransaction,+  journalDbg,+  journalInferMarketPricesFromTransactions,+  journalInferCommodityStyles,+  journalStyleAmounts,+  journalCommodityStyles,+  journalCommodityStylesWith,+  journalToCost,+  journalInferEquityFromCosts,+  journalTagCostsAndEquityAndMaybeInferCosts,+  journalReverse,+  journalSetLastReadTime,+  journalRenumberAccountDeclarations,+  journalPivot,+  journalPostingsAddAccountTags,+  journalPostingsKeepAccountTagsOnly,+  journalPostingsAddCommodityTags,+-- * Filtering+  filterJournalTransactions,+  filterJournalPostings,+  filterJournalRelatedPostings,+  filterJournalAmounts,+  filterTransactionAmounts,+  filterTransactionPostings,+  filterTransactionPostingsExtra,+  filterTransactionRelatedPostings,+  filterPostingAmount,+  -- * Mapping+  journalMapTransactions,+  journalMapPostings,+  journalMapPostingAmounts,+  -- * Querying+  journalAccountNamesUsed,+  journalAccountNamesImplied,+  journalAccountNamesDeclared,+  journalAccountNamesDeclaredOrUsed,+  journalAccountNamesDeclaredOrImplied,+  journalAccountNames,+  journalLeafAccountNames,+  journalAccountNameTree,+  journalAccountTags,+  journalCommodityTags,+  journalInheritedAccountTags,+  -- journalAmountAndPriceCommodities,+  -- journalAmountStyles,+  -- overJournalAmounts,+  -- traverseJournalAmounts,+  -- journalCanonicalCommodities,+  journalPayeesDeclared,+  journalPayeesUsed,+  journalPayeesDeclaredOrUsed,+  journalTagsDeclared,+  journalTagsUsed,+  journalTagsDeclaredOrUsed,+  journalAmounts,+  journalPostingAmounts,+  journalPostingAndCostAmounts,+  journalCommoditiesDeclared,+  journalCommoditiesUsed,+  journalCommodities,+  journalCommoditiesFromPriceDirectives,+  journalCommoditiesFromTransactions,+  journalDateSpan,+  journalDateSpanBothDates,+  journalStartDate,+  journalEndDate,+  journalLastDay,+  journalDescriptions,+  journalFilePath,+  journalFilePaths,+  journalTransactionAt,+  journalNextTransaction,+  journalPrevTransaction,+  journalPostings,+  showJournalPostingAmountsDebug,+  journalTransactionsSimilarTo,+  -- * Account types+  journalAccountType,+  journalAccountTypes,+  journalAddAccountTypes,+  -- * Conversion accounts+  defaultBaseConversionAccount,+  journalBaseConversionAccount,+  journalConversionAccounts,+  -- * Misc+  nulljournal,+  journalConcat,+  journalNumberTransactions,+  journalNumberAndTieTransactions,+  journalUntieTransactions,+  journalModifyTransactions,+  journalApplyAliases,+  dbgJournalAcctDeclOrder,+  -- * Tests+  samplejournal,+  samplejournalMaybeExplicit,+  tests_Journal,+  --+)+where++import Control.Applicative ((<|>))+import Control.Monad.Except (ExceptT(..))+import Control.Monad.State.Strict (StateT)+import Data.Char (toUpper, isDigit)+import Data.Default (Default(..))+import Data.Foldable (toList)+import Data.List ((\\), find, sortBy, union, intercalate)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.List.Extra (nubSort)+import Data.Map.Strict qualified as M+import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T+import Safe (headMay, headDef, maximumMay, minimumMay, lastDef)+import Data.Time.Calendar (Day, addDays, fromGregorian, diffDays)+import Data.Time.Clock.POSIX (POSIXTime)+import Data.Tree (Tree(..), flatten)+import Text.Printf (printf)+import Text.Megaparsec (ParsecT)++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Amount+import Hledger.Data.Posting+import Hledger.Data.Transaction+import Hledger.Data.TransactionModifier+import Hledger.Data.Valuation+import Hledger.Query+import System.FilePath (takeFileName)+import Data.Ord (comparing)+import Hledger.Data.Dates (nulldate)+import Data.List (sort)+import Data.Function ((&))+-- import Data.Function ((&))+++-- | A parser of text that runs in some monad, keeping a Journal as state.+type JournalParser m a = StateT Journal (ParsecT HledgerParseErrorData Text m) a++-- | A parser of text that runs in some monad, keeping a Journal as+-- state, that can throw an exception to end parsing, preventing+-- further parser backtracking.+type ErroringJournalParser m a =+  StateT Journal (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a++-- 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 $ jinferredcommoditystyles j)+             -- ++ (show $ journalTransactions l)+             where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j++journalDbg j@Journal{..} = chomp $ unlines $+  ("Journal " ++ takeFileName (journalFilePath j)++":") :  --  ++ " {"+  map (" "<>) [+   "jparsedefaultyear: "         <> shw jparsedefaultyear+  ,"jparsedefaultcommodity: "    <> shw jparsedefaultcommodity+  ,"jparsedecimalmark: "         <> shw jparsedecimalmark+  ,"jparseparentaccounts: "      <> shw jparseparentaccounts+  ,"jparsealiases: "             <> shw jparsealiases+  -- ,"jparsetimeclockentries: " <> shw jparsetimeclockentries+  ,"jincludefilestack: "         <> shw jincludefilestack+  ,"jdeclaredpayees: "           <> shw jdeclaredpayees+  ,"jdeclaredtags: "             <> shw jdeclaredtags+  ,"jdeclaredaccounts: "         <> shw jdeclaredaccounts+  ,"jdeclaredaccounttags: "      <> shw jdeclaredaccounttags+  ,"jdeclaredaccounttypes: "     <> shw jdeclaredaccounttypes+  ,"jaccounttypes: "             <> shw jaccounttypes+  ,"jdeclaredcommodities: "      <> shw jdeclaredcommodities+  ,"jinferredcommoditystyles: "  <> shw jinferredcommoditystyles+  ,"jglobalcommoditystyles: "    <> shw jglobalcommoditystyles+  ,"jpricedirectives: "          <> shw jpricedirectives+  ,"jinferredmarketprices: "     <> shw jinferredmarketprices+  ,"jtxnmodifiers: "             <> shw jtxnmodifiers+  -- ,"jperiodictxns: "          <> shw jperiodictxns+  ,"jtxns: "                     <> shw jtxns+  ,"jfinalcommentlines: "        <> shw jfinalcommentlines+  ,"jfiles: "                    <> shw jfiles+  ,"jlastreadtime: "             <> shw jlastreadtime+  ]+  -- ++ ["}"]+  where+    shw :: Show a => a -> String+    shw = show+    -- shw = pshow++-- The semigroup instance for Journal is useful for two situations.+--+-- 1. concatenating finalised journals, eg with multiple -f options:+-- FIRST <> SECOND.+--+-- 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.+--+-- Note that (<>) is right-biased, so nulljournal is only a left identity.+-- In particular, this prevents Journal from being a monoid.+instance Semigroup Journal where j1 <> j2 = j1 `journalConcat` j2++-- | Merge two journals into one.+-- Transaction counts are summed, map fields are combined,+-- the second's list fields are appended to the first's,+-- the second's parse state is kept.+journalConcat :: Journal -> Journal -> Journal+journalConcat j1 j2 =+  let+    f1 = takeFileName $ journalFilePath j1+    f2 = maybe "(unknown)" takeFileName $ fmap fst $ headMay $ jincludefilestack j2  -- XXX more accurate than journalFilePath for some reason+  in+    dbgJournalAcctDeclOrder ("journalConcat: " <> f1 <> " <> " <> f2 <> ", acct decls renumbered: ") $+    journalRenumberAccountDeclarations $+    dbgJournalAcctDeclOrder ("journalConcat: " <> f1 <> " <> " <> f2 <> ", acct decls           : ") $+    Journal {+     jparsedefaultyear          = jparsedefaultyear          j2+    ,jparsedefaultcommodity     = jparsedefaultcommodity     j2+    ,jparsedecimalmark          = jparsedecimalmark          j2+    ,jparseparentaccounts       = jparseparentaccounts       j2+    ,jparsealiases              = jparsealiases              j2+    -- ,jparsetransactioncount     = jparsetransactioncount     j1 +  jparsetransactioncount     j2+    ,jparsetimeclockentries     = jparsetimeclockentries     j1 <> jparsetimeclockentries     j2+    ,jincludefilestack          = jincludefilestack j2+    ,jdeclaredpayees            = jdeclaredpayees            j1 <> jdeclaredpayees            j2+    ,jdeclaredtags              = jdeclaredtags              j1 <> jdeclaredtags              j2+    ,jdeclaredaccounts          = jdeclaredaccounts          j1 <> jdeclaredaccounts          j2+    --+    -- The next six fields are Maps, which need to be merged carefully for correct semantics,+    -- especially the first two, which have list values. There may still be room for improvement here.+    --+    -- ,jdeclaredaccounttags   :: M.Map AccountName [Tag]+    -- jdeclaredaccounttags can have multiple duplicated/conflicting values for an account's tag.+    ,jdeclaredaccounttags       = M.unionWith (<>) (jdeclaredaccounttags j1) (jdeclaredaccounttags j2)+    --+    -- ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]+    -- jdeclaredaccounttypes can have multiple duplicated/conflicting values for an account's type.+    ,jdeclaredaccounttypes      = M.unionWith (<>) (jdeclaredaccounttypes j1) (jdeclaredaccounttypes j2)+    --+    -- ,jaccounttypes          :: M.Map AccountName AccountType+    -- jaccounttypes has a single type for any given account. When it had multiple type declarations, the last/rightmost wins.+    ,jaccounttypes              = M.unionWith (const id) (jaccounttypes j1) (jaccounttypes j2)+    --+    -- ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle+    ,jglobalcommoditystyles     = (<>) (jglobalcommoditystyles j1) (jglobalcommoditystyles j2)+    --+    -- ,jdeclaredcommodities           :: M.Map CommoditySymbol Commodity+    ,jdeclaredcommodities               = (<>) (jdeclaredcommodities j1) (jdeclaredcommodities j2)+    --+    -- ,jdeclaredcommoditytags     :: M.Map CommoditySymbol [Tag]+    ,jdeclaredcommoditytags     = M.unionWith (<>) (jdeclaredcommoditytags j1) (jdeclaredcommoditytags j2)+    --+    -- ,jinferredcommoditystyles   :: M.Map CommoditySymbol AmountStyle+    ,jinferredcommoditystyles       = (<>) (jinferredcommoditystyles j1) (jinferredcommoditystyles j2)+    --+    --+    ,jpricedirectives           = jpricedirectives           j1 <> jpricedirectives           j2+    ,jinferredmarketprices      = jinferredmarketprices      j1 <> jinferredmarketprices      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)+    }++-- | Renumber all the account declarations. This is useful to call when+-- finalising or concatenating Journals, to give account declarations+-- a total order across files.+journalRenumberAccountDeclarations :: Journal -> Journal+journalRenumberAccountDeclarations j = j{jdeclaredaccounts=jdas'}+  where+    jdas' = [(a, adi{adideclarationorder=n}) | (n, (a,adi)) <- zip [1..] $ jdeclaredaccounts j]+    -- the per-file declaration order saved during parsing is discarded,+    -- it seems unneeded except perhaps for debugging++-- | Debug log the ordering of a journal's account declarations+-- (at debug level 7+).+dbgJournalAcctDeclOrder :: String -> Journal -> Journal+dbgJournalAcctDeclOrder prefix =+  dbg7With ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)+  where+    showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String+    showAcctDeclsSummary adis+      | length adis < (2*n+2) = "[" <> showadis adis <> "]"+      | otherwise =+          "[" <> showadis (take n adis) <> " ... " <> showadis (takelast n adis) <> "]"+      where+        n = 3+        showadis = intercalate ", " . map showadi+        showadi (a,adi) = "("<>show (adideclarationorder adi)<>","<>T.unpack a<>")"+        takelast n' = reverse . take n' . reverse++instance Default Journal where+  def = nulljournal++nulljournal :: Journal+nulljournal = Journal {+   jparsedefaultyear          = Nothing+  ,jparsedefaultcommodity     = Nothing+  ,jparsedecimalmark          = Nothing+  ,jparseparentaccounts       = []+  ,jparsealiases              = []+  -- ,jparsetransactioncount     = 0+  ,jparsetimeclockentries     = []+  ,jincludefilestack          = []+  ,jdeclaredpayees            = []+  ,jdeclaredtags              = []+  ,jdeclaredaccounts          = []+  ,jdeclaredaccounttags       = M.empty+  ,jdeclaredaccounttypes      = M.empty+  ,jaccounttypes              = M.empty+  ,jglobalcommoditystyles     = M.empty+  ,jdeclaredcommodities       = M.empty+  ,jdeclaredcommoditytags     = M.empty+  ,jinferredcommoditystyles   = M.empty+  ,jpricedirectives           = []+  ,jinferredmarketprices      = []+  ,jtxnmodifiers              = []+  ,jperiodictxns              = []+  ,jtxns                      = []+  ,jfinalcommentlines         = ""+  ,jfiles                     = []+  ,jlastreadtime              = 0+  }++journalFilePath :: Journal -> FilePath+journalFilePath = fst . mainfile++journalFilePaths :: Journal -> [FilePath]+journalFilePaths = map fst . jfiles++mainfile :: Journal -> (FilePath, Text)+mainfile = headDef ("(unknown)", "") . 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)++-- | All postings from this journal's transactions, in order.+journalPostings :: Journal -> [Posting]+journalPostings = concatMap tpostings . jtxns++-- | All posting amounts from this journal, in order.+journalPostingAmounts :: Journal -> [MixedAmount]+journalPostingAmounts = map pamount . journalPostings++-- | Show the journal posting amounts rendered, suitable for debug logging.+showJournalPostingAmountsDebug :: Journal -> String+showJournalPostingAmountsDebug = show . map showMixedAmountOneLine . journalPostingAmounts++-- | All raw amounts used in this journal's postings and costs,+-- with MixedAmounts flattened, in parse order.+journalPostingAndCostAmounts :: Journal -> [Amount]+journalPostingAndCostAmounts = concatMap getAmounts . concatMap (amountsRaw . pamount) . journalPostings++-- | All raw amounts appearing in this journal, with MixedAmounts flattened, in no particular order.+-- (Including from posting amounts, cost amounts, P directives, and the last D directive.)+journalAmounts :: Journal -> S.Set Amount+journalAmounts = S.fromList . journalStyleInfluencingAmounts True++-- | Sorted unique commodity symbols declared by commodity directives in this journal.+journalCommoditiesDeclared :: Journal -> [CommoditySymbol]+journalCommoditiesDeclared = M.keys . jdeclaredcommodities++-- | Sorted unique commodity symbols used anywhere in this journal, including+-- commodity directives, P directives, the last D directive, posting amounts and cost amounts.+journalCommoditiesUsed :: Journal -> [CommoditySymbol]+journalCommoditiesUsed j = S.elems $+  journalCommoditiesFromPriceDirectives j <>+  (S.fromList $ map acommodity $ journalStyleInfluencingAmounts True j)++-- | Sorted unique commodity symbols mentioned anywhere in this journal.+-- (Including commodity directives, P directives, the last D directive, posting amounts and cost amounts.)+journalCommodities :: Journal -> S.Set CommoditySymbol+journalCommodities j =+     M.keysSet (jdeclaredcommodities j)+  <> journalCommoditiesFromPriceDirectives j+  <> S.fromList (map acommodity $ journalStyleInfluencingAmounts True j)++-- | Sorted unique commodity symbols mentioned in this journal's P directives.+journalCommoditiesFromPriceDirectives :: Journal -> S.Set CommoditySymbol+journalCommoditiesFromPriceDirectives = S.fromList . concatMap pdcomms . jpricedirectives+  where pdcomms pd = [pdcommodity pd, acommodity $ pdamount pd]++-- | Sorted unique commodity symbols used in transactions, in either posting or cost amounts.+journalCommoditiesFromTransactions :: Journal -> S.Set CommoditySymbol+journalCommoditiesFromTransactions j = S.fromList $ map acommodity $ journalPostingAndCostAmounts j++-- | Unique transaction descriptions used in this journal.+journalDescriptions :: Journal -> [Text]+journalDescriptions = nubSort . map tdescription . jtxns++-- | Sorted unique payees declared by payee directives in this journal.+journalPayeesDeclared :: Journal -> [Payee]+journalPayeesDeclared = nubSort . map fst . jdeclaredpayees++-- | Sorted unique payees used by transactions in this journal.+journalPayeesUsed :: Journal -> [Payee]+journalPayeesUsed = nubSort . map transactionPayee . jtxns++-- | Sorted unique payees used in transactions or declared by payee directives in this journal.+journalPayeesDeclaredOrUsed :: Journal -> [Payee]+journalPayeesDeclaredOrUsed j = toList $ foldMap S.fromList+    [journalPayeesDeclared j, journalPayeesUsed j]++-- | Sorted unique tag names declared by tag directives in this journal.+journalTagsDeclared :: Journal -> [TagName]+journalTagsDeclared = nubSort . map fst . jdeclaredtags++-- | Sorted unique tag names used in this journal (in account directives, transactions, postings..)+journalTagsUsed :: Journal -> [TagName]+journalTagsUsed j = nubSort $ map fst $ concatMap transactionAllTags $ jtxns j+  -- tags used in all transactions and postings and postings' accounts++-- | Sorted unique tag names used in transactions or declared by tag directives in this journal.+journalTagsDeclaredOrUsed :: Journal -> [TagName]+journalTagsDeclaredOrUsed j = toList $ foldMap S.fromList+    [journalTagsDeclared j, journalTagsUsed j]++-- | 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 = toList $ foldMap S.fromList+    [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 = toList $ foldMap S.fromList+    [journalAccountNamesDeclared j, expandAccountNames $ journalAccountNamesUsed j]++-- | Convenience/compatibility alias for journalAccountNamesDeclaredOrImplied.+journalAccountNames :: Journal -> [AccountName]+journalAccountNames = journalAccountNamesDeclaredOrImplied++-- | Sorted unique account names declared or implied in this journal+-- which have no children.+journalLeafAccountNames :: Journal -> [AccountName]+journalLeafAccountNames = treeLeaves . journalAccountNameTree++journalAccountNameTree :: Journal -> Tree AccountName+journalAccountNameTree = accountNameTreeFrom . journalAccountNamesDeclaredOrImplied++-- | Which tags have been declared explicitly for this account, if any ?+journalAccountTags :: Journal -> AccountName -> [Tag]+journalAccountTags Journal{jdeclaredaccounttags} a = M.findWithDefault [] a jdeclaredaccounttags++-- | Which tags are in effect for this account, including tags inherited from parent accounts ?+journalInheritedAccountTags :: Journal -> AccountName -> [Tag]+journalInheritedAccountTags j a =+  foldl' (\ts a' -> ts `union` journalAccountTags j a') [] as+  where+    as = a : parentAccountNames a+-- PERF: cache in journal ?++type DateWeightedSimilarityScore = Double+type SimilarityScore = Double+type Age = Integer++-- | Find up to N most similar and most recent transactions matching+-- the given transaction description and query and exceeding the given+-- description similarity score (0 to 1, see compareDescriptions).+-- Returns transactions along with+-- their age in days compared to the latest transaction date,+-- their description similarity score,+-- and a heuristically date-weighted variant of this that favours more recent transactions.+journalTransactionsSimilarTo :: Journal -> Text -> Query -> SimilarityScore -> Int+  -> [(DateWeightedSimilarityScore, Age, SimilarityScore, Transaction)]+journalTransactionsSimilarTo Journal{jtxns} desc q similaritythreshold n =+  take n $+  dbg1With (+    unlines . +    ("up to 30 transactions above description similarity threshold "<>show similaritythreshold<>" ordered by recency-weighted similarity:":) .+    take 30 .+    map ( \(w,a,s,Transaction{..}) -> printf "weighted:%8.3f  age:%4d similarity:%5.3f  %s %s" w a s (show tdate) tdescription )) $+  sortBy (comparing (negate.first4)) $+  map (\(s,t) -> (weightedScore (s,t), age t, s, t)) $+  filter ((> similaritythreshold).fst)+  [(compareDescriptions desc $ tdescription t, t) | t <- jtxns, q `matchesTransaction` t]+  where+    latest = lastDef nulldate $ sort $ map tdate jtxns+    age = diffDays latest . tdate+    -- Combine similarity and recency heuristically. This gave decent results+    -- in my "find most recent invoice" use case in 2023-03,+    -- but will probably need more attention.+    weightedScore :: (Double, Transaction) -> Double+    weightedScore (s, t) = 100 * s - fromIntegral (age t) / 4++-- | Return a similarity score from 0 to 1.5 for two transaction descriptions. +-- This is based on compareStrings, with the following modifications:+--+-- - numbers are stripped out before measuring similarity+--+-- - if the (unstripped) first description appears in its entirety within the second,+--   the score is boosted by 0.5.+--+compareDescriptions :: Text -> Text -> Double+compareDescriptions a b =+  (if a `T.isInfixOf` b then (0.5+) else id) $+  compareStrings (simplify a) (simplify b)+  where+    simplify = T.unpack . T.filter (not.isDigit)++-- | Return a similarity score from 0 to 1 for two strings.  This+-- was based on Simon White's string similarity algorithm+-- (http://www.catalysoft.com/articles/StrikeAMatch.html), later found+-- to be https://en.wikipedia.org/wiki/S%C3%B8rensen%E2%80%93Dice_coefficient,+-- and modified to handle short strings better.+-- Todo: check out http://nlp.fi.muni.cz/raslan/2008/raslan08.pdf#page=14 .+compareStrings :: String -> String -> Double+compareStrings "" "" = 1+compareStrings [_] "" = 0+compareStrings "" [_] = 0+compareStrings [a] [b] = if toUpper a == toUpper b then 1 else 0+compareStrings s1 s2 = 2 * commonpairs / totalpairs+  where+    pairs1      = S.fromList $ wordLetterPairs $ uppercase s1+    pairs2      = S.fromList $ wordLetterPairs $ uppercase s2+    commonpairs = fromIntegral $ S.size $ S.intersection pairs1 pairs2+    totalpairs  = fromIntegral $ S.size pairs1 + S.size pairs2++wordLetterPairs :: String -> [String]+wordLetterPairs = concatMap letterPairs . words++letterPairs :: String -> [String]+letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)+letterPairs _ = []++-- Newer account type code.++journalAccountType :: Journal -> AccountName -> Maybe AccountType+journalAccountType Journal{jaccounttypes} = accountNameType jaccounttypes++-- | Add a map of all known account types to the journal.+journalAddAccountTypes :: Journal -> Journal+journalAddAccountTypes j = j{jaccounttypes = journalAccountTypes j}++-- | An account type inherited from the parent account(s),+-- and whether it was originally declared by an account directive (true) or inferred from an account name (false).+type ParentAccountType = (AccountType, Bool)++-- | Build a map of all known account types, explicitly declared+-- or inferred from the account's parent or name.+journalAccountTypes :: Journal -> M.Map AccountName AccountType+journalAccountTypes j = M.fromList [(a,acctType) | (a, Just (acctType,_)) <- flatten t']+  where+    t = accountNameTreeFrom $ journalAccountNames j :: Tree AccountName+    -- Traverse downward through the account tree, applying any explicitly declared account types,+    -- otherwise inferring account types from account names when possible, and propagating account types downward.+    -- Declared account types (possibly inherited from parent) are preferred, inferred types are used as a fallback.+    t' = setTypeHereAndBelow Nothing t :: Tree (AccountName, Maybe (AccountType, Bool))+      where+        declaredtypes       = M.keys $ jdeclaredaccounttypes j+        declaredtypesbyname = journalDeclaredAccountTypes j & fmap (,True)+        setTypeHereAndBelow :: Maybe ParentAccountType -> Tree AccountName -> Tree (AccountName, Maybe ParentAccountType)+        setTypeHereAndBelow mparenttype (Node a subs) = Node (a, mnewtype) (map (setTypeHereAndBelow mnewtype) subs)+          where+            mnewtype = mthisacctdeclaredtype <|> mparentacctdeclaredtype <|> mthisacctinferredtype <|> mparentacctinferredtype+              where+                mthisacctdeclaredtype   = M.lookup a declaredtypesbyname+                mparentacctdeclaredtype = if       fromMaybe False $ snd <$> mparenttype then mparenttype else Nothing+                mparentacctinferredtype = if not $ fromMaybe True  $ snd <$> mparenttype then mparenttype else Nothing+                mthisacctinferredtype   = accountNameInferTypeExcept declaredtypes a & fmap (,False)  -- XXX not sure about this Except logic.. but for now, tests pass++-- | Build a map from account names to explicitly declared account types.+journalDeclaredAccountTypes :: Journal -> M.Map AccountName AccountType+journalDeclaredAccountTypes Journal{jdeclaredaccounttypes} =+  M.fromList $ concat [map (,t) as | (t,as) <- M.toList jdeclaredaccounttypes]++-- | To all postings in the journal, add any tags from their account+-- (including those inherited from parent accounts).+-- If a tag already exists on the posting, it is not changed (the account tag will be ignored).+journalPostingsAddAccountTags :: Journal -> Journal+journalPostingsAddAccountTags j = journalMapPostings addtags j+  where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p)++-- | Get any tags declared for this commodity.+journalCommodityTags :: Journal -> CommoditySymbol -> [Tag]+journalCommodityTags Journal{jdeclaredcommoditytags} c =+  M.findWithDefault [] c jdeclaredcommoditytags++-- | To all postings in the journal, add any tags from their amount's commodities.+-- If a tag already exists on the posting, it is not changed (the commodity tag will be ignored).+journalPostingsAddCommodityTags :: Journal -> Journal+journalPostingsAddCommodityTags j = journalMapPostings addtags j+  where+    addtags p = p `postingAddTags` concatMap (journalCommodityTags j) (postingCommodities p)++-- | Remove all tags from the journal's postings except those provided by their account.+-- This is useful for the accounts report.+-- It does not remove tag declarations from the posting comments.+journalPostingsKeepAccountTagsOnly :: Journal -> Journal+journalPostingsKeepAccountTagsOnly j = journalMapPostings keepaccounttags j+  where keepaccounttags p = p{ptags=[]} `postingAddTags` (journalInheritedAccountTags j $ paccount p)++-- | The account name to use for conversion postings generated by --infer-equity.+-- This is the first account declared with type V/Conversion,+-- or otherwise the defaultBaseConversionAccount (equity:conversion).+journalBaseConversionAccount :: Journal -> AccountName+journalBaseConversionAccount = headDef defaultBaseConversionAccount . journalConversionAccounts++-- | All the accounts in this journal which are declared or inferred as V/Conversion type.+-- This does not include new account names which might be generated by --infer-equity, currently.+journalConversionAccounts :: Journal -> [AccountName]+journalConversionAccounts = M.keys . M.filter (==Conversion) . jaccounttypes+++-- 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} = j{jtxns=filter (matchesTransactionExtra (journalAccountType j) q) jtxns}++-- | 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 (filterTransactionPostingsExtra (journalAccountType j) q) ts}++-- | Keep only postings which do not match the query expression, but for which a related posting does.+-- This can leave unbalanced transactions.+filterJournalRelatedPostings :: Query -> Journal -> Journal+filterJournalRelatedPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionRelatedPostings q) ts}++-- | Within each posting's amount, keep only the parts matching the query, and+-- remove any postings with all amounts removed.+-- 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, and remove any postings with all amounts removed.+-- This can leave the transaction unbalanced.+filterTransactionAmounts :: Query -> Transaction -> Transaction+filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=mapMaybe (filterPostingAmount q) ps}++-- | Filter out all parts of this posting's amount which do not match the query, and remove the posting+-- if this removes all amounts.+filterPostingAmount :: Query -> Posting -> Maybe Posting+filterPostingAmount q p@Posting{pamount=as}+  | null newamt = Nothing+  | otherwise   = Just p{pamount=Mixed newamt}+  where+    Mixed newamt = filterMixedAmount (q `matchesAmount`) as++filterTransactionPostings :: Query -> Transaction -> Transaction+filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}++-- Like filterTransactionPostings, but is given the map of account types so can also filter by account type.+filterTransactionPostingsExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Transaction+filterTransactionPostingsExtra atypes q t@Transaction{tpostings=ps} =+  t{tpostings=filter (matchesPostingExtra atypes q) ps}++filterTransactionRelatedPostings :: Query -> Transaction -> Transaction+filterTransactionRelatedPostings q t@Transaction{tpostings=ps} =+    t{tpostings=if null matches then [] else ps \\ matches}+  where matches = filter (matchesPosting q) ps++-- | Apply a transformation to a journal's transactions.+journalMapTransactions :: (Transaction -> Transaction) -> Journal -> Journal+journalMapTransactions f j@Journal{jtxns=ts} = j{jtxns=map f ts}++-- | Apply a transformation to a journal's postings.+journalMapPostings :: (Posting -> Posting) -> Journal -> Journal+journalMapPostings f j@Journal{jtxns=ts} = j{jtxns=map (transactionMapPostings f) ts}++-- | Apply a transformation to a journal's posting amounts.+journalMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Journal -> Journal+journalMapPostingAmounts f = journalMapPostings (postingTransformAmount f)++{-+-------------------------------------------------------------------------------+-- 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 :: POSIXTime -> 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=zipWith (\i t -> t{tindex=i}) [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). Or if a modifier rule fails to parse,+-- return the error message. A reference date is provided to help interpret+-- relative dates in transaction modifier queries.+-- The first argument selects whether to add visible tags to generated postings & modified transactions.+journalModifyTransactions :: Bool -> Day -> Journal -> Either String Journal+journalModifyTransactions verbosetags d j =+  case modifyTransactions (journalAccountType j) (journalInheritedAccountTags j) (journalCommodityStyles j) d verbosetags (jtxnmodifiers j) (jtxns j) of+    Right ts -> Right j{jtxns=ts}+    Left err -> Left err++-- | Apply this journal's commodity display styles to all of its amounts.+-- This does no display rounding, keeping decimal digits as they were;+-- it is suitable for an early cleanup pass before calculations.+-- Reports may want to do additional rounding/styling at render time.+-- This can return an error message eg if inconsistent number formats are found.+journalStyleAmounts :: Journal -> Either String Journal+journalStyleAmounts = fmap journalapplystyles . journalInferCommodityStyles+  where+    journalapplystyles j@Journal{jpricedirectives=pds} =+      journalMapPostings (styleAmounts styles) j{jpricedirectives=map fixpricedirective pds}+      where+        styles = journalCommodityStylesWith NoRounding j  -- defer rounding, in case of print --round=none+        fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmounts styles a}++-- | Get the canonical amount styles for this journal, whether (in order of precedence):+-- set globally in InputOpts,+-- declared by commodity directives, +-- declared by a default commodity (D) directive, +-- or inferred from posting amounts, +-- as a map from symbol to style. +-- Styles from directives are assumed to specify the decimal mark.+journalCommodityStyles :: Journal -> M.Map CommoditySymbol AmountStyle+journalCommodityStyles j =+  -- XXX could be some redundancy here, cf journalStyleInfluencingAmounts+  globalstyles <> declaredstyles <> defaultcommoditystyle <> inferredstyles+  where+    globalstyles          = jglobalcommoditystyles j+    declaredstyles        = M.mapMaybe cformat $ jdeclaredcommodities j+    defaultcommoditystyle = M.fromList $ catMaybes [jparsedefaultcommodity j]+    inferredstyles        = jinferredcommoditystyles j++-- | Like journalCommodityStyles, but attach a particular rounding strategy to the styles,+-- affecting how they will affect display precisions when applied.+journalCommodityStylesWith :: Rounding -> Journal -> M.Map CommoditySymbol AmountStyle+journalCommodityStylesWith r = amountStylesSetRounding r . journalCommodityStyles++-- | Collect and save inferred amount styles for each commodity based on+-- P directive amounts, posting amounts but not cost amounts, and maybe the last D amount, in that commodity.+-- Can return an error message eg if inconsistent number formats are found.+journalInferCommodityStyles :: Journal -> Either String Journal+journalInferCommodityStyles j =+  case commodityStylesFromAmounts $ journalStyleInfluencingAmounts False j of+    Left e   -> Left e+    Right cs -> Right j{jinferredcommoditystyles = dbg7 "journalInferCommodityStyles" cs}++-- -- | 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+--       fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}+--        where+--         fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}+--         fixmixedamount = mapMixedAmount fixamount+--         fixamount = fixprice+--         fixprice a@Amount{price=Just _} = a+--         fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitCost) $ journalPriceDirectiveFor j d c}++-- -- | Get the price for a commodity on the specified day from the price database, if known.+-- -- Does only one lookup step, ie will not look up the price of a price.+-- journalPriceDirectiveFor :: Journal -> Day -> CommoditySymbol -> Maybe MixedAmount+-- journalPriceDirectiveFor j d CommoditySymbol{symbol=s} = do+--   let ps = reverse $ filter ((<= d).pddate) $ filter ((s==).hsymbol) $ sortBy (comparing pddate) $ jpricedirectives j+--   case ps of (PriceDirective{pdamount=a}:_) -> Just a+--              _ -> Nothing++-- | Infer transaction-implied market prices from commodity-exchanging+-- transactions, if any. It's best to call this after transactions have+-- been balanced and posting amounts have appropriate prices attached.+journalInferMarketPricesFromTransactions :: Journal -> Journal+journalInferMarketPricesFromTransactions j =+  j{jinferredmarketprices =+       dbg4With (("jinferredmarketprices:\n"<>) . showMarketPrices) $+       map priceDirectiveToMarketPrice .+       concatMap postingPriceDirectivesFromCost $+       journalPostings j+   }++-- | Convert all this journal's amounts to cost using their attached prices, if any.+journalToCost :: ConversionOp -> Journal -> Journal+journalToCost cost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost cost) ts}++-- | Identify and tag (1) equity conversion postings and (2) postings which have (or could have ?) redundant costs.+-- And if the addcosts flag is true, also add any costs which can be inferred from equity conversion postings.+-- This is always called before transaction balancing to tag the redundant-cost postings so they can be ignored.+-- With --infer-costs, it is called again after transaction balancing (when it has more information to work with) to infer costs from equity postings.+-- See transactionTagCostsAndEquityAndMaybeInferCosts for more details, and hledger manual > Cost reporting for more background.+journalTagCostsAndEquityAndMaybeInferCosts :: Bool -> Bool -> Journal -> Either String Journal+journalTagCostsAndEquityAndMaybeInferCosts verbosetags addcosts j = do+  let conversionaccts = journalConversionAccounts j+  ts <- mapM (transactionTagCostsAndEquityAndMaybeInferCosts verbosetags addcosts conversionaccts) $ jtxns j+  return j{jtxns=ts}++-- | Add equity postings inferred from costs, where needed and possible.+-- See hledger manual > Cost reporting.+journalInferEquityFromCosts :: Bool -> Journal -> Journal+journalInferEquityFromCosts verbosetags j =+  journalMapTransactions (transactionInferEquityPostings verbosetags equityAcct) j+  where equityAcct = journalBaseConversionAccount j++-- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.+-- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol+-- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j++-- -- | Get all this journal's amounts' commodities, in the order parsed.+-- journalAmountCommodities :: Journal -> [CommoditySymbol]+-- journalAmountCommodities = map acommodity . concatMap amounts . journalAmounts++-- -- | Get all this journal's amount and price commodities, in the order parsed.+-- journalAmountAndPriceCommodities :: Journal -> [CommoditySymbol]+-- journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts++-- -- | Get this amount's commodity and any commodities referenced in its price.+-- amountCommodities :: Amount -> [CommoditySymbol]+-- amountCommodities Amount{acommodity=c,acost=p} =+--     case p of Nothing -> [c]+--               Just (UnitCost ma)  -> c:(concatMap amountCommodities $ amounts ma)+--               Just (TotalCost ma) -> c:(concatMap amountCommodities $ amounts ma)++-- | Get an ordered list of amounts in this journal which can influence+-- canonical amount display styles (excluding the ones in commodity directives). +-- They are, in the following order:+--+-- * amounts in market price (P) directives (in parse order)+-- * posting amounts and optionally cost amounts (in parse order)+-- * the amount in the final default commodity (D) directive+--+journalStyleInfluencingAmounts :: Bool -> Journal -> [Amount]+journalStyleInfluencingAmounts includecost j =+  dbg7 "journalStyleInfluencingAmounts" $+  catMaybes $ concat [+   [mdefaultcommodityamt]+  ,map (Just . pdamount) $ jpricedirectives j+  ,map Just $ if includecost+    then journalPostingAndCostAmounts j+    else concatMap amountsRaw $ journalPostingAmounts j+  ]+  where+    -- D's amount style isn't actually stored as an amount, make it into one+    mdefaultcommodityamt =+      case jparsedefaultcommodity j of+        Just (symbol,style) -> Just nullamt{acommodity=symbol,astyle=style}+        Nothing -> Nothing++-- overcomplicated/unused amount traversal stuff+--+--  Get an ordered list of 'AmountStyle's from the amounts in this+-- journal which influence canonical amount display styles. See+-- traverseJournalAmounts.+-- journalAmounts :: Journal -> [Amount]+-- journalAmounts = getConst . traverseJournalAmounts (Const . (:[]))+--+--  Apply a transformation to the journal amounts traversed by traverseJournalAmounts.+-- overJournalAmounts :: (Amount -> Amount) -> Journal -> Journal+-- overJournalAmounts f = runIdentity . traverseJournalAmounts (Identity . f)+--+--  A helper that traverses over most amounts in the journal,+-- in particular the ones which influence canonical amount display styles,+-- processing them with the given applicative function.+--+-- These include, in the following order:+--+-- * the amount in the final default commodity (D) directive+-- * amounts in market price (P) directives (in parse order)+-- * posting amounts in transactions (in parse order)+--+-- Transaction price amounts, which may be embedded in posting amounts+-- (the acost field), are left intact but not traversed/processed.+--+-- traverseJournalAmounts :: Applicative f => (Amount -> f Amount) -> Journal -> f Journal+-- traverseJournalAmounts f j =+--   recombine <$> (traverse . dcamt) f (jparsedefaultcommodity j)+--             <*> (traverse . pdamt) f (jpricedirectives j)+--             <*> (traverse . tps . traverse . pamt . amts . traverse) f (jtxns j)+--   where+--     recombine pds txns = j { jpricedirectives = pds, jtxns = txns }+--     -- a bunch of traversals+--     dcamt g pd         = (\mdc -> case mdc of Nothing -> Nothing+--                                               Just ((c,stpd{pdamount =amt}+--                          ) <$> g (pdamount pd)+--     pdamt g pd         = (\amt -> pd{pdamount =amt}) <$> g (pdamount pd)+--     tps   g t          = (\ps  -> t {tpostings=ps }) <$> g (tpostings t)+--     pamt  g p          = (\amt -> p {pamount  =amt}) <$> g (pamount p)+--     amts  g (Mixed as) = Mixed <$> g as++-- | The fully specified exact date span enclosing the dates (primary or secondary)+-- of all this journal's transactions and postings, or DateSpan Nothing Nothing+-- if there are none.+journalDateSpan :: Bool -> Journal -> DateSpan+journalDateSpan False = journalDateSpanHelper $ Just PrimaryDate+journalDateSpan True  = journalDateSpanHelper $ Just SecondaryDate++-- | The fully specified date span enclosing the dates (primary and secondary)+-- of all this journal's transactions and postings, or DateSpan Nothing Nothing+-- if there are none.+journalDateSpanBothDates :: Journal -> DateSpan+journalDateSpanBothDates = journalDateSpanHelper Nothing++-- | A helper for journalDateSpan which takes Maybe WhichDate directly. Nothing+-- uses both primary and secondary dates.+journalDateSpanHelper :: Maybe WhichDate -> Journal -> DateSpan+journalDateSpanHelper whichdate j =+    DateSpan (Exact <$> minimumMay dates) (Exact . addDays 1 <$> maximumMay dates)+  where+    dates    = pdates ++ tdates+    tdates   = concatMap gettdate ts+    pdates   = concatMap getpdate $ concatMap tpostings ts+    ts       = jtxns j+    gettdate t = case whichdate of+        Just PrimaryDate   -> [tdate t]+        Just SecondaryDate -> [fromMaybe (tdate t) $ tdate2 t]+        Nothing            -> tdate t : maybeToList (tdate2 t)+    getpdate p = case whichdate of+        Just PrimaryDate   -> maybeToList $ pdate p+        Just SecondaryDate -> maybeToList $ pdate2 p <|> pdate p+        Nothing            -> catMaybes [pdate p, pdate2 p]++-- | The earliest of this journal's transaction and posting dates, or+-- Nothing if there are none.+journalStartDate :: Bool -> Journal -> Maybe Day+journalStartDate secondary j = fromEFDay <$> b where DateSpan b _ = journalDateSpan secondary j++-- | The "exclusive end date" of this journal: the day following its latest transaction +-- or posting date, or Nothing if there are none.+journalEndDate :: Bool -> Journal -> Maybe Day+journalEndDate secondary j = fromEFDay <$> e where DateSpan _ e = journalDateSpan secondary j++-- | The latest of this journal's transaction and posting dates, or+-- Nothing if there are none.+journalLastDay :: Bool -> Journal -> Maybe Day+journalLastDay secondary j = addDays (-1) <$> journalEndDate secondary j++-- | Apply the pivot transformation to all postings in a journal,+-- replacing their account name by their value for the given field or tag.+journalPivot :: Text -> Journal -> Journal+journalPivot fieldortagname j = j{jtxns = map (transactionPivot fieldortagname) . jtxns $ j}++-- | Replace this transaction's postings' account names with the value+-- of the given field or tag, if any.+transactionPivot :: Text -> Transaction -> Transaction+transactionPivot fieldortagname t = t{tpostings = map (postingPivot fieldortagname) . tpostings $ t}++-- | Replace this posting's account name with the value+-- of the given field or tag, if any, otherwise the empty string.+postingPivot :: Text -> Posting -> Posting+postingPivot fieldortagname p =+  p{paccount = pivotAccount fieldortagname p, poriginal = Just $ originalPosting p}++pivotAccount :: Text -> Posting -> Text+pivotAccount fieldortagname p =+  T.intercalate ":" [pivotComponent x p | x <- T.splitOn ":" fieldortagname]++-- | Get the value of the given field or tag for this posting.+-- "comm" and "cur" are accepted as synonyms meaning the commodity symbol.+-- Pivoting on an unknown field or tag, or on commodity when there are multiple commodities, returns "".+-- Pivoting on a tag when there are multiple values for that tag, returns the first value.+-- Pivoting on the "type" tag normalises type values to their short spelling.+pivotComponent :: Text -> Posting -> Text+pivotComponent fieldortagname p+  | fieldortagname == "code",        Just t <- ptransaction p = tcode t+  | fieldortagname `elem` descnames, Just t <- ptransaction p = tdescription t+  | fieldortagname == "payee",       Just t <- ptransaction p = transactionPayee t+  | fieldortagname == "note",        Just t <- ptransaction p = transactionNote t+  | fieldortagname == "status",      Just t <- ptransaction p = T.pack . show . tstatus $ t+  | fieldortagname == "acct"        = paccount p+  | fieldortagname `elem` commnames = case map acommodity $ amounts $ pamount p of [s] -> s; _ -> unknown+  | fieldortagname == "amt"         = case amounts $ pamount p of [a] -> T.pack $ show $ aquantity a; _ -> unknown+  | fieldortagname == "cost"        = case amounts $ pamount p of [a@Amount{acost=Just _}] -> T.pack $ lstrip $ showAmountCost a; _ -> unknown+  | Just (_, tagvalue) <- postingFindTag fieldortagname p =+      if fieldortagname == "type"+      then either (const tagvalue) (T.pack . show) $ parseAccountType True tagvalue+      else tagvalue+  | otherwise = unknown+  where+    descnames = ["desc", "description"]   -- allow "description" for hledger <=1.30 compat+    commnames = ["cur","comm"]            -- allow either; cur is the query prefix, comm is more consistent+    unknown   = ""++postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)+postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p++-- | Apply some account aliases to all posting account names in the journal, as described by accountNameApplyAliases.+-- This can fail due to a bad replacement pattern in a regular expression alias.+journalApplyAliases :: [AccountAlias] -> Journal -> Either RegexError Journal+-- short circuit the common case, just in case there's a performance impact from txnTieKnot etc.+journalApplyAliases [] j = Right j+journalApplyAliases aliases j = +  case mapM (transactionApplyAliases aliases) $ jtxns j of+    Right ts -> Right j{jtxns = ts}+    Left err -> Left err++-- -- | Build a database of market prices in effect on the given date,+-- -- from the journal's price directives.+-- journalPrices :: Day -> Journal -> Prices+-- journalPrices d = toPrices d . jpricedirectives++-- -- | Render a market price as a P directive.+-- showPriceDirectiveDirective :: PriceDirective -> String+-- showPriceDirectiveDirective pd = unwords+--     [ "P"+--     , showDate (pddate pd)+--     , T.unpack (pdcommodity pd)+--     , (showAmount . amountSetPrecision maxprecision) (pdamount pd+--     )+--     ]++-- debug helpers+-- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a+-- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps++-- tests+--+-- A sample journal for testing, similar to examples/sample.journal.+-- Provide an option to either use explicit amounts or missing amounts, for testing purposes.+--+-- 2008/01/01 income+--     assets:bank:checking  $1+--     income:salary+--+-- 2008/06/01 gift+--     assets:bank:checking  $1+--     income:gifts+--+-- 2008/06/02 save+--     assets:bank:saving  $1+--     assets:bank:checking+--+-- 2008/06/03 * eat & shop+--     expenses:food      $1+--     expenses:supplies  $1+--     assets:cash+--+-- 2008/10/01 take a loan+--     assets:bank:checking $1+--     liabilities:debts    $-1+--+-- 2008/12/31 * pay off+--     liabilities:debts  $1+--     assets:bank:checking++samplejournal = samplejournalMaybeExplicit True++samplejournalMaybeExplicit :: Bool -> Journal+samplejournalMaybeExplicit explicit = nulljournal+         {jtxns = [+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 01 01,+             tdate2=Nothing,+             tstatus=Unmarked,+             tcode="",+             tdescription="income",+             tcomment="",+             ttags=[],+             tpostings=+                 ["assets:bank:checking" `post` usd 1+                 ,"income:salary" `post` if explicit then usd (-1) else missingamt+                 ],+             tprecedingcomment=""+           }+          ,+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 06 01,+             tdate2=Nothing,+             tstatus=Unmarked,+             tcode="",+             tdescription="gift",+             tcomment="",+             ttags=[],+             tpostings=+                 ["assets:bank:checking" `post` usd 1+                 ,"income:gifts" `post` if explicit then usd (-1) else missingamt+                 ],+             tprecedingcomment=""+           }+          ,+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 06 02,+             tdate2=Nothing,+             tstatus=Unmarked,+             tcode="",+             tdescription="save",+             tcomment="",+             ttags=[],+             tpostings=+                 ["assets:bank:saving" `post` usd 1+                 ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt+                 ],+             tprecedingcomment=""+           }+          ,+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 06 03,+             tdate2=Nothing,+             tstatus=Cleared,+             tcode="",+             tdescription="eat & shop",+             tcomment="",+             ttags=[],+             tpostings=["expenses:food" `post` usd 1+                       ,"expenses:supplies" `post` usd 1+                       ,"assets:cash" `post` if explicit then usd (-2) else missingamt+                       ],+             tprecedingcomment=""+           }+          ,+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 10 01,+             tdate2=Nothing,+             tstatus=Unmarked,+             tcode="",+             tdescription="take a loan",+             tcomment="",+             ttags=[],+             tpostings=["assets:bank:checking" `post` usd 1+                       ,"liabilities:debts" `post` usd (-1)+                       ],+             tprecedingcomment=""+           }+          ,+           txnTieKnot $ Transaction {+             tindex=0,+             tsourcepos=nullsourcepospair,+             tdate=fromGregorian 2008 12 31,+             tdate2=Nothing,+             tstatus=Unmarked,+             tcode="",+             tdescription="pay off",+             tcomment="",+             ttags=[],+             tpostings=["liabilities:debts" `post` usd 1+                       ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt+                       ],+             tprecedingcomment=""+           }+          ]+         }++tests_Journal = testGroup "Journal" [++   testCase "journalDateSpan" $+    journalDateSpan True nulljournal{+      jtxns = [nulltransaction{tdate = fromGregorian 2014 02 01+                              ,tpostings = [posting{pdate=Just (fromGregorian 2014 01 10)}]+                              }+              ,nulltransaction{tdate = fromGregorian 2014 09 01+                              ,tpostings = [posting{pdate2=Just (fromGregorian 2014 10 10)}]+                              }+              ]+      }+    @?= (DateSpan (Just $ Exact $ fromGregorian 2014 1 10) (Just $ Exact $ fromGregorian 2014 10 11))   ]
+ Hledger/Data/JournalChecks.hs view
@@ -0,0 +1,332 @@+{-|+Various additional validation checks that can be performed on a Journal.+Some are called as part of reading a file in strict mode,+others can be called only via the check command.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}++module Hledger.Data.JournalChecks (+  journalStrictChecks,+  journalCheckAccounts,+  journalCheckBalanceAssertions,+  journalCheckCommodities,+  journalCheckPayees,+  journalCheckPairedConversionPostings,+  journalCheckRecentAssertions,+  journalCheckTags,+  module Hledger.Data.JournalChecks.Ordereddates,+  module Hledger.Data.JournalChecks.Uniqueleafnames,+)+where++import Data.Char (isSpace)+import Data.List.Extra+import Data.Maybe+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Safe (atMay, lastMay, headMay)+import Text.Printf (printf)++import Hledger.Data.Errors+import Hledger.Data.Journal+import Hledger.Data.JournalChecks.Ordereddates+import Hledger.Data.JournalChecks.Uniqueleafnames+import Hledger.Data.Posting (isVirtual, postingDate, transactionAllTags, conversionPostingTagName, costPostingTagName, postingAsLines, generatedPostingTagName, generatedTransactionTagName, modifiedTransactionTagName)+import Hledger.Data.Types+import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt, oneLineFmt, showMixedAmountWith)+import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart, partitionAndCheckConversionPostings)+import Data.Time (diffDays)+import Hledger.Utils+import Data.Ord+import Hledger.Data.Dates (showDate)+import Hledger.Data.Balancing (journalBalanceTransactions, defbalancingopts)++-- | Run the extra -s/--strict checks on a journal, in order of priority,+-- returning the first error message if any of them fail.+journalStrictChecks :: Journal -> Either String ()+journalStrictChecks j = do+  -- keep the order of checks here synced with Check.md and Hledger.Cli.Commands.Check.Check.+  -- balanced is checked earlier, in journalFinalise+  journalCheckCommodities j+  journalCheckAccounts j++-- | Check that all the journal's postings are to accounts  with+-- account directives, returning an error message otherwise.+journalCheckAccounts :: Journal -> Either String ()+journalCheckAccounts j = mapM_ checkacct (journalPostings j)+  where+    checkacct p@Posting{paccount=a}+      | a `elem` journalAccountNamesDeclared j = Right ()+      | otherwise = Left $ printf (unlines [+           "%s:%d:"+          ,"%s"+          ,"Strict account checking is enabled, and"+          ,"account \"%s\" has not been declared."+          ,"Consider adding an account directive. Examples:"+          ,""+          ,"account %s"+          ]) f l ex a a+        where+          (f,l,_mcols,ex) = makePostingAccountErrorExcerpt p++-- | Check all balance assertions in the journal and return an error message if any of them fail.+-- (Technically, this also tries to balance the journal and can return balancing failure errors;+-- ensure the journal is already balanced (with journalBalanceTransactions) to avoid this.)+journalCheckBalanceAssertions :: Journal -> Either String ()+journalCheckBalanceAssertions = fmap (const ()) . journalBalanceTransactions defbalancingopts++-- | Check that all the commodities used in this journal's postings and P directives+-- have been declared by commodity directives, returning an error message otherwise.+journalCheckCommodities :: Journal -> Either String ()+journalCheckCommodities j = do+  mapM_ checkPriceDirectiveCommodities $ jpricedirectives j+  mapM_ checkPostingCommodities $ journalPostings j+  where+    firstUndeclaredOf comms = find (`M.notMember` jdeclaredcommodities j) comms++    errmsg = unlines [+        "%s:%d:"+      ,"%s"+      ,"Strict commodity checking is enabled, and"+      ,"commodity %s has not been declared."+      ,"Consider adding a commodity directive. Examples:"+      ,""+      ,"commodity %s1000.00"+      ,"commodity 1.000,00 %s"+      ]++    checkPriceDirectiveCommodities pd@PriceDirective{pdcommodity=c, pdamount=amt} =+      case firstUndeclaredOf [c, acommodity amt] of+        Nothing   -> Right ()+        Just comm -> Left $ printf errmsg f l ex (show comm) comm comm+          where (f,l,_mcols,ex) = makePriceDirectiveErrorExcerpt pd Nothing++    checkPostingCommodities p =+      case firstundeclaredcomm p of+        Nothing                    -> Right ()+        Just (comm, _inpostingamt) -> Left $ printf errmsg f l ex (show comm) comm comm+          where+            (f,l,_mcols,ex) = makePostingErrorExcerpt p finderrcols+      where+        -- Find the first undeclared commodity symbol in this posting's amount or balance assertion amount, if any.+        -- and whether it was in the posting amount.+        -- XXX The latter is currently unused, could be used to refine the error highlighting ?+        firstundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool)+        firstundeclaredcomm Posting{pamount=amt,pbalanceassertion} =+          case (firstUndeclaredOf postingcomms, firstUndeclaredOf assertioncomms) of+            (Just c, _) -> Just (c, True)+            (_, Just c) -> Just (c, False)+            _           -> Nothing+          where+            assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]+            postingcomms = map acommodity $ filter (not . isIgnorable) $ amountsRaw amt+              where+                isIgnorable a = a==missingamt || (amountIsZero a && T.null (acommodity a))  -- #1767++        -- Calculate columns suitable for highlighting the excerpt.+        -- We won't show these in the main error line as they aren't+        -- accurate for the actual data.++        -- Find the best position for an error column marker when this posting+        -- is rendered by showTransaction.+        -- Reliably locating a problem commodity symbol in showTransaction output+        -- is really tricky. Some examples:+        --+        --     assets      "C $" -1 @ $ 2+        --                            ^+        --     assets      $1 = $$1+        --                      ^+        --     assets   [ANSI RED]$-1[ANSI RESET]+        --              ^+        --+        -- To simplify, we will mark the whole amount + balance assertion region, like:+        --     assets      "C $" -1 @ $ 2+        --                 ^^^^^^^^^^^^^^+        -- XXX refine this region when it's easy+        finderrcols p' t txntxt =+          case transactionFindPostingIndex (==p') t of+            Nothing     -> Nothing+            Just pindex -> Just (amtstart, Just amtend)+              where+                tcommentlines = max 0 (length (T.lines $ tcomment t) - 1)+                errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines+                errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1))+                acctend = 4 + T.length (paccount p') + if isVirtual p' then 2 else 0+                amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1+                amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline)++-- | Check that all the journal's transactions have payees declared with+-- payee directives, returning an error message otherwise.+journalCheckPayees :: Journal -> Either String ()+journalCheckPayees j = mapM_ checkpayee (jtxns j)+  where+    checkpayee t+      | payee `elem` journalPayeesDeclared j = Right ()+      | otherwise = Left $+        printf (unlines [+           "%s:%d:"+          ,"%s"+          ,"Strict payee checking is enabled, and"+          ,"payee %s has not been declared."+          ,"Consider adding a payee directive. Examples:"+          ,""+          ,"payee %s"+          ]) f l ex (show payee) payee+      where+        payee = transactionPayee t+        (f,l,_mcols,ex) = makeTransactionErrorExcerpt t finderrcols+        -- Calculate columns suitable for highlighting the excerpt.+        -- We won't show these in the main error line as they aren't+        -- accurate for the actual data.+        finderrcols t' = Just (col, Just col2)+          where+            col  = T.length (showTransactionLineFirstPart t') + 2+            col2 = col + T.length (transactionPayee t') - 1++-- | Check that all the journal's tags (on accounts, transactions, postings..)+-- have been declared with tag directives, returning an error message otherwise.+journalCheckTags :: Journal -> Either String ()+journalCheckTags j = do+  mapM_ checkaccttags $ jdeclaredaccounts j+  mapM_ checktxntags  $ jtxns j+  where+    checkaccttags (a, adi) = mapM_ (checkaccttag.fst) $ aditags adi+      where+        checkaccttag tagname+          | tagname `elem` declaredtags = Right ()+          | otherwise = Left $ printf msg f l ex (show tagname) tagname+            where (f,l,_mcols,ex) = makeAccountTagErrorExcerpt (a, adi) tagname+    checktxntags txn = mapM_ (checktxntag . fst) $ transactionAllTags txn+      where+        checktxntag tagname+          | tagname `elem` declaredtags = Right ()+          | otherwise = Left $ printf msg f l ex (show tagname) tagname+            where+              (f,l,_mcols,ex) = makeTransactionErrorExcerpt txn finderrcols+                where+                  finderrcols _txn' = Nothing+                    -- don't bother for now+                    -- Just (col, Just col2)+                    -- where+                    --   col  = T.length (showTransactionLineFirstPart txn') + 2+                    --   col2 = col + T.length tagname - 1+    declaredtags = journalTagsDeclared j ++ builtinTags+    msg = (unlines [+      "%s:%d:"+      ,"%s"+      ,"Strict tag checking is enabled, and"+      ,"tag %s has not been declared."+      ,"Consider adding a tag directive. Examples:"+      ,""+      ,"tag %s"+      ])++-- | Tag names which have special significance to hledger, and need not be declared for `hledger check tags`.+-- Keep synced with check-tags.test and hledger manual > Special tags.+builtinTags = [+   "date"                   -- overrides a posting's date+  ,"date2"                  -- overrides a posting's secondary date+  ,"type"                   -- declares an account's type+  ,"t"                      -- appears on postings generated by timedot letters+  ,"assert"                 -- appears on txns generated by close --assert+  ,"retain"                 -- appears on txns generated by close --retain+  ,"start"                  -- appears on txns generated by close --migrate/--close/--open/--assign+  ]+  -- these tags are used in both hidden and visible form+  <> ts <> map toVisibleTagName ts+  where+    ts = [+       generatedTransactionTagName -- marks txns generated by periodic rule+      ,modifiedTransactionTagName  -- marks txns which have had auto postings added+      ,generatedPostingTagName     -- marks postings which have been generated+      ,costPostingTagName          -- marks equity conversion postings which have been matched with a nearby costful posting+      ,conversionPostingTagName    -- marks costful postings which have been matched with a nearby pair of equity conversion postings+      ]++-- | In each tranaction, check that any conversion postings occur in adjacent pairs.+journalCheckPairedConversionPostings :: Journal -> Either String ()+journalCheckPairedConversionPostings j =+  mapM_ (transactionCheckPairedConversionPostings conversionaccts) $ jtxns j+  where conversionaccts = journalConversionAccounts j++transactionCheckPairedConversionPostings :: [AccountName] -> Transaction -> Either String ()+transactionCheckPairedConversionPostings conversionaccts t =+  case partitionAndCheckConversionPostings True conversionaccts (zip [0..] $ tpostings t) of+    Left err -> Left $ T.unpack err+    Right _  -> Right ()++----------++-- | The number of days allowed between an account's latest balance assertion +-- and latest posting (7).+maxlag = 7++-- | Check that accounts with balance assertions have no posting more+-- than maxlag days after their latest balance assertion.+journalCheckRecentAssertions :: Journal -> Either String ()+journalCheckRecentAssertions j =+  let acctps = groupOn paccount $ sortOn paccount $ journalPostings j+  in case mapMaybe findRecentAssertionError acctps of+    []         -> Right ()+    firsterr:_ -> Left firsterr++-- | Do the recentassertions check for one account: given a list of postings to the account,+-- if any of them contain a balance assertion, identify the latest balance assertion,+-- and if any postings are >maxlag days later than the assertion,+-- return an error message identifying the first of them.+-- Postings on the same date will be handled in parse order (hopefully).+findRecentAssertionError :: [Posting] -> Maybe String+findRecentAssertionError ps = do+  let rps = sortOn (Data.Ord.Down . postingDate) ps+  let (afterlatestassertrps, untillatestassertrps) = span (isNothing.pbalanceassertion) rps+  latestassertdate <- postingDate <$> headMay untillatestassertrps+  let withinlimit date = diffDays date latestassertdate <= maxlag+  firsterrorp <- lastMay $ dropWhileEnd (withinlimit.postingDate) afterlatestassertrps+  let lag = diffDays (postingDate firsterrorp) latestassertdate+  let acct = paccount firsterrorp+  let (f,l,_mcols,ex) = makePostingAccountErrorExcerpt firsterrorp+  -- let comm =+  --       case map acommodity $ amounts $ pamount firsterrorp of+  --         [] -> ""+  --         (t:_) | T.length t == 1 -> t+  --         (t:_) -> t <> " "+  Just $ chomp $ printf+    (unlines [+      "%s:%d:",+      "%s\n",+      -- "The recentassertions check is enabled, so accounts with balance assertions must",+      -- "have a balance assertion within %d days of their latest posting.",+      "The recentassertions check is enabled, so accounts with balance assertions",+      "must have a recent one, not more than %d days older than their latest posting.",+      "In account: %s",+      "the last assertion was on %s, %d days before this latest posting.",+      "Consider adding a new balance assertion to the above posting. Eg:",+      "",+      "%s = BALANCE"+      ])+    f+    l+    (textChomp ex)+    maxlag+    (bold' $ T.unpack acct)+    (showDate latestassertdate)+    lag+    (showposting firsterrorp)+    where+      showposting p =+        headDef "" $ first3 $ postingAsLines False True acctw amtw p{pcomment=""}+        where+          acctw = T.length $ paccount p+          amtw  = length $ showMixedAmountWith oneLineFmt $ pamount p++-- -- | Print the last balance assertion date & status of all accounts with balance assertions.+-- printAccountLastAssertions :: Day -> [BalanceAssertionInfo] -> IO ()+-- printAccountLastAssertions today acctassertioninfos = do+--   forM_ acctassertioninfos $ \BAI{..} -> do+--     putStr $ printf "%-30s  %s %s, %d days ago\n"+--       baiAccount+--       (if baiLatestClearedAssertionStatus==Unmarked then " " else show baiLatestClearedAssertionStatus)+--       (show baiLatestClearedAssertionDate)+--       (diffDays today baiLatestClearedAssertionDate)
+ Hledger/Data/JournalChecks/Ordereddates.hs view
@@ -0,0 +1,60 @@+module Hledger.Data.JournalChecks.Ordereddates (+  journalCheckOrdereddates+)+where++import Control.Monad (forM)+import Data.List (groupBy)+import Text.Printf (printf)+import Data.Text qualified as T (pack, unlines)++import Hledger.Data.Errors (makeTransactionErrorExcerpt)+import Hledger.Data.Transaction (transactionFile)+import Hledger.Data.Types+import Hledger.Utils (textChomp)++journalCheckOrdereddates :: Journal -> Either String ()+journalCheckOrdereddates j = do+  let+    -- we check date ordering within each file, not across files+    -- note, relying on txns always being sorted by file here+    txnsbyfile = groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ jtxns j+    compare' a b = tdate a <= tdate b+  (const $ Right ()) =<< (forM txnsbyfile $ \ts ->+    case checkTransactions compare' ts of+      FoldAcc{fa_previous=Nothing} -> Right ()+      FoldAcc{fa_error=Nothing}    -> Right ()+      FoldAcc{fa_error=Just t, fa_previous=Just tprev} -> Left $ printf+        ("%s:%d:\n%s\nOrdered dates checking is enabled, and this transaction's\n"+          ++ "date (%s) is out of order with the previous transaction.\n"+          ++ "Consider moving this entry into date order, or adjusting its date.")+        f l ex (show $ tdate t)+        where+          (_,_,_,ex1) = makeTransactionErrorExcerpt tprev (const Nothing)+          (f,l,_,ex2) = makeTransactionErrorExcerpt t finderrcols+          -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them+          ex = T.unlines [textChomp ex1, T.pack " ", textChomp ex2]+          finderrcols _t = Just (1, Just 10)+    )++data FoldAcc a b = FoldAcc+ { fa_error    :: Maybe a+ , fa_previous :: Maybe b+ }++checkTransactions :: (Transaction -> Transaction -> Bool)+  -> [Transaction] -> FoldAcc Transaction Transaction+checkTransactions compare' = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}+  where+    f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}+    f current acc@FoldAcc{fa_previous=Just previous} =+      if compare' previous current+      then acc{fa_previous=Just current}+      else acc{fa_error=Just current}++foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b+foldWhile _ acc [] = acc+foldWhile fold acc (a:as) =+  case fold a acc of+   acc'@FoldAcc{fa_error=Just _} -> acc'+   acc' -> foldWhile fold acc' as
+ Hledger/Data/JournalChecks/Uniqueleafnames.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.JournalChecks.Uniqueleafnames (+  journalCheckUniqueleafnames+)+where++import Data.Function (on)+import Data.List (groupBy, sortBy)+import Data.Text (Text)+import Data.Text qualified as T+import Safe (headErr)+import Text.Printf (printf)++import Hledger.Data.AccountName (accountLeafName)+import Hledger.Data.Errors (makePostingErrorExcerpt)+import Hledger.Data.Journal (journalPostings, journalAccountNamesUsed)+import Hledger.Data.Posting (isVirtual)+import Hledger.Data.Types+import Hledger.Utils (chomp, textChomp)++-- | Check that all the journal's postings are to accounts with a unique leaf name.+-- Otherwise, return an error message for the first offending posting.+journalCheckUniqueleafnames :: Journal -> Either String ()+journalCheckUniqueleafnames j = do+  -- find all duplicate leafnames, and the full account names they appear in+  case finddupes $ journalLeafAndFullAccountNames j of+    [] -> Right ()+    -- pick the first duplicated leafname and show the transactions of+    -- the first two postings using it, highlighting the second as the error.+    (leaf,fulls):_ ->+      case filter ((`elem` fulls).paccount) $ journalPostings j of+        ps@(p:p2:_) -> Left $ chomp $ printf+          ("%s:%d:\n%s\nChecking for unique account leaf names is enabled, and\n"+          ++"account leaf name %s is not unique.\n"+          ++"It appears in these account names, which are used in %d places:\n%s"+          ++"\nConsider changing these account names so their last parts are different."+          )+          f l ex (show leaf) (length ps) accts+          where+            -- t = fromMaybe nulltransaction ptransaction  -- XXX sloppy+            (_,_,_,ex1) = makePostingErrorExcerpt p (\_ _ _ -> Nothing)+            (f,l,_,ex2) = makePostingErrorExcerpt p2 finderrcols+            -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them+            ex = T.unlines [textChomp ex1, T.pack " ...", textChomp ex2]+            finderrcols p' _ _ = Just (col, Just col2)+              where+                a = paccount p'+                alen = T.length a+                llen = T.length $ accountLeafName a+                col = 5 + (if isVirtual p' then 1 else 0) + alen - llen+                col2 = col + llen - 1+            accts = T.unlines fulls++        _ -> Right ()  -- shouldn't happen++finddupes :: (Ord leaf, Eq full) => [(leaf, full)] -> [(leaf, [full])]+finddupes leafandfullnames = zip dupLeafs dupAccountNames+  where+    dupAccountNames = map (map snd) dupes+    dupLeafs = case dupes of+      [] -> []+      _  -> map (fst . headErr) dupes  -- PARTIAL headErr succeeds because of pattern+    dupes = fnddupes leafandfullnames+      where+        fnddupes = filter ((> 1) . length)+          . groupBy ((==) `on` fst)+          . sortBy (compare `on` fst)++journalLeafAndFullAccountNames :: Journal -> [(Text, AccountName)]+journalLeafAndFullAccountNames = map leafAndAccountName . journalAccountNamesUsed+  where leafAndAccountName a = (accountLeafName a, a)
+ Hledger/Data/Json.hs view
@@ -0,0 +1,313 @@+{-+JSON instances. Should they be in Types.hs ?+-}++{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Hledger.Data.Json (+  -- * Instances+  -- * Utilities+   toJsonText+  ,writeJsonFile+  ,readJsonFile+) where++import           Data.Aeson+import           Data.Aeson.Encode.Pretty (Config(..), Indent(..), NumberFormat(..),+                     encodePretty', encodePrettyToTextBuilder')+--import           Data.Aeson.TH+import Data.ByteString.Lazy qualified as BL+import           Data.Decimal (DecimalRaw(..), roundTo)+import           Data.Maybe (fromMaybe)+import Data.Text.Lazy qualified    as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Map qualified as M+import           Text.Megaparsec (Pos, SourcePos, mkPos, unPos)++import           Hledger.Data.Types+import           Hledger.Utils.IO (error')+import           Hledger.Data.Amount (amountsRaw, mixed)++-- To JSON++instance ToJSON Status+instance ToJSON SourcePos++-- Use the same encoding as the underlying Int+instance ToJSON Pos where+  toJSON = toJSON . unPos+  toEncoding = toEncoding . unPos++-- https://github.com/simonmichael/hledger/issues/1195++-- The default JSON output for Decimal can contain 255-digit integers+-- (for repeating decimals caused by implicit transaction prices).+-- JSON output is intended to be consumed by diverse apps and+-- programming languages, which can't handle numbers like that.+-- From #1195:+--+-- > - JavaScript uses 64-bit IEEE754 numbers which can only accurately+-- >   represent integers up to 9007199254740991 (i.e. a maximum of 15 digits).+-- > - Java’s largest integers are limited to 18 digits.+-- > - Python 3 integers are unbounded.+-- > - Python 2 integers are limited to 18 digits like Java.+-- > - C and C++ number limits depend on platform — most platforms should+-- >   be able to represent unsigned integers up to 64 bits, i.e. 19 digits.+--+-- What is the best compromise for both accuracy and practicality ?+-- For now, we provide both the maximum precision representation+-- (decimalPlaces & decimalMantissa), and a floating point representation+-- with up to 10 decimal places (and an unbounded number of integer digits).+-- We hope the mere presence of the large number in JSON won't break things,+-- and that the overall number of significant digits in the floating point+-- remains manageable in practice. (I'm not sure how to limit the number+-- of significant digits in a Decimal right now.)+instance (Integral a, ToJSON a) => ToJSON (DecimalRaw a) where+  toJSON = object . decimalKV+  toEncoding = pairs . mconcat . decimalKV++decimalKV :: (+#if MIN_VERSION_aeson(2,2,0)+  KeyValue e kv,+#else+  KeyValue kv,+#endif+  Integral a, ToJSON a) => DecimalRaw a -> [kv]+decimalKV d = let d' = if decimalPlaces d <= 10 then d else roundTo 10 d in+    [ "decimalPlaces"   .= decimalPlaces d'+    , "decimalMantissa" .= decimalMantissa d'+    , "floatingPoint"   .= (realToFrac d' :: Double)+    ]++instance ToJSON CostBasis+instance ToJSON Amount+instance ToJSON Rounding+instance ToJSON AmountStyle++-- Use the same JSON serialisation as Maybe Word8+instance ToJSON AmountPrecision where+  toJSON = toJSON . \case+    Precision n      -> Just n+    NaturalPrecision -> Nothing+  toEncoding = toEncoding . \case+    Precision n      -> Just n+    NaturalPrecision -> Nothing++instance ToJSON Side+instance ToJSON DigitGroupStyle++instance ToJSON MixedAmount where+  toJSON = toJSON . amountsRaw+  toEncoding = toEncoding . amountsRaw++instance ToJSON BalanceAssertion+instance ToJSON AmountCost+instance ToJSON MarketPrice+instance ToJSON PostingType++instance ToJSON Posting where+  toJSON = object . postingKV+  toEncoding = pairs . mconcat . postingKV++postingKV ::+#if MIN_VERSION_aeson(2,2,0)+  KeyValue e kv+#else+  KeyValue kv+#endif+  => Posting -> [kv]+postingKV Posting{..} =+    [ "pdate"             .= pdate+    , "pdate2"            .= pdate2+    , "pstatus"           .= pstatus+    , "paccount"          .= paccount+    , "pamount"           .= pamount+    , "pcomment"          .= pcomment+    , "ptype"             .= ptype+    , "ptags"             .= ptags+    , "pbalanceassertion" .= pbalanceassertion+    -- To avoid a cycle, show just the parent transaction's index number+    -- in a dummy field. When re-parsed, there will be no parent.+    , "ptransaction_"     .= maybe "" (show.tindex) ptransaction+    -- This is probably not wanted in json, we discard it.+    , "poriginal"         .= (Nothing :: Maybe Posting)+    ]++instance ToJSON Transaction+instance ToJSON TransactionModifier+instance ToJSON TMPostingRule+instance ToJSON PeriodicTransaction+instance ToJSON PriceDirective+instance ToJSON EFDay+instance ToJSON DateSpan+instance ToJSON Interval+instance ToJSON Period+instance ToJSON AccountAlias+instance ToJSON AccountType+instance ToJSONKey AccountType+instance ToJSON AccountDeclarationInfo+instance ToJSON PayeeDeclarationInfo+instance ToJSON TagDeclarationInfo+instance ToJSON Commodity+instance ToJSON TimeclockCode+instance ToJSON TimeclockEntry+instance ToJSON Journal++instance ToJSON BalanceData+instance ToJSON a => ToJSON (PeriodData a) where+  toJSON a = object+    [ "pdpre" .= pdpre a+    , "pdperiods" .= (M.toList $ pdperiods a)+    ]++instance ToJSON a => ToJSON (Account a) where+  toJSON = object . accountKV+  toEncoding = pairs . mconcat . accountKV++accountKV ::+#if MIN_VERSION_aeson(2,2,0)+  (KeyValue e kv, ToJSON a)+#else+  (KeyValue kv, ToJSON a)+#endif+  => Account a -> [kv]+accountKV a =+    [ "aname"            .= aname a+    , "adeclarationinfo" .= adeclarationinfo a+    -- To avoid a cycle, show just the parent account's name+    -- in a dummy field. When re-parsed, there will be no parent.+    , "aparent_"         .= maybe "" aname (aparent a)+    -- Just the names of subaccounts, as a dummy field, ignored when parsed.+    , "asubs_"           .= map aname (asubs a)+    -- The actual subaccounts (and their subs..), making a (probably highly redundant) tree+    -- ,"asubs"        .= asubs a+    -- Omit the actual subaccounts+    , "asubs"            .= ([]::[Account BalanceData])+    , "aboring"          .= aboring a+    , "adata"            .= adata a+    ]++instance ToJSON Ledger++-- From JSON++instance FromJSON Status+instance FromJSON SourcePos+-- Use the same encoding as the underlying Int+instance FromJSON Pos where+  parseJSON = fmap mkPos . parseJSON++instance FromJSON CostBasis+instance FromJSON Amount+instance FromJSON Rounding+instance FromJSON AmountStyle++-- Use the same JSON serialisation as Maybe Word8+instance FromJSON AmountPrecision where+  parseJSON = fmap (maybe NaturalPrecision Precision) . parseJSON++instance FromJSON Side+instance FromJSON DigitGroupStyle++instance FromJSON MixedAmount where+  parseJSON = fmap (mixed :: [Amount] -> MixedAmount) . parseJSON++instance FromJSON BalanceAssertion+instance FromJSON AmountCost+instance FromJSON MarketPrice+instance FromJSON PostingType+instance FromJSON Posting+instance FromJSON Transaction+instance FromJSON AccountDeclarationInfo++instance FromJSON BalanceData+instance FromJSON a => FromJSON (PeriodData a) where+  parseJSON = withObject "PeriodData" $ \v -> PeriodData+    <$> v .: "pdpre"+    <*> (M.fromList <$> v .: "pdperiods")++-- XXX The ToJSON instance replaces subaccounts with just names.+-- Here we should try to make use of those to reconstruct the+-- parent-child relationships.+instance FromJSON a => FromJSON (Account a)++-- Decimal, various attempts+--+-- https://stackoverflow.com/questions/40331851/haskell-data-decimal-as-aeson-type+----instance FromJSON Decimal where parseJSON =+----  A.withScientific "Decimal" (return . right . eitherFromRational . toRational)+--+-- https://github.com/bos/aeson/issues/474+-- http://hackage.haskell.org/package/aeson-1.4.2.0/docs/Data-Aeson-TH.html+-- $(deriveFromJSON defaultOptions ''Decimal) -- doesn't work+-- $(deriveFromJSON defaultOptions ''DecimalRaw)  -- works; requires TH, but gives better parse error messages+--+-- https://github.com/PaulJohnson/Haskell-Decimal/issues/6+instance FromJSON (DecimalRaw Integer)+--+-- @simonmichael, I think the code in your first comment should work if it compiles—though “work” doesn’t mean you can parse a JSON number directly into a `Decimal` using the generic instance, as you’ve discovered.+--+--Error messages with these extensions are always rather cryptic, but I’d prefer them to Template Haskell. Typically you’ll want to start by getting a generic `ToJSON` instance working, then use that to figure out what the `FromJSON` instance expects to parse: for a correct instance, `encode` and `decode` should give you an isomorphism between your type and a subset of `Bytestring` (up to the `Maybe` wrapper that `decode` returns).+--+--I don’t have time to test it right now, but I think it will also work without `DeriveAnyClass`, just using `DeriveGeneric` and `StandAloneDeriving`. It should also work to use the [`genericParseJSON`](http://hackage.haskell.org/package/aeson/docs/Data-Aeson.html#v:genericParseJSON) function to implement the class explicitly, something like this:+--+--{-# LANGUAGE DeriveGeneric #-}+--{-# LANGUAGE StandAloneDeriving #-}+--import GHC.Generics+--import Data.Aeson+--deriving instance Generic Decimal+--instance FromJSON Decimal where+--  parseJSON = genericParseJSON defaultOptions+--+--And of course you can avoid `StandAloneDeriving` entirely if you’re willing to wrap `Decimal` in your own `newtype`.++-- XXX these will allow reading a Journal, but currently the+-- jdeclaredaccounttypes Map gets serialised as a JSON list, which+-- can't be read back.+--+-- instance FromJSON AccountAlias+-- instance FromJSONKey AccountType where fromJSONKey = genericFromJSONKey defaultJSONKeyOptions+-- instance FromJSON AccountType+-- instance FromJSON ClockTime+-- instance FromJSON Commodity+-- instance FromJSON DateSpan+-- instance FromJSON Interval+-- instance FromJSON Period+-- instance FromJSON PeriodicTransaction+-- instance FromJSON PriceDirective+-- instance FromJSON TimeclockCode+-- instance FromJSON TimeclockEntry+-- instance FromJSON TransactionModifier+-- instance FromJSON Journal+++-- Utilities++-- | Config for pretty printing JSON output.+jsonConf :: Config+jsonConf = Config{confIndent=Spaces 2, confCompare=compare, confNumFormat=Generic, confTrailingNewline=True}++-- | Show a JSON-convertible haskell value as pretty-printed JSON text.+toJsonText :: ToJSON a => a -> TL.Text+toJsonText = TB.toLazyText . encodePrettyToTextBuilder' jsonConf++-- | Write a JSON-convertible haskell value to a pretty-printed JSON file.+-- Eg: writeJsonFile "a.json" nulltransaction+writeJsonFile :: ToJSON a => FilePath -> a -> IO ()+writeJsonFile f = BL.writeFile f . encodePretty' jsonConf++-- | Read a JSON file and decode it to the target type, or raise an error if we can't.+-- Eg: readJsonFile "a.json" :: IO Transaction+readJsonFile :: FromJSON a => FilePath -> IO a+readJsonFile f = do+  bl <- BL.readFile f+  -- PARTIAL:+  let v = fromMaybe (error' $ "could not decode JSON in "++show f++" to target value")+          (decode bl :: Maybe Value)+  case fromJSON v :: FromJSON a => Result a of+    Error e   -> error' e+    Success t -> return t
Hledger/Data/Ledger.hs view
@@ -17,7 +17,6 @@   ,ledgerRootAccount   ,ledgerTopAccounts   ,ledgerLeafAccounts-  ,ledgerAccountsMatching   ,ledgerPostings   ,ledgerDateSpan   ,ledgerCommodities@@ -25,17 +24,16 @@ ) where -import qualified Data.Map as M--- import Data.Text (Text)-import qualified Data.Text as T+import Data.Map qualified as M import Safe (headDef) import Text.Printf -import Hledger.Utils.Test +import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase) import Hledger.Data.Types import Hledger.Data.Account+import Hledger.Data.Dates (nulldate) import Hledger.Data.Journal-import Hledger.Data.Posting import Hledger.Query  @@ -53,17 +51,19 @@   laccounts = []   } --- | Filter a journal's transactions with the given query, then derive--- a ledger containing the chart of accounts and balances. If the--- query includes a depth limit, that will affect the ledger's--- journal but not the ledger's account tree.+-- | Filter a journal's transactions with the given query, then build+-- a "Ledger", containing the journal plus the tree of all its+-- accounts with their subaccount-inclusive and subaccount-exclusive+-- balances. If the query includes a depth limit, the ledger's journal+-- will be depth limited, but the ledger's account tree will not. ledgerFromJournal :: Query -> Journal -> Ledger ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as}   where     (q',depthq)  = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q)     j'  = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude           filterJournalPostings q' j-    as  = accountsFromPostings $ journalPostings j'+    -- Ledger does not use date-separated balances, so dates are left empty+    as  = accountsFromPostings (const $ Just nulldate) $ journalPostings j'     j'' = filterJournalPostings depthq j'  -- | List a ledger's account names.@@ -71,27 +71,23 @@ ledgerAccountNames = drop 1 . map aname . laccounts  -- | Get the named account from a ledger.-ledgerAccount :: Ledger -> AccountName -> Maybe Account+ledgerAccount :: Ledger -> AccountName -> Maybe (Account BalanceData) ledgerAccount l a = lookupAccount a $ laccounts l  -- | Get this ledger's root account, which is a dummy "root" account -- above all others. This should always be first in the account list, -- if somehow not this returns a null account.-ledgerRootAccount :: Ledger -> Account+ledgerRootAccount :: Ledger -> Account BalanceData ledgerRootAccount = headDef nullacct . laccounts  -- | List a ledger's top-level accounts (the ones below the root), in tree order.-ledgerTopAccounts :: Ledger -> [Account]-ledgerTopAccounts = asubs . head . laccounts+ledgerTopAccounts :: Ledger -> [Account BalanceData]+ledgerTopAccounts = asubs . headDef nullacct . laccounts  -- | List a ledger's bottom-level (subaccount-less) accounts, in tree order.-ledgerLeafAccounts :: Ledger -> [Account]+ledgerLeafAccounts :: Ledger -> [Account BalanceData] ledgerLeafAccounts = filter (null.asubs) . laccounts --- | Accounts in ledger whose name matches the pattern, in tree order.-ledgerAccountsMatching :: [String] -> Ledger -> [Account]-ledgerAccountsMatching pats = filter (matchpats pats . T.unpack . aname) . laccounts -- XXX pack- -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting] ledgerPostings = journalPostings . ljournal@@ -99,21 +95,18 @@ -- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan-ledgerDateSpan = postingsDateSpan . ledgerPostings+ledgerDateSpan = journalDateSpanBothDates . ljournal  -- | All commodities used in this ledger. ledgerCommodities :: Ledger -> [CommoditySymbol]-ledgerCommodities = M.keys . jinferredcommodities . ljournal+ledgerCommodities = M.keys . jinferredcommoditystyles . ljournal  -- tests  tests_Ledger =-  tests-    "Ledger"-    [ tests-        "ledgerFromJournal"-        [ length (ledgerPostings $ ledgerFromJournal Any nulljournal) `is` 0-        , length (ledgerPostings $ ledgerFromJournal Any samplejournal) `is` 13-        , length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) `is` 7-        ]-    ]+  testGroup "Ledger" [+    testCase "ledgerFromJournal" $ do+        length (ledgerPostings $ ledgerFromJournal Any nulljournal) @?= 0+        length (ledgerPostings $ ledgerFromJournal Any samplejournal) @?= 13+        length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) @?= 7+  ]
− Hledger/Data/MarketPrice.hs 
@@ -1,27 +0,0 @@-{-|--A 'MarketPrice' represents a historical exchange rate between two-commodities. (Ledger calls them historical prices.) For example, prices-published by a stock exchange or the foreign exchange market.  Some-commands (balance, currently) can use this information to show the market-value of things at a given date.---}--module Hledger.Data.MarketPrice-where-import qualified Data.Text as T--import Hledger.Data.Amount-import Hledger.Data.Dates-import Hledger.Data.Types---- | Get the string representation of an market price, based on its--- commodity's display settings.-showMarketPrice :: MarketPrice -> String-showMarketPrice mp = unwords-    [ "P"-    , showDate (mpdate mp)-    , T.unpack (mpcommodity mp)-    , (showAmount . setAmountPrecision maxprecision) (mpamount mp)-    ]
Hledger/Data/Period.hs view
@@ -5,9 +5,37 @@  -} -module Hledger.Data.Period+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.Period (+   periodAsDateSpan+  ,dateSpanAsPeriod+  ,simplifyPeriod+  ,isLastDayOfMonth+  ,isStandardPeriod+  ,periodTextWidth+  ,showPeriod+  ,showPeriodAbbrev+  ,periodStart+  ,periodEnd+  ,periodNext+  ,periodPrevious+  ,periodNextIn+  ,periodPreviousIn+  ,periodMoveTo+  ,periodGrow+  ,periodShrink+  ,mondayBefore+  ,thursdayOfWeekContaining+  ,yearMonthContainingWeekStarting+  ,quarterContainingMonth+  ,firstMonthOfQuarter+  ,startOfFirstWeekInMonth+) where +import Data.Text (Text)+import Data.Text qualified as T import Data.Time.Calendar import Data.Time.Calendar.MonthDay import Data.Time.Calendar.OrdinalDate@@ -17,38 +45,38 @@  import Hledger.Data.Types --- | Convert Periods to DateSpans.+-- | Convert Periods to exact DateSpans. ----- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ Flex $ fromGregorian 2000 1 1) (Just $ Flex $ fromGregorian 2000 2 1) -- True periodAsDateSpan :: Period -> DateSpan-periodAsDateSpan (DayPeriod d) = DateSpan (Just d) (Just $ addDays 1 d)-periodAsDateSpan (WeekPeriod b) = DateSpan (Just b) (Just $ addDays 7 b)-periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+periodAsDateSpan (DayPeriod d) = DateSpan (Just $ Exact d) (Just $ Exact $ addDays 1 d)+periodAsDateSpan (WeekPeriod b) = DateSpan (Just $ Flex b) (Just $ Flex $ addDays 7 b)+periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ Flex $ fromGregorian y m 1) (Just $ Flex $ fromGregorian y' m' 1)   where     (y',m') | m==12     = (y+1,1)             | otherwise = (y,m+1)-periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ Flex $ fromGregorian y m 1) (Just $ Flex $ fromGregorian y' m' 1)   where     (y', q') | q==4      = (y+1,1)              | otherwise = (y,q+1)-    quarterAsMonth q = (q-1) * 3 + 1+    quarterAsMonth q2 = (q2-1) * 3 + 1     m  = quarterAsMonth q     m' = quarterAsMonth q'-periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1)-periodAsDateSpan (PeriodBetween b e) = DateSpan (Just b) (Just e)-periodAsDateSpan (PeriodFrom b) = DateSpan (Just b) Nothing-periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just e)+periodAsDateSpan (YearPeriod y) = DateSpan (Just $ Flex $ fromGregorian y 1 1) (Just $ Flex $ fromGregorian (y+1) 1 1)+periodAsDateSpan (PeriodBetween b e) = DateSpan (Just $ Exact b) (Just $ Exact e)+periodAsDateSpan (PeriodFrom b) = DateSpan (Just $ Exact b) Nothing+periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just $ Exact e) periodAsDateSpan (PeriodAll) = DateSpan Nothing Nothing  -- | Convert DateSpans to Periods. ----- >>> dateSpanAsPeriod $ DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- >>> dateSpanAsPeriod $ DateSpan (Just $ Exact $ fromGregorian 2000 1 1) (Just $ Exact $ fromGregorian 2000 2 1) -- MonthPeriod 2000 1 dateSpanAsPeriod :: DateSpan -> Period-dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween b e-dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom b-dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo e+dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween (fromEFDay b) (fromEFDay e)+dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom (fromEFDay b)+dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo (fromEFDay e) dateSpanAsPeriod (DateSpan Nothing Nothing) = PeriodAll  -- | Convert PeriodBetweens to a more abstract period where possible.@@ -129,35 +157,61 @@     isStandardPeriod' (YearPeriod _) = True     isStandardPeriod' _ = False +-- | The width of a period of this type when displayed.+periodTextWidth :: Period -> Int+periodTextWidth = periodTextWidth' . simplifyPeriod+  where+    periodTextWidth' DayPeriod{}     = 10  -- 2021-01-01+    periodTextWidth' WeekPeriod{}    = 13  -- 2021-01-01W52+    periodTextWidth' MonthPeriod{}   = 7   -- 2021-01+    periodTextWidth' QuarterPeriod{} = 6   -- 2021Q1+    periodTextWidth' YearPeriod{}    = 4   -- 2021+    periodTextWidth' PeriodBetween{} = 22  -- 2021-01-01..2021-01-07+    periodTextWidth' PeriodFrom{}    = 12  -- 2021-01-01..+    periodTextWidth' PeriodTo{}      = 12  -- ..2021-01-01+    periodTextWidth' PeriodAll       = 2   -- ..+ -- | Render a period as a compact display string suitable for user output. -- -- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))--- "2016/07/25w30"-showPeriod (DayPeriod b)       = formatTime defaultTimeLocale "%0C%y/%m/%d" b     -- DATE-showPeriod (WeekPeriod b)      = formatTime defaultTimeLocale "%0C%y/%m/%dw%V" b  -- STARTDATEwYEARWEEK-showPeriod (MonthPeriod y m)   = printf "%04d/%02d" y m                           -- YYYY/MM-showPeriod (QuarterPeriod y q) = printf "%04dq%d" y q                             -- YYYYqN-showPeriod (YearPeriod y)      = printf "%04d" y                                  -- YYYY-showPeriod (PeriodBetween b e) = formatTime defaultTimeLocale "%0C%y/%m/%d" b-                                 ++ formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e) -- STARTDATE-INCLUSIVEENDDATE-showPeriod (PeriodFrom b)      = formatTime defaultTimeLocale "%0C%y/%m/%d-" b                   -- STARTDATE--showPeriod (PeriodTo e)        = formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e)    -- -INCLUSIVEENDDATE-showPeriod PeriodAll           = "-"+-- "2016-W30"+-- >>> showPeriod (WeekPeriod (fromGregorian 2024 12 30))+-- "2025-W01"+showPeriod :: Period -> Text+showPeriod (DayPeriod b)       = T.pack $ formatTime defaultTimeLocale "%F" b              -- DATE+showPeriod (WeekPeriod b)      = T.pack $ y <> "-W" <> w                                   -- YYYY-Www+  where+    y = formatTime defaultTimeLocale "%0Y" $ thursdayOfWeekContaining b  -- be careful at year boundary+    w = formatTime defaultTimeLocale "%V" b+showPeriod (MonthPeriod y m)   = T.pack $ printf "%04d-%02d" y m                           -- YYYY-MM+showPeriod (QuarterPeriod y q) = T.pack $ printf "%04dQ%d" y q                             -- YYYYQN+showPeriod (YearPeriod y)      = T.pack $ printf "%04d" y                                  -- YYYY+showPeriod (PeriodBetween b e) = T.pack $ formatTime defaultTimeLocale "%F" b+                                 ++ formatTime defaultTimeLocale "..%F" (addDays (-1) e) -- STARTDATE..INCLUSIVEENDDATE+showPeriod (PeriodFrom b)      = T.pack $ formatTime defaultTimeLocale "%F.." b                   -- STARTDATE..+showPeriod (PeriodTo e)        = T.pack $ formatTime defaultTimeLocale "..%F" (addDays (-1) e)    -- ..INCLUSIVEENDDATE+showPeriod PeriodAll           = ".." --- | Like showPeriod, but if it's a month period show just --- the 3 letter month name abbreviation for the current locale.-showPeriodMonthAbbrev (MonthPeriod _ m)                           -- Jan-  | m > 0 && m <= length monthnames = snd $ monthnames !! (m-1)+-- | Like showPeriod, but if it's a month or week period show+-- an abbreviated form.+-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2016 7 25))+-- "W30"+-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2024 12 30))+-- "W01"+showPeriodAbbrev :: Period -> Text+showPeriodAbbrev (MonthPeriod _ m)                                              -- Jan+  | m > 0 && m <= length monthnames = T.pack . snd $ monthnames !! (m-1)   where monthnames = months defaultTimeLocale-showPeriodMonthAbbrev p = showPeriod p+showPeriodAbbrev (WeekPeriod b) = T.pack $ formatTime defaultTimeLocale "W%V" b -- Www+showPeriodAbbrev p = showPeriod p  periodStart :: Period -> Maybe Day-periodStart p = mb+periodStart p = fromEFDay <$> mb   where     DateSpan mb _ = periodAsDateSpan p  periodEnd :: Period -> Maybe Day-periodEnd p = me+periodEnd p = fromEFDay <$> me   where     DateSpan _ me = periodAsDateSpan p @@ -188,11 +242,12 @@ -- | Move a standard period to the following period of same duration, staying within enclosing dates. -- Non-standard periods are unaffected. periodNextIn :: DateSpan -> Period -> Period-periodNextIn (DateSpan _ (Just e)) p =+periodNextIn (DateSpan _ (Just e0)) p =   case mb of     Just b -> if b < e then p' else p     _      -> p   where+    e = fromEFDay e0     p' = periodNext p     mb = periodStart p' periodNextIn _ p = periodNext p@@ -200,11 +255,12 @@ -- | Move a standard period to the preceding period of same duration, staying within enclosing dates. -- Non-standard periods are unaffected. periodPreviousIn :: DateSpan -> Period -> Period-periodPreviousIn (DateSpan (Just b) _) p =+periodPreviousIn (DateSpan (Just b0) _) p =   case me of     Just e -> if e > b then p' else p     _      -> p   where+    b = fromEFDay b0     p' = periodPrevious p     me = periodEnd p' periodPreviousIn _ p = periodPrevious p@@ -273,9 +329,11 @@ periodShrink today _ = YearPeriod y   where (y,_,_) = toGregorian today -mondayBefore d = addDays (fromIntegral (1 - wd)) d+mondayBefore d = addDays (1 - toInteger wd) d   where     (_,_,wd) = toWeekDate d++thursdayOfWeekContaining = (addDays 3).mondayBefore  yearMonthContainingWeekStarting weekstart = (y,m)   where
+ Hledger/Data/PeriodData.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-|+++Data values for zero or more report periods, and for the pre-report period.+Report periods are assumed to be contiguous, and represented only by start dates+(as keys of an IntMap).++-}+module Hledger.Data.PeriodData+( periodDataFromList+, periodDataToList++, lookupPeriodData+, lookupPeriodDataOrHistorical+, insertPeriodData+, opPeriodData+, mergePeriodData+, padPeriodData++, tests_PeriodData+) where++#if MIN_VERSION_base(4,18,0)+import Data.Foldable1 (Foldable1(..))+#else+import Control.Applicative (liftA2)+#endif+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Map qualified as M+import Data.Time (Day (..), fromGregorian)++import Hledger.Data.Amount+import Hledger.Data.Types+import Hledger.Utils+++instance Show a => Show (PeriodData a) where+  showsPrec d (PeriodData h ds) =+    showParen (d > 10) $+        showString "PeriodData"+      . showString "{ pdpre = " . shows h+      . showString ", pdperiods = "+      . showString "fromList " . shows (M.toList ds)+      . showChar '}'++instance Foldable PeriodData where+  foldr f z (PeriodData h as) = foldr f (f h z) as+  foldl f z (PeriodData h as) = foldl f (f z h) as+  foldl' f z (PeriodData h as) = let fzh = f z h in fzh `seq` foldl' f fzh as++#if MIN_VERSION_base(4,18,0)+instance Foldable1 PeriodData where+  foldrMap1 f g (PeriodData h as) = foldr g (f h) as+  foldlMap1 f g (PeriodData h as) = foldl g (f h) as+  foldlMap1' f g (PeriodData h as) = let fh = f h in fh `seq` foldl' g fh as+#endif++instance Traversable PeriodData where+  traverse f (PeriodData h as) = liftA2 PeriodData (f h) $ traverse f as++-- | The Semigroup instance for 'PeriodData' simply takes the union of+-- keys in the date map section. This may not be the result you want if the+-- keys are not identical.+instance Semigroup a => Semigroup (PeriodData a) where+  PeriodData h1 as1 <> PeriodData h2 as2 = PeriodData (h1 <> h2) $ M.unionWith (<>) as1 as2++instance Monoid a => Monoid (PeriodData a) where+  mempty = PeriodData mempty mempty++-- | Construct a 'PeriodData' from a historical data value and a list of (period start, period data) pairs.+periodDataFromList :: a -> [(Day, a)] -> PeriodData a+periodDataFromList h = PeriodData h . M.fromList++-- | Convert 'PeriodData' to a historical data value and a list of (period start, period data) pairs.+periodDataToList :: PeriodData a -> (a, [(Day, a)])+periodDataToList (PeriodData h as) = (h, M.toList as)++-- | Get the data for the period containing the given 'Day', and that period's start date.+-- If the day is after the end of the last period, it is assumed to be within the last period.+-- If the day is before the start of the first period (ie, in the historical period), return Nothing.+lookupPeriodData :: Day -> PeriodData a -> Maybe (Day, a)+lookupPeriodData d (PeriodData _ as) = M.lookupLE d as++-- | Get the data for the period containing the given 'Day', and that period's start date.+-- If the day is after the end of the last period, it is assumed to be within the last period.+-- If the day is before the start of the first period (ie, in the historical period),+-- return the data for the historical period and no start date.+lookupPeriodDataOrHistorical :: Day -> PeriodData a -> (Maybe Day, a)+lookupPeriodDataOrHistorical d pd@(PeriodData h _) = case lookupPeriodData d pd of+  Nothing     -> (Nothing, h)+  Just (a, b) -> (Just a, b)++-- | Set historical or period data in the appropriate location in a 'PeriodData'.+insertPeriodData :: Semigroup a => Maybe Day -> a -> PeriodData a -> PeriodData a+insertPeriodData mday b balances = case mday of+    Nothing  -> balances{pdpre = pdpre balances <> b}+    Just day -> balances{pdperiods = M.insertWith (<>) day b $ pdperiods balances}++-- | Merge two 'PeriodData', using the given operation to combine their data values.+--+-- This will drop keys if they are not present in both 'PeriodData'.+opPeriodData :: (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c+opPeriodData f (PeriodData h1 as1) (PeriodData h2 as2) =+  PeriodData (f h1 h2) $ M.intersectionWith f as1 as2++-- | Merge two 'PeriodData', using the given operations for combining data+-- that's only in the first, only in the second, or in both, respectively.+mergePeriodData :: (a -> c) -> (b -> c) -> (a -> b -> c) -> PeriodData a -> PeriodData b -> PeriodData c+mergePeriodData only1 only2 f = \(PeriodData h1 as1) (PeriodData h2 as2) ->+  PeriodData (f h1 h2) $ merge as1 as2+  where+    merge = M.mergeWithKey (\_ x y -> Just $ f x y) (fmap only1) (fmap only2)++-- | Pad out the date map of a 'PeriodData' so that every key from another 'PeriodData' is present.+padPeriodData :: a -> PeriodData b -> PeriodData a -> PeriodData a+padPeriodData x pad bal = bal{pdperiods = pdperiods bal <> (x <$ pdperiods pad)}+++-- tests++tests_PeriodData =+  let+    dayMap  = periodDataFromList (mixed [usd 1]) [(fromGregorian 2000 01 01, mixed [usd 2]), (fromGregorian 2004 02 28, mixed [usd 3])]+    dayMap2 = periodDataFromList (mixed [usd 2]) [(fromGregorian 2000 01 01, mixed [usd 4]), (fromGregorian 2004 02 28, mixed [usd 6])]+  in testGroup "PeriodData" [++       testCase "periodDataFromList" $ do+         length dayMap @?= 3,++       testCase "Semigroup instance" $ do+         dayMap <> dayMap @?= dayMap2,++       testCase "Monoid instance" $ do+         dayMap <> mempty @?= dayMap+     ]
Hledger/Data/PeriodicTransaction.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-|@@ -12,19 +11,18 @@ ) where -#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import qualified Data.Text as T+import Data.Function ((&))+import Data.Maybe (isNothing)+import Data.Text qualified as T+import Data.Text.IO qualified as T import Text.Printf  import Hledger.Data.Types import Hledger.Data.Dates+import Hledger.Data.DayPartition import Hledger.Data.Amount-import Hledger.Data.Posting (post)+import Hledger.Data.Posting (post, generatedTransactionTagName) import Hledger.Data.Transaction-import Hledger.Utils.UTF8IOCompat (error')--- import Hledger.Utils.Debug  -- $setup -- >>> :set -XOverloadedStrings@@ -34,26 +32,33 @@ -- doctest helper, too much hassle to define in the comment -- XXX duplicates some logic in periodictransactionp _ptgen str = do-  let +  let     t = T.pack str     (i,s) = parsePeriodExpr' nulldate t-  case checkPeriodicTransactionStartDate i s t of-    Just e  -> error' e-    Nothing ->-      mapM_ (putStr . showTransaction) $-        runPeriodicTransaction-          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } -          nulldatespan+  mapM_ (T.putStr . showTransaction) $+    runPeriodicTransaction True+      nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }+      nulldatespan +_ptgenspan str spn = do+  let+    t = T.pack str+    (i,s) = parsePeriodExpr' nulldate t+  mapM_ (T.putStr . showTransaction) $+    runPeriodicTransaction True+      nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }+      spn  --deriving instance Show PeriodicTransaction -- for better pretty-printing: instance Show PeriodicTransaction where   show PeriodicTransaction{..} =-    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s}"+    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s, %s}"+      -- Warning, be careful to keep these synced ^ v       ("ptperiodexpr=" ++ show ptperiodexpr)       ("ptinterval=" ++ show ptinterval)       ("ptspan=" ++ show (show ptspan))+      ("ptsourcepos=" ++ show ptsourcepos)       ("ptstatus=" ++ show (show ptstatus))       ("ptcode=" ++ show ptcode)       ("ptdescription=" ++ show ptdescription)@@ -66,169 +71,175 @@  --nullperiodictransaction is defined in Types.hs --- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'+-- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'.+-- This should be a closed span with both start and end dates specified;+-- an open ended span will generate no transactions. -- -- Note that new transactions require 'txnTieKnot' post-processing.+-- The new transactions will have three tags added: +-- - a recur:PERIODICEXPR tag whose value is the generating periodic expression+-- - a generated-transaction: tag+-- - a hidden _generated-transaction: tag which does not appear in the comment.  --+-- >>> import Data.Time (fromGregorian) -- >>> _ptgen "monthly from 2017/1 to 2017/4"--- 2017/01/01---     ; recur: monthly from 2017/1 to 2017/4+-- 2017-01-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE>--- 2017/02/01---     ; recur: monthly from 2017/1 to 2017/4+-- 2017-02-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE>--- 2017/03/01---     ; recur: monthly from 2017/1 to 2017/4+-- 2017-03-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "monthly from 2017/1 to 2017/5"--- 2017/01/01---     ; recur: monthly from 2017/1 to 2017/5+-- 2017-01-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/02/01---     ; recur: monthly from 2017/1 to 2017/5+-- 2017-02-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/03/01---     ; recur: monthly from 2017/1 to 2017/5+-- 2017-03-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/04/01---     ; recur: monthly from 2017/1 to 2017/5+-- 2017-04-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"--- 2017/01/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04---     a           $1.00--- <BLANKLINE>--- 2017/02/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04+-- 2017-02-02+--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04 --     a           $1.00 -- <BLANKLINE>--- 2017/03/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04+-- 2017-03-02+--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"--- 2016/12/30---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/01/30---     ; recur: every 30th day of month from 2017/1 to 2017/5+-- 2017-01-30+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/02/28---     ; recur: every 30th day of month from 2017/1 to 2017/5+-- 2017-02-28+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/03/30---     ; recur: every 30th day of month from 2017/1 to 2017/5+-- 2017-03-30+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE>--- 2017/04/30---     ; recur: every 30th day of month from 2017/1 to 2017/5+-- 2017-04-30+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"--- 2016/12/08---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/01/12---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+-- 2017-01-12+--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE>--- 2017/02/09---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+-- 2017-02-09+--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE>--- 2017/03/09---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+-- 2017-03-09+--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "every nov 29th from 2017 to 2019"--- 2016/11/29---     ; recur: every nov 29th from 2017 to 2019---     a           $1.00--- <BLANKLINE>--- 2017/11/29---     ; recur: every nov 29th from 2017 to 2019+-- 2017-11-29+--     ; generated-transaction: ~ every nov 29th from 2017 to 2019 --     a           $1.00 -- <BLANKLINE>--- 2018/11/29---     ; recur: every nov 29th from 2017 to 2019+-- 2018-11-29+--     ; generated-transaction: ~ every nov 29th from 2017 to 2019 --     a           $1.00 -- <BLANKLINE> -- -- >>> _ptgen "2017/1"--- 2017/01/01---     ; recur: 2017/1+-- 2017-01-01+--     ; generated-transaction: ~ 2017/1 --     a           $1.00 -- <BLANKLINE> ----- >>> _ptgen ""--- *** Exception: failed to parse...--- ...------ >>> _ptgen "weekly from 2017"--- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the week------ >>> _ptgen "monthly from 2017/5/4"--- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month        ------ >>> _ptgen "every quarter from 2017/1/2"--- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter        ------ >>> _ptgen "yearly from 2017/1/14"--- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year        ------ >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))+-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction True (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03)) -- [] ---runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]-runPeriodicTransaction PeriodicTransaction{..} requestedspan =-    [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` spantofill ]+-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ Flex $ fromGregorian 2020 01 01) (Just $ Flex $ fromGregorian 2020 02 01))+--+-- >>> _ptgenspan "every 3 months from 2019-05" (DateSpan (Just $ Flex $ fromGregorian 2020 02 01) (Just $ Flex $ fromGregorian 2020 03 01))+-- 2020-02-01+--     ; generated-transaction: ~ every 3 months from 2019-05+--     a           $1.00+-- <BLANKLINE>+-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 05))+-- 2018-01-01+--     ; generated-transaction: ~ every 3 days from 2018+--     a           $1.00+-- <BLANKLINE>+-- 2018-01-04+--     ; generated-transaction: ~ every 3 days from 2018+--     a           $1.00+-- <BLANKLINE>+-- >>> _ptgenspan "every 3 days from 2018" (DateSpan (Just $ Flex $ fromGregorian 2018 01 02) (Just $ Flex $ fromGregorian 2018 01 05))+-- 2018-01-04+--     ; generated-transaction: ~ every 3 days from 2018+--     a           $1.00+-- <BLANKLINE>++runPeriodicTransaction :: Bool -> PeriodicTransaction -> DateSpan -> [Transaction]+runPeriodicTransaction verbosetags PeriodicTransaction{..} requestedspan =+    [ t{tdate=d} | (d, _) <- maybe [] dayPartitionToList alltxnspans, spanContainsDate requestedspan d ]   where-    spantofill = spanIntervalIntersect ptinterval ptspan requestedspan     t = nulltransaction{-           tstatus      = ptstatus+           tsourcepos   = ptsourcepos+          ,tstatus      = ptstatus           ,tcode        = ptcode-          ,tdescription = ptdescription -          ,tcomment     = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr-          ,ttags        = ("recur", ptperiodexpr) : pttags +          ,tdescription = ptdescription+          ,tcomment     = ptcomment+          ,ttags        = pttags           ,tpostings    = ptpostings           }+        & transactionAddHiddenAndMaybeVisibleTag verbosetags (generatedTransactionTagName, period)+    period = "~ " <> ptperiodexpr+    -- All the date spans described by this periodic transaction rule.+    alltxnspans = splitSpan adjust ptinterval span'+      where+        -- If the PT does not specify  start or end dates, we take them from the requestedspan.+        span' = ptspan `spanValidDefaultsFrom` requestedspan+        -- Unless the PT specified a start date explicitly, we will adjust the start date to the previous interval boundary.+        adjust = isNothing $ spanStart span' --- | Check that this date span begins at a boundary of this interval, +-- | Check that this date span begins at a boundary of this interval, -- or return an explanatory error message including the provided period expression -- (from which the span and interval are derived).-checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String -checkPeriodicTransactionStartDate i s periodexpr = +checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String+checkPeriodicTransactionStartDate i s periodexpr =   case (i, spanStart s) of-    (Weeks _,    Just d) -> checkStart d "week"-    (Months _,   Just d) -> checkStart d "month"-    (Quarters _, Just d) -> checkStart d "quarter"-    (Years _,    Just d) -> checkStart d "year"-    _                    -> Nothing +    (Weeks _,    Just d) -> checkStart d Week+    (Months _,   Just d) -> checkStart d Month+    (Quarters _, Just d) -> checkStart d Quarter+    (Years _,    Just d) -> checkStart d Year+    _                    -> Nothing     where       checkStart d x =-        let firstDate = fixSmartDate d ("","this",x) -        in   -         if d == firstDate +        let firstDate = fromEFDay $ fixSmartDate d $ SmartRelative 0 x+        in+         if d == firstDate          then Nothing          else Just $           "Unable to generate transactions according to "++show (T.unpack periodexpr)-          ++" because "++show d++" is not a first day of the "++x+          ++" because "++show d++" is not a first day of the "++show x  ---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ? --periodTransactionInterval :: PeriodicTransaction -> Maybe Interval
Hledger/Data/Posting.hs view
@@ -7,8 +7,9 @@  -} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}  module Hledger.Data.Posting (   -- * Posting@@ -18,9 +19,7 @@   vpost,   post',   vpost',-  nullsourcepos,   nullassertion,-  assertion,   balassert,   balassertTot,   balassertParInc,@@ -37,55 +36,113 @@   postingAllTags,   transactionAllTags,   relatedPostings,-  removePrices,+  postingStripCosts,+  postingApplyAliases,+  postingApplyCommodityStyles,+  postingStyleAmounts,+  postingAddTags,+  postingAddHiddenAndMaybeVisibleTag,   -- * date operations   postingDate,   postingDate2,-  isPostingInDateSpan,-  isPostingInDateSpan',-  postingsDateSpan,-  postingsDateSpan',+  postingDateOrDate2,   -- * account name operations   accountNamesFromPostings,-  accountNamePostingType,-  accountNameWithoutPostingType,-  accountNameWithPostingType,-  joinAccountNames,-  concatAccountNames,-  accountNameApplyAliases,-  accountNameApplyAliasesMemo,-  -- * transaction description operations-  transactionPayee,-  transactionNote,-  payeeAndNoteFromDescription,+  -- * comment/tag operations+  commentJoin,+  commentAddTag,+  commentAddTagUnspaced,+  commentAddTagNextLine,+  generatedTransactionTagName,+  modifiedTransactionTagName,+  generatedPostingTagName,+  costPostingTagName,+  conversionPostingTagName,+   -- * arithmetic   sumPostings,+  postingNegate,+  postingNegateMainAmount,   -- * rendering   showPosting,+  showPostingLines,+  postingAsLines,+  postingsAsLines,+  postingIndent,+  showAccountName,+  renderCommentLines,+  showBalanceAssertion,   -- * misc.-  showComment,+  postingTransformAmount,+  postingApplyValuation,+  postingToCost,+  postingAddInferredEquityPostings,+  postingPriceDirectivesFromCost,+  postingCommodities,   tests_Posting ) where-import Data.List-import Data.Maybe-import Data.MemoUgly (memo)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid++import Data.Default (def)+import Data.Foldable (asum)+import Data.Function ((&))+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.List (sort, union)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl') #endif+import Data.Set qualified as S import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar-import Safe+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Time.Calendar (Day)+import Safe (maximumBound)+import Text.DocLayout (realLength)+import Text.Tabular.AsciiWide hiding (render) -import Hledger.Utils +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName-import Hledger.Data.Dates (nulldate, spanContainsDate)+import Hledger.Data.Dates (nulldate)+import Hledger.Data.Valuation  +-- | Special tags hledger sometimes adds to mark various things.+-- These should be hidden tag names, beginning with _.+-- With --verbose-tags, the equivalent visible tags will also be added.+-- These tag names are mentioned in docs and can be matched by user queries, so consider the impact before changing them.+generatedTransactionTagName, modifiedTransactionTagName, costPostingTagName, conversionPostingTagName, generatedPostingTagName :: TagName+generatedTransactionTagName = "_generated-transaction"  -- transactions generated by a periodic txn rule+modifiedTransactionTagName  = "_modified-transaction"   -- transactions modified by an auto posting rule+generatedPostingTagName     = "_generated-posting"      -- postings generated by hledger for one reason or another+costPostingTagName          = "_cost-posting"           -- postings which have or could have a cost that's equivalent to nearby conversion postings+conversionPostingTagName    = "_conversion-posting"     -- postings to an equity account of Conversion type which have an amount that's equivalent to a nearby costful or potentially costful posting +instance HasAmounts BalanceAssertion where+  styleAmounts styles ba@BalanceAssertion{baamount} = ba{baamount=styleAmounts styles baamount}++instance HasAmounts Posting where+  styleAmounts styles p@Posting{pamount, pbalanceassertion} =+    p{ pamount=styleAmounts styles pamount+      ,pbalanceassertion=styleAmounts styles pbalanceassertion +      }++{-# DEPRECATED postingApplyCommodityStyles "please use styleAmounts instead" #-}+-- | Find and apply the appropriate display style to the posting amounts+-- in each commodity (see journalCommodityStyles).+-- Main amount precisions may be set or not according to the styles, but cost precisions are not set.+postingApplyCommodityStyles :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting+postingApplyCommodityStyles = styleAmounts++{-# DEPRECATED postingStyleAmounts "please use styleAmounts instead" #-}+-- | Like postingApplyCommodityStyles, but neither+-- main amount precisions or cost precisions are set.+postingStyleAmounts :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting+postingStyleAmounts = styleAmounts+ nullposting, posting :: Posting nullposting = Posting                 {pdate=Nothing@@ -106,7 +163,7 @@  -- | Make a posting to an account. post :: AccountName -> Amount -> Posting-post acc amt = posting {paccount=acc, pamount=Mixed [amt]}+post acc amt = posting {paccount=acc, pamount=mixedAmount amt}  -- | Make a virtual (unbalanced) posting to an account. vpost :: AccountName -> Amount -> Posting@@ -114,23 +171,19 @@  -- | Make a posting to an account, maybe with a balance assertion. post' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting-post' acc amt ass = posting {paccount=acc, pamount=Mixed [amt], pbalanceassertion=ass}+post' acc amt ass = posting {paccount=acc, pamount=mixedAmount amt, pbalanceassertion=ass}  -- | Make a virtual (unbalanced) posting to an account, maybe with a balance assertion. vpost' :: AccountName -> Amount -> Maybe BalanceAssertion -> Posting vpost' acc amt ass = (post' acc amt ass){ptype=VirtualPosting, pbalanceassertion=ass} -nullsourcepos :: GenericSourcePos-nullsourcepos = JournalSourcePos "" (1,1)--nullassertion, assertion :: BalanceAssertion+nullassertion :: BalanceAssertion nullassertion = BalanceAssertion                   {baamount=nullamt                   ,batotal=False                   ,bainclusive=False-                  ,baposition=nullsourcepos+                  ,baposition=initialPos ""                   }-assertion = nullassertion  -- | Make a partial, exclusive balance assertion. balassert :: Amount -> Maybe BalanceAssertion@@ -148,28 +201,163 @@ balassertTotInc :: Amount -> Maybe BalanceAssertion balassertTotInc amt = Just $ nullassertion{baamount=amt, batotal=True, bainclusive=True} +-- | Render a balance assertion, as the =[=][*] symbol and expected amount.+showBalanceAssertion :: BalanceAssertion -> WideBuilder+showBalanceAssertion ba =+    singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True, displayForceDecimalMark=True} (baamount ba)+  where+    eq  = if batotal ba     then singleton '=' else mempty+    ast = if bainclusive ba then singleton '*' else mempty+    singleton c = WideBuilder (TB.singleton c) 1+ -- Get the original posting, if any. originalPosting :: Posting -> Posting originalPosting p = fromMaybe p $ poriginal p --- XXX once rendered user output, but just for debugging now; clean up showPosting :: Posting -> String-showPosting p@Posting{paccount=a,pamount=amt,ptype=t} =-    unlines $ [concatTopPadded [show (postingDate p) ++ " ", showaccountname a ++ " ", showamount amt, showComment (pcomment p)]]-    where-      ledger3ishlayout = False-      acctnamewidth = if ledger3ishlayout then 25 else 22-      showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . T.unpack . elideAccountName width-      (bracket,width) = case t of-                          BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)-                          VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)-                          _ -> (id,acctnamewidth)-      showamount = padLeftWide 12 . showMixedAmount+showPosting p = T.unpack . T.unlines $ postingsAsLines False [p] +-- | Render a posting, at the appropriate width for aligning with+-- its siblings if any. Used by the rewrite command.+showPostingLines :: Posting -> [Text]+showPostingLines p = first3 $ postingAsLines False False maxacctwidth maxamtwidth p+  where+    linesWithWidths = map (postingAsLines False False maxacctwidth maxamtwidth) . maybe [p] tpostings $ ptransaction p+    maxacctwidth = maximumBound 0 $ map second3 linesWithWidths+    maxamtwidth  = maximumBound 0 $ map third3 linesWithWidths -showComment :: Text -> String-showComment t = if T.null t then "" else "  ;" ++ T.unpack t+-- | Render a transaction's postings as indented lines, suitable for `print` output.+--+-- Normally these will be in valid journal syntax which hledger can reparse+-- (though they may include no-longer-valid balance assertions).+-- Explicit amounts are shown, implicit amounts are not.+--+-- Postings with multicommodity explicit amounts are handled as follows:+-- if onelineamounts is true, these amounts are shown on one line,+-- comma-separated, and the output will not be valid journal syntax.+-- Otherwise, they are shown as several similar postings, one per commodity.+-- When the posting has a balance assertion, it is attached to the last of these postings.+--+-- Posting amounts will be aligned with each other, starting about 4 columns+-- beyond the widest account name (see postingAsLines for details).+-- The postings will appear balanced (amounts summing to zero).+-- Amounts' display precisions, which may have been limited by commodity directives,+-- will be increased if necessary to ensure this.+--+postingsAsLines :: Bool -> [Posting] -> [Text]+postingsAsLines onelineamounts ps = concatMap first3 linesWithWidths+  where+    linesWithWidths = map (postingAsLines False onelineamounts maxacctwidth maxamtwidth) ps+    maxacctwidth = maximumBound 0 $ map second3 linesWithWidths+    maxamtwidth  = maximumBound 0 $ map third3 linesWithWidths +-- | Render one posting, on one or more lines, suitable for `print` output.+-- Also returns the widths calculated for the account and amount fields.+--+-- There will be an indented account name, plus one or more of status flag,+-- posting amount, balance assertion, same-line comment, next-line comments.+--+-- If the posting's amount is implicit or if elideamount is true, no amount is shown.+-- If the posting's amount is explicit and multi-commodity, multiple similar+-- postings are shown, one for each commodity, to help produce parseable journal syntax.+-- Or if onelineamounts is true, such amounts are shown on one line, comma-separated+-- (and the output will not be valid journal syntax).+--+-- If an amount is zero, any commodity symbol attached to it is shown+-- (and the corresponding commodity display style is used).+--+-- By default, 4 spaces (2 if there's a status flag) are shown between+-- account name and start of amount area, which is typically 12 chars wide+-- and contains a right-aligned amount (so 10-12 visible spaces between+-- account name and amount is typical).+-- When given a list of postings to be aligned with, the whitespace will be+-- increased if needed to match the posting with the longest account name.+-- This is used to align the amounts of a transaction's postings.+--+postingAsLines :: Bool -> Bool -> Int -> Int -> Posting -> ([Text], Int, Int)+postingAsLines elideamount onelineamounts acctwidth amtwidth p =+    (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth)+  where+    -- This needs to be converted to strict Text in order to strip trailing+    -- spaces. This adds a small amount of inefficiency, and the only difference+    -- is whether there are trailing spaces in print (and related) reports. This+    -- could be removed and we could just keep everything as a Text Builder, but+    -- would require adding trailing spaces to 42 failing tests.+    postingblocks = [map T.stripEnd . T.lines . TL.toStrict $+                       render [ textCell BottomLeft statusandaccount+                              , textCell BottomLeft "  "+                              , Cell BottomLeft [pad amt]+                              , Cell BottomLeft [assertion]+                              , textCell BottomLeft samelinecomment+                              ]+                    | (amt,assertion) <- shownAmountsAssertions]+    render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header+    pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt+      where w = max 12 amtwidth - wbWidth amt  -- min. 12 for backwards compatibility++    pacctstr p' = showAccountName Nothing (ptype p') (paccount p')+    pstatusandacct p' = pstatusprefix p' <> pacctstr p'+    pstatusprefix p' = case pstatus p' of+        Unmarked -> ""+        s        -> T.pack (show s) <> " "++    -- currently prices are considered part of the amount string when right-aligning amounts+    -- Since we will usually be calling this function with the knot tied between+    -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on+    -- amtwidth at all.+    shownAmounts+      | elideamount = [mempty]+      | otherwise   = showMixedAmountLinesB displayopts $ pamount p+        where displayopts = defaultFmt{+          displayZeroCommodity=True, displayForceDecimalMark=True, displayOneLine=onelineamounts+          }+    thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts++    -- when there is a balance assertion, show it only on the last posting line+    shownAmountsAssertions = zip shownAmounts shownAssertions+      where+        shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion]+          where+            assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p++    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned+    statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p+    thisacctwidth = realLength $ pacctstr p++    (samelinecomment, newlinecomments) =+      case renderCommentLines (pcomment p) of []   -> ("",[])+                                              c:cs -> (c,cs)++-- | Show an account name, clipped to the given width if any, and+-- appropriately bracketed/parenthesised for the given posting type.+showAccountName :: Maybe Int -> PostingType -> AccountName -> Text+showAccountName w = fmt+  where+    fmt RegularPosting         = maybe id T.take w+    fmt VirtualPosting         = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w+    fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w++-- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines.+-- The first line (unless empty) will have leading space, subsequent lines will have a larger indent.+renderCommentLines :: Text -> [Text]+renderCommentLines t =+  case T.lines t of+    []      -> []+    [l]     -> [commentSpace $ comment l]        -- single-line comment+    ("":ls) -> "" : map (postingIndent . comment) ls  -- multi-line comment with empty first line+    (l:ls)  -> commentSpace (comment l) : map (postingIndent . comment) ls+  where+    comment = ("; "<>)++-- | Prepend a suitable indent for a posting (or transaction/posting comment) line.+postingIndent :: Text -> Text+postingIndent = ("    "<>)++-- | Prepend the space required before a same-line comment.+commentSpace :: Text -> Text+commentSpace = ("  "<>)++ isReal :: Posting -> Bool isReal p = ptype p == RegularPosting @@ -180,76 +368,78 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting  hasAmount :: Posting -> Bool-hasAmount = (/= missingmixedamt) . pamount+hasAmount = not . isMissingMixedAmount . pamount  hasBalanceAssignment :: Posting -> Bool hasBalanceAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)  -- | Sorted unique account names referenced by these postings. accountNamesFromPostings :: [Posting] -> [AccountName]-accountNamesFromPostings = nub . sort . map paccount+accountNamesFromPostings = S.toList . S.fromList . map paccount +-- | Sum all amounts from a list of postings. sumPostings :: [Posting] -> MixedAmount-sumPostings = sumStrict . map pamount+sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt --- | Remove all prices of a posting-removePrices :: Posting -> Posting-removePrices p = p{ pamount = Mixed $ remove <$> amounts (pamount p) }-  where remove a = a { aprice = NoPrice }+-- | Negate the posting's main amount and balance assertion amount if any.+postingNegate :: Posting -> Posting+postingNegate p@Posting{pamount=a, pbalanceassertion=mb} =+  p{pamount=negate a, pbalanceassertion=fmap balanceAssertionNegate mb}+  where+    balanceAssertionNegate b@BalanceAssertion{baamount=ba} = b{baamount=negate ba} +-- | Negate the posting's main amount but not the balance assertion amount.+postingNegateMainAmount :: Posting -> Posting+postingNegateMainAmount p@Posting{pamount=a} = p{pamount=negate a}++-- | Strip all prices from a Posting.+postingStripCosts :: Posting -> Posting+postingStripCosts = postingTransformAmount mixedAmountStripCosts+ -- | Get a posting's (primary) date - it's own primary date if specified, -- otherwise the parent transaction's primary date, or the null date if -- there is no parent transaction. postingDate :: Posting -> Day-postingDate p = fromMaybe txndate $ pdate p-    where-      txndate = maybe nulldate tdate $ ptransaction p+postingDate p = fromMaybe nulldate $ asum dates+    where dates = [ pdate p, tdate <$> ptransaction p ]  -- | Get a posting's secondary (secondary) date, which is the first of: -- posting's secondary date, transaction's secondary date, posting's -- primary date, transaction's primary date, or the null date if there is -- no parent transaction. postingDate2 :: Posting -> Day-postingDate2 p = headDef nulldate $ catMaybes dates-  where dates = [pdate2 p-                ,maybe Nothing tdate2 $ ptransaction p-                ,pdate p-                ,fmap tdate (ptransaction p)+postingDate2 p = fromMaybe nulldate $ asum dates+  where dates = [ pdate2 p+                , tdate2 =<< ptransaction p+                , pdate p+                , tdate <$> ptransaction p                 ] +-- | Get a posting's primary or secondary date, as specified.+postingDateOrDate2 :: WhichDate -> Posting -> Day+postingDateOrDate2 PrimaryDate   = postingDate+postingDateOrDate2 SecondaryDate = postingDate2+ -- | Get a posting's status. This is cleared or pending if those are -- explicitly set on the posting, otherwise the status of its parent -- transaction, or unmarked if there is no parent transaction. (Note--- the ambiguity, unmarked can mean "posting and transaction are both +-- the ambiguity, unmarked can mean "posting and transaction are both -- unmarked" or "posting is unmarked and don't know about the transaction". postingStatus :: Posting -> Status-postingStatus Posting{pstatus=s, ptransaction=mt}-  | s == Unmarked = case mt of Just t  -> tstatus t-                               Nothing -> Unmarked-  | otherwise = s--transactionPayee :: Transaction -> Text-transactionPayee = fst . payeeAndNoteFromDescription . tdescription--transactionNote :: Transaction -> Text-transactionNote = snd . payeeAndNoteFromDescription . tdescription+postingStatus Posting{pstatus=s, ptransaction=mt} = case s of+    Unmarked -> maybe Unmarked tstatus mt+    _ -> s --- | Parse a transaction's description into payee and note (aka narration) fields,--- assuming a convention of separating these with | (like Beancount).--- Ie, everything up to the first | is the payee, everything after it is the note.--- When there's no |, payee == note == description.-payeeAndNoteFromDescription :: Text -> (Text,Text)-payeeAndNoteFromDescription t-  | T.null n = (t, t)-  | otherwise = (textstrip p, textstrip $ T.drop 1 n)-  where-    (p, n) = T.span (/= '|') t+-- | Get the commodity symbols used in a posting's amounts (not including costs).+postingCommodities :: Posting -> [CommoditySymbol]+postingCommodities = map acommodity . filter (not . isMissingAmount) . amountsRaw . pamount+  where isMissingAmount a = acommodity a == "AUTO"  -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] postingAllTags p = ptags p ++ maybe [] ttags (ptransaction p) --- | Tags for this transaction including any from its postings.+-- | Tags for this transaction including any from its postings (which includes any from the postings' accounts). transactionAllTags :: Transaction -> [Tag] transactionAllTags t = ttags t ++ concatMap ptags (tpostings t) @@ -258,120 +448,164 @@ relatedPostings p@Posting{ptransaction=Just t} = filter (/= p) $ tpostings t relatedPostings _ = [] --- | Does this posting fall within the given date span ?-isPostingInDateSpan :: DateSpan -> Posting -> Bool-isPostingInDateSpan s = spanContainsDate s . postingDate+isEmptyPosting :: Posting -> Bool+isEmptyPosting = mixedAmountLooksZero . pamount --- --date2-sensitive version, separate for now to avoid disturbing multiBalanceReport.-isPostingInDateSpan' :: WhichDate -> DateSpan -> Posting -> Bool-isPostingInDateSpan' PrimaryDate   s = spanContainsDate s . postingDate-isPostingInDateSpan' SecondaryDate s = spanContainsDate s . postingDate2+-- | Apply some account aliases to the posting's account name, as described by accountNameApplyAliases.+-- This can fail due to a bad replacement pattern in a regular expression alias.+postingApplyAliases :: [AccountAlias] -> Posting -> Either RegexError Posting+postingApplyAliases aliases p@Posting{paccount} =+  case accountNameApplyAliases aliases paccount of+    Right a -> Right p{paccount=a}+    Left e  -> Left err+      where+        err = "problem while applying account aliases:\n" ++ pshow aliases+          ++ "\n to account name: "++T.unpack paccount++"\n "++e -isEmptyPosting :: Posting -> Bool-isEmptyPosting = isZeroMixedAmount . pamount+-- | Add tags to a posting, discarding any for which the posting already has a value.+-- Note this does not add tags to the posting's comment.+postingAddTags :: Posting -> [Tag] -> Posting+postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} --- | Get the minimal date span which contains all the postings, or the--- null date span if there are none.-postingsDateSpan :: [Posting] -> DateSpan-postingsDateSpan [] = DateSpan Nothing Nothing-postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')-    where ps' = sortOn postingDate ps+-- | Add the given hidden tag to a posting; and with a true argument,+-- also add the equivalent visible tag to the posting's tags and comment fields.+-- If the posting already has these tags (with any value), do nothing.+postingAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Posting -> Posting+postingAddHiddenAndMaybeVisibleTag verbosetags ht p@Posting{pcomment=c, ptags} =+  (p `postingAddTags` ([ht] <> [vt |verbosetags]))+  {pcomment=if verbosetags && not hadtag then c `commentAddTag` vt else c}+  where+    vt@(vname,_) = toVisibleTag ht+    hadtag = any ((== (T.toLower vname)) . T.toLower . fst) ptags  -- XXX should regex-quote vname --- --date2-sensitive version, as above.-postingsDateSpan' :: WhichDate -> [Posting] -> DateSpan-postingsDateSpan' _  [] = DateSpan Nothing Nothing-postingsDateSpan' wd ps = DateSpan (Just $ postingdate $ head ps') (Just $ addDays 1 $ postingdate $ last ps')-    where-      ps' = sortOn postingdate ps-      postingdate = if wd == PrimaryDate then postingDate else postingDate2+-- | Apply a specified valuation to this posting's amount, using the+-- provided price oracle, commodity styles, and reference dates.+-- See amountApplyValuation.+postingApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> ValuationType -> Posting -> Posting+postingApplyValuation priceoracle styles periodlast today v p =+    postingTransformAmount (mixedAmountApplyValuation priceoracle styles periodlast today (postingDate p) v) p --- AccountName stuff that depends on PostingType+-- | Maybe convert this 'Posting's amount to cost.+postingToCost :: ConversionOp -> Posting -> Maybe Posting+postingToCost NoConversionOp p = Just p+postingToCost ToCost         p+  -- If this is an equity conversion posting with an associated cost nearby, ignore it+  | conversionPostingTagName `elem` map fst (ptags p) && nocosts = Nothing+  | otherwise = Just $ postingTransformAmount mixedAmountCost p+  where+    nocosts = (not . any (isJust . acost) . amountsRaw) $ pamount p -accountNamePostingType :: AccountName -> PostingType-accountNamePostingType a-    | T.null a = RegularPosting-    | T.head a == '[' && T.last a == ']' = BalancedVirtualPosting-    | T.head a == '(' && T.last a == ')' = VirtualPosting-    | otherwise = RegularPosting+-- | Generate equity conversion postings corresponding to a 'Posting''s cost(s)+-- (one pair of conversion postings per cost), wherever they don't already exist.+postingAddInferredEquityPostings :: Bool -> Text -> Posting -> [Posting]+postingAddInferredEquityPostings verbosetags equityAcct p+  -- this posting has no costs+  | null costs = [p]+  -- this posting is already tagged as having associated conversion postings+  | costPostingTagName `elem` map fst (ptags p) = [p]+  -- tag the posting, and for each of its costs, add an equivalent pair of conversion postings after it+  | otherwise =+    postingAddHiddenAndMaybeVisibleTag verbosetags (costPostingTagName,"") p :+    concatMap makeConversionPostings costs+  where+    costs = filter (isJust . acost) . amountsRaw $ pamount p+    makeConversionPostings amt = case acost amt of+      Nothing -> []+      Just _  -> [ convp{ paccount = accountPrefix <> amtCommodity+                        , pamount = mixedAmount . negate $ amountStripCost amt+                        }+                 , convp{ paccount = accountPrefix <> costCommodity+                        , pamount = mixedAmount cost+                        }+                 ]+      where+        cost = amountCost amt+        amtCommodity  = commodity amt+        costCommodity = commodity cost+        convp = nullposting{pdate=pdate p, pdate2=pdate2 p, pstatus=pstatus p, ptransaction=ptransaction p}+          & postingAddHiddenAndMaybeVisibleTag verbosetags (conversionPostingTagName,"")+          & postingAddHiddenAndMaybeVisibleTag verbosetags (generatedPostingTagName, "")+        accountPrefix = mconcat [ equityAcct, ":", T.intercalate "-" $ sort [amtCommodity, costCommodity], ":"]+        -- Take the commodity of an amount and collapse consecutive spaces to a single space+        commodity = T.unwords . filter (not . T.null) . T.words . acommodity -accountNameWithoutPostingType :: AccountName -> AccountName-accountNameWithoutPostingType a = case accountNamePostingType a of-                                    BalancedVirtualPosting -> T.init $ T.tail a-                                    VirtualPosting -> T.init $ T.tail a-                                    RegularPosting -> a+-- | Make a market price equivalent to this posting's amount's unit+-- price, if any.+postingPriceDirectivesFromCost :: Posting -> [PriceDirective]+postingPriceDirectivesFromCost p@Posting{pamount} =+    mapMaybe (amountPriceDirectiveFromCost $ postingDate p) $ amountsRaw pamount -accountNameWithPostingType :: PostingType -> AccountName -> AccountName-accountNameWithPostingType BalancedVirtualPosting a = "["<>accountNameWithoutPostingType a<>"]"-accountNameWithPostingType VirtualPosting a = "("<>accountNameWithoutPostingType a<>")"-accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a+-- | Apply a transform function to this posting's main amount (but not its balance assertion amount).+postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting+postingTransformAmount f p@Posting{pamount=a} = p{pamount=f a} --- | Prefix one account name to another, preserving posting type--- indicators like concatAccountNames.-joinAccountNames :: AccountName -> AccountName -> AccountName-joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b]+-- | Join two parts of a comment, eg a tag and another tag, or a tag+-- and a non-tag, on a single line. Interpolates a comma and space+-- unless one of the parts is empty.+commentJoin :: Text -> Text -> Text+commentJoin c1 c2+  | T.null c1 = c2+  | T.null c2 = c1+  | otherwise = c1 <> ", " <> c2 --- | Join account names into one. If any of them has () or [] posting type--- indicators, these (the first type encountered) will also be applied to--- the resulting account name.-concatAccountNames :: [AccountName] -> AccountName-concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as-    where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as+-- | Add a tag to a comment, comma-separated from any prior content.+-- A space is inserted following the colon, before the value.+commentAddTag :: Text -> Tag -> Text+commentAddTag c (t,v)+  | T.null c' = tag+  | otherwise = c' `commentJoin` tag+  where+    c'  = T.stripEnd c+    tag = t <> ": " <> v --- | Rewrite an account name using all matching aliases from the given list, in sequence.--- Each alias sees the result of applying the previous aliases.-accountNameApplyAliases :: [AccountAlias] -> AccountName -> AccountName-accountNameApplyAliases aliases a = accountNameWithPostingType atype aname'+-- | Like commentAddTag, but omits the space after the colon.+commentAddTagUnspaced :: Text -> Tag -> Text+commentAddTagUnspaced c (t,v)+  | T.null c' = tag+  | otherwise = c' `commentJoin` tag   where-    (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a)-    aname' = foldl-             (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct))-             aname-             aliases+    c'  = T.stripEnd c+    tag = t <> ":" <> v --- | Memoising version of accountNameApplyAliases, maybe overkill.-accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> AccountName-accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)+-- | Add a tag on its own line to a comment, preserving any prior content.+-- A space is inserted following the colon, before the value.+commentAddTagNextLine :: Text -> Tag -> Text+commentAddTagNextLine cmt (t,v) =+  cmt <> (if "\n" `T.isSuffixOf` cmt then "" else "\n") <> t <> ": " <> v --- aliasMatches :: AccountAlias -> AccountName -> Bool--- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a--- aliasMatches (RegexAlias re  _) a = regexMatchesCI re a -aliasReplace :: AccountAlias -> AccountName -> AccountName-aliasReplace (BasicAlias old new) a-  | old `isAccountNamePrefixOf` a || old == a = new <> T.drop (T.length old) a-  | otherwise = a-aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX+-- tests +tests_Posting = testGroup "Posting" [ --- tests+  testCase "accountNamePostingType" $ do+    accountNamePostingType "a" @?= RegularPosting+    accountNamePostingType "(a)" @?= VirtualPosting+    accountNamePostingType "[a]" @?= BalancedVirtualPosting -tests_Posting = tests "Posting" [+ ,testCase "accountNameWithoutPostingType" $ do+    accountNameWithoutPostingType "(a)" @?= "a" -  tests "accountNamePostingType" [-    accountNamePostingType "a" `is` RegularPosting-    ,accountNamePostingType "(a)" `is` VirtualPosting-    ,accountNamePostingType "[a]" `is` BalancedVirtualPosting-  ]+ ,testCase "accountNameWithPostingType" $ do+    accountNameWithPostingType VirtualPosting "[a]" @?= "(a)" - ,tests "accountNameWithoutPostingType" [-    accountNameWithoutPostingType "(a)" `is` "a"-  ]+ ,testCase "joinAccountNames" $ do+    "a" `joinAccountNames` "b:c" @?= "a:b:c"+    "a" `joinAccountNames` "(b:c)" @?= "(a:b:c)"+    "[a]" `joinAccountNames` "(b:c)" @?= "[a:b:c]"+    "" `joinAccountNames` "a" @?= "a" - ,tests "accountNameWithPostingType" [-    accountNameWithPostingType VirtualPosting "[a]" `is` "(a)"-  ]+ ,testCase "concatAccountNames" $ do+    concatAccountNames [] @?= ""+    concatAccountNames ["a","(b)","[c:d]"] @?= "(a:b:c:d)" - ,tests "joinAccountNames" [-    "a" `joinAccountNames` "b:c" `is` "a:b:c"-    ,"a" `joinAccountNames` "(b:c)" `is` "(a:b:c)"-    ,"[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]"-    ,"" `joinAccountNames` "a" `is` "a"-  ]+ ,testCase "commentAddTag" $ do+    commentAddTag "" ("a","") @?= "a: "+    commentAddTag "[1/2]" ("a","") @?= "[1/2], a: " - ,tests "concatAccountNames" [-    concatAccountNames [] `is` ""-    ,concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"-  ]+ ,testCase "commentAddTagNextLine" $ do+    commentAddTagNextLine "" ("a","") @?= "\na: "+    commentAddTagNextLine "[1/2]" ("a","") @?= "[1/2]\na: "   ]
Hledger/Data/RawOptions.hs view
@@ -9,60 +9,158 @@  module Hledger.Data.RawOptions (   RawOpts,+  mkRawOpts,+  overRawOpts,+  dropRawOpt,   setopt,   setboolopt,-  inRawOpts,+  unsetboolopt,+  appendopts,   boolopt,+  toggleopt,+  choiceopt,+  collectopts,   stringopt,   maybestringopt,   listofstringopt,   intopt,+  posintopt,   maybeintopt,-  maybecharopt+  maybeposintopt,+  maybecharopt,+  maybeynopt,+  maybeynaopt, ) where -import Data.Maybe-import qualified Data.Text as T-import Safe+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Default (Default(..))+import Safe (headMay, lastMay, readDef)  import Hledger.Utils+import Data.Char (toLower)+import Data.List (intercalate)   -- | The result of running cmdargs: an association list of option names to string values.-type RawOpts = [(String,String)]+newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] }+  deriving (Show) +instance Default RawOpts where def = RawOpts []++mkRawOpts :: [(String,String)] -> RawOpts+mkRawOpts = RawOpts++overRawOpts :: ([(String,String)] -> [(String,String)]) -> RawOpts -> RawOpts+overRawOpts f = RawOpts . f . unRawOpts++dropRawOpt :: String -> RawOpts -> RawOpts+dropRawOpt a = overRawOpts $ filter (not.(==a).fst)+ setopt :: String -> String -> RawOpts -> RawOpts-setopt name val = (++ [(name, quoteIfNeeded $ val)])+setopt name val = overRawOpts (++ [(name, val)])  setboolopt :: String -> RawOpts -> RawOpts-setboolopt name = (++ [(name,"")])+setboolopt name = overRawOpts (++ [(name,"")]) --- | Is the named option present ?-inRawOpts :: String -> RawOpts -> Bool-inRawOpts name = isJust . lookup name+unsetboolopt :: String -> RawOpts -> RawOpts+unsetboolopt name = overRawOpts (filter ((/=name).fst)) +appendopts :: [(String,String)] -> RawOpts -> RawOpts+appendopts new = overRawOpts (++new)++-- | Is the named flag present ? boolopt :: String -> RawOpts -> Bool-boolopt = inRawOpts+boolopt name = isJust . lookup name . unRawOpts +-- | Like boolopt, except if the flag is repeated on the command line it toggles the value.+-- An even number of repetitions is equivalent to none.+toggleopt :: String -> RawOpts -> Bool+toggleopt name rawopts = odd $ length [ n | (n,_) <- unRawOpts rawopts, n==name]++-- | From a list of RawOpts, get the last one (ie the right-most on the command line)+-- for which the given predicate returns a Just value.+-- Useful for exclusive choice flags like --daily|--weekly|--quarterly...+--+-- >>> import Safe (readMay)+-- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")])+-- Just "c"+-- >>> choiceopt (const Nothing) (RawOpts [("a","")])+-- Nothing+-- >>> choiceopt readMay (RawOpts [("LT",""),("EQ",""),("Neither","")]) :: Maybe Ordering+-- Just EQ+choiceopt :: (String -> Maybe a) -- ^ "parser" that returns 'Just' value for valid choice+          -> RawOpts             -- ^ actual options where to look for flag+          -> Maybe a             -- ^ exclusive choice among those returned as 'Just' from "parser"+choiceopt f = lastMay . collectopts (f . fst)++-- | Collects processed and filtered list of options preserving their order+--+-- >>> collectopts (const Nothing) (RawOpts [("x","")])+-- []+-- >>> collectopts Just (RawOpts [("a",""),("b","")])+-- [("a",""),("b","")]+collectopts :: ((String, String) -> Maybe a) -> RawOpts -> [a]+collectopts f = mapMaybe f . unRawOpts+ maybestringopt :: String -> RawOpts -> Maybe String-maybestringopt name = fmap (T.unpack . stripquotes . T.pack) . lookup name . reverse+maybestringopt name = lookup name . reverse . unRawOpts  stringopt :: String -> RawOpts -> String stringopt name = fromMaybe "" . maybestringopt name  maybecharopt :: String -> RawOpts -> Maybe Char-maybecharopt name rawopts = lookup name rawopts >>= headMay+maybecharopt name (RawOpts rawopts) = lookup name rawopts >>= headMay  listofstringopt :: String -> RawOpts -> [String]-listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]+listofstringopt name (RawOpts rawopts) = [v | (k,v) <- rawopts, k==name] +-- | Reads the named option's Int argument, if it is present.+-- An argument that is too small or too large will raise an error. maybeintopt :: String -> RawOpts -> Maybe Int-maybeintopt name rawopts =-    let ms = maybestringopt name rawopts in-    case ms of Nothing -> Nothing-               Just s -> Just $ readDef (usageError $ "could not parse "++name++" number: "++s) s+maybeintopt = maybeclippedintopt minBound maxBound +-- | Reads the named option's natural-number argument, if it is present.+-- An argument that is negative or too large will raise an error.+maybeposintopt :: String -> RawOpts -> Maybe Int+maybeposintopt = maybeclippedintopt 0 maxBound++-- | Reads the named option's Int argument. If not present it will+-- return 0. An argument that is too small or too large will raise an error. intopt :: String -> RawOpts -> Int intopt name = fromMaybe 0 . maybeintopt name +-- | Reads the named option's natural-number argument. If not present it will+-- return 0. An argument that is negative or too large will raise an error.+posintopt :: String -> RawOpts -> Int+posintopt name = fromMaybe 0 . maybeposintopt name++-- | Reads the named option's Int argument, if it is present. An argument+-- that does not fit within the given bounds will raise an error.+maybeclippedintopt :: Int -> Int -> String -> RawOpts -> Maybe Int+maybeclippedintopt minVal maxVal name =+    fmap (intOrError . readOrError) . maybestringopt name+  where+    readOrError s = readDef (usageError $ "could not parse " ++ name ++ " number: " ++ s) s+    intOrError n | n >= toInteger minVal && n <= toInteger maxVal = fromInteger n+                 | otherwise = usageError $ "argument to " ++ name+                                         ++ " must lie in the range "+                                         ++ show minVal ++ " to " ++ show maxVal+                                         ++ ", but is " ++ show n++maybeynopt :: String -> RawOpts -> Maybe Bool+maybeynopt name rawopts =+  case maybestringopt name rawopts of+    Just v | map toLower v `elem` ["y","yes","always"] -> Just True+    Just v | map toLower v `elem` ["n","no","never"]   -> Just False+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no"])+    _ -> Nothing++maybeynaopt :: String -> RawOpts -> Maybe YNA+maybeynaopt name rawopts =+  case maybestringopt name rawopts of+    Just v | map toLower v `elem` ["y","yes","always"] -> Just Yes+    Just v | map toLower v `elem` ["n","no","never"]   -> Just No+    Just v | map toLower v `elem` ["a","auto"]         -> Just Auto+    Just _ -> error' $ name <> " value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])+    _ -> Nothing
Hledger/Data/StringFormat.hs view
@@ -2,7 +2,9 @@ -- hledger's report item fields. The formats are used by -- report-specific renderers like renderBalanceReportItem. -{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies, PackageImports #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}  module Hledger.Data.StringFormat (           parseStringFormat@@ -10,20 +12,21 @@         , StringFormat(..)         , StringFormatComponent(..)         , ReportItemField(..)+        , defaultBalanceLineFormat         , tests_StringFormat         ) where -import Prelude ()-import "base-compat-batteries" Prelude.Compat-import Numeric+import Numeric (readDec) import Data.Char (isPrint)-import Data.Maybe-import qualified Data.Text as T+import Data.Default (Default(..))+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T import Text.Megaparsec-import Text.Megaparsec.Char+import Text.Megaparsec.Char (char, digitChar, string) -import Hledger.Utils.Parse-import Hledger.Utils.String (formatString)+import Hledger.Utils.Parse (SimpleTextParser)+import Hledger.Utils.Text (formatText) import Hledger.Utils.Test  -- | A format specification/template to use when rendering a report line item as text.@@ -41,13 +44,13 @@ -- mode, which provides a limited StringFormat renderer. -- data StringFormat =-    OneLine [StringFormatComponent]       -- ^ multi-line values will be rendered on one line, comma-separated-  | TopAligned [StringFormatComponent]    -- ^ values will be top-aligned (and bottom-padded to the same height)+    OneLine       [StringFormatComponent] -- ^ multi-line values will be rendered on one line, comma-separated+  | TopAligned    [StringFormatComponent] -- ^ values will be top-aligned (and bottom-padded to the same height)   | BottomAligned [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded)   deriving (Show, Eq)  data StringFormatComponent =-    FormatLiteral String        -- ^ Literal text to be rendered as-is+    FormatLiteral Text          -- ^ Literal text to be rendered as-is   | FormatField Bool                 (Maybe Int)                 (Maybe Int)@@ -73,6 +76,16 @@   | FieldNo Int       -- ^ A report item's nth field. May be unimplemented.     deriving (Show, Eq) +instance Default StringFormat where def = defaultBalanceLineFormat++-- | Default line format for balance report: "%20(total)  %2(depth_spacer)%-(account)"+defaultBalanceLineFormat :: StringFormat+defaultBalanceLineFormat = BottomAligned [+      FormatField False (Just 20) Nothing TotalField+    , FormatLiteral "  "+    , FormatField True (Just 2) Nothing DepthSpacerField+    , FormatField True Nothing Nothing AccountField+    ] ----------------------------------------------------------------------  -- renderStringFormat :: StringFormat -> Map String String -> String@@ -81,14 +94,14 @@ ----------------------------------------------------------------------  -- | Parse a string format specification, or return a parse error.-parseStringFormat :: String -> Either String StringFormat+parseStringFormat :: Text -> Either String StringFormat parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of     Left y -> Left $ show y     Right x -> Right x  defaultStringFormatStyle = BottomAligned -stringformatp :: SimpleStringParser StringFormat+stringformatp :: SimpleTextParser StringFormat stringformatp = do   alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String))   let constructor =@@ -99,19 +112,19 @@           _        -> defaultStringFormatStyle   constructor <$> many componentp -componentp :: SimpleStringParser StringFormatComponent+componentp :: SimpleTextParser StringFormatComponent componentp = formatliteralp <|> formatfieldp -formatliteralp :: SimpleStringParser StringFormatComponent+formatliteralp :: SimpleTextParser StringFormatComponent formatliteralp = do-    s <- some c+    s <- T.pack <$> some c     return $ FormatLiteral s     where       isPrintableButNotPercentage x = isPrint x && x /= '%'       c =     (satisfy isPrintableButNotPercentage <?> "printable character")           <|> try (string "%%" >> return '%') -formatfieldp :: SimpleStringParser StringFormatComponent+formatfieldp :: SimpleTextParser StringFormatComponent formatfieldp = do     char '%'     leftJustified <- optional (char '-')@@ -120,13 +133,13 @@     char '('     f <- fieldp     char ')'-    return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f+    return $ FormatField (isJust leftJustified) (parseDec minWidth <|> Just 0) (parseDec maxWidth) f     where       parseDec s = case s of         Just text -> Just m where ((m,_):_) = readDec text         _ -> Nothing -fieldp :: SimpleStringParser ReportItemField+fieldp :: SimpleTextParser ReportItemField fieldp = do         try (string "account" >> return AccountField)     <|> try (string "depth_spacer" >> return DepthSpacerField)@@ -137,45 +150,43 @@  ---------------------------------------------------------------------- -formatStringTester fs value expected = actual `is` expected +formatStringTester fs value expected = actual @?= expected   where     actual = case fs of-      FormatLiteral l                   -> formatString False Nothing Nothing l-      FormatField leftJustify min max _ -> formatString leftJustify min max value+      FormatLiteral l                 -> formatText False Nothing Nothing l+      FormatField leftJustify mn mx _ -> formatText leftJustify mn mx value -tests_StringFormat = tests "StringFormat" [+tests_StringFormat = testGroup "StringFormat" [ -   tests "formatStringHelper" [+   testCase "formatStringHelper" $ do       formatStringTester (FormatLiteral " ")                                     ""            " "-    , formatStringTester (FormatField False Nothing Nothing DescriptionField)    "description" "description"-    , formatStringTester (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"-    , formatStringTester (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"-    , formatStringTester (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"-    , formatStringTester (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "-    , formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "-    , formatStringTester (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"-    ]+      formatStringTester (FormatField False Nothing Nothing DescriptionField)    "description" "description"+      formatStringTester (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"+      formatStringTester (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"+      formatStringTester (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"+      formatStringTester (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "+      formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "+      formatStringTester (FormatField True Nothing (Just 3) DescriptionField)    "description" "des" -  ,tests "parseStringFormat" $-    let s `gives` expected = test (T.pack s) $ parseStringFormat s `is` Right expected-    in [+  ,let s `gives` expected = testCase s $ parseStringFormat (T.pack s) @?= Right expected+   in testGroup "parseStringFormat" [       ""                           `gives` (defaultStringFormatStyle [])     , "D"                          `gives` (defaultStringFormatStyle [FormatLiteral "D"])-    , "%(date)"                    `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])-    , "%(total)"                   `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField])+    , "%(date)"                    `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing DescriptionField])+    , "%(total)"                   `gives` (defaultStringFormatStyle [FormatField False (Just 0) Nothing TotalField])     -- TODO     -- , "^%(total)"                  `gives` (TopAligned [FormatField False Nothing Nothing TotalField])     -- , "_%(total)"                  `gives` (BottomAligned [FormatField False Nothing Nothing TotalField])     -- , ",%(total)"                  `gives` (OneLine [FormatField False Nothing Nothing TotalField])-    , "Hello %(date)!"             `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])-    , "%-(date)"                   `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField])+    , "Hello %(date)!"             `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False (Just 0) Nothing DescriptionField, FormatLiteral "!"])+    , "%-(date)"                   `gives` (defaultStringFormatStyle [FormatField True (Just 0) Nothing DescriptionField])     , "%20(date)"                  `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])-    , "%.10(date)"                 `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField])+    , "%.10(date)"                 `gives` (defaultStringFormatStyle [FormatField False (Just 0) (Just 10) DescriptionField])     , "%20.10(date)"               `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])     , "%20(account) %.10(total)"   `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField                                                                      ,FormatLiteral " "-                                                                     ,FormatField False Nothing (Just 10) TotalField+                                                                     ,FormatField False (Just 0) (Just 10) TotalField                                                                      ])-    , test "newline not parsed" $ expectLeft $ parseStringFormat "\n"+    , testCase "newline not parsed" $ assertLeft $ parseStringFormat "\n"     ]  ]
Hledger/Data/Timeclock.hs view
@@ -6,95 +6,239 @@  -} -{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}  module Hledger.Data.Timeclock (-   timeclockEntriesToTransactions+   timeclockToTransactions+  ,timeclockToTransactionsOld   ,tests_Timeclock ) where -import Data.Maybe--- import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar-import Data.Time.Clock-import Data.Time.Format-import Data.Time.LocalTime-#if !(MIN_VERSION_time(1,5,0))-import System.Locale (defaultTimeLocale)-#endif-import Text.Printf+import Data.List (partition, sortBy, uncons)+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Time.Calendar (addDays)+import Data.Time.Clock (addUTCTime, getCurrentTime)+import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)+import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), getCurrentTimeZone,+                            localTimeToUTC, midnight, utc, utcToLocalTime)+import Text.Printf (printf) -import Hledger.Utils +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Amount import Hledger.Data.Posting-import Hledger.Data.Transaction +-- detailed output for debugging+-- deriving instance Show TimeclockEntry++-- compact output instance Show TimeclockEntry where-    show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)+  show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)  instance Show TimeclockCode where-    show SetBalance = "b"-    show SetRequiredHours = "h"-    show In = "i"-    show Out = "o"-    show FinalOut = "O"+  show SetBalance = "b"+  show SetRequiredHours = "h"+  show In = "i"+  show Out = "o"+  show FinalOut = "O"  instance Read TimeclockCode where-    readsPrec _ ('b' : xs) = [(SetBalance, xs)]-    readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]-    readsPrec _ ('i' : xs) = [(In, xs)]-    readsPrec _ ('o' : xs) = [(Out, xs)]-    readsPrec _ ('O' : xs) = [(FinalOut, xs)]-    readsPrec _ _ = []+  readsPrec _ ('b':xs) = [(SetBalance, xs)]+  readsPrec _ ('h':xs) = [(SetRequiredHours, xs)]+  readsPrec _ ('i':xs) = [(In, xs)]+  readsPrec _ ('o':xs) = [(Out, xs)]+  readsPrec _ ('O':xs) = [(FinalOut, xs)]+  readsPrec _ _ = [] --- | Convert time log entries to journal transactions. When there is no--- clockout, add one with the provided current time. Sessions crossing--- midnight are split into days to give accurate per-day totals.-timeclockEntriesToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]-timeclockEntriesToTransactions _ [] = []-timeclockEntriesToTransactions now [i]-    | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now [i',o]-    | otherwise = [entryFromTimeclockInOut i o]-    where-      o = TimeclockEntry (tlsourcepos i) Out end "" ""-      end = if itime > now then itime else now-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-timeclockEntriesToTransactions now (i:o:rest)-    | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now (i':o:rest)-    | otherwise = entryFromTimeclockInOut i o : timeclockEntriesToTransactions now rest-    where-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-{- HLINT ignore timeclockEntriesToTransactions -}+data Session = Session {+  in' :: TimeclockEntry,+  out :: TimeclockEntry+} deriving Show +data Sessions = Sessions {+  completed :: [Session],+  active :: [TimeclockEntry]+} deriving Show++-- | Convert timeclock entries to journal transactions.+-- This is the old version from hledger <1.43, now enabled by --old-timeclock.+-- It requires strictly alternating clock-in and clock-entries.+-- It was documented as allowing only one clocked-in session at a time,+-- but in fact it allows concurrent sessions, even with the same account name.+--+-- Entries must be a strict alternation of in and out, beginning with in.+-- When there is no clockout, one is added with the provided current time. +-- Sessions crossing midnight are split into days to give accurate per-day totals.+-- If entries are not in the expected in/out order, an error is raised.+--+timeclockToTransactionsOld :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockToTransactionsOld _ [] = []+timeclockToTransactionsOld now [i]+  | tlcode i /= In = errorExpectedCodeButGot In i+  | odate > idate = entryFromTimeclockInOut True i o' : timeclockToTransactionsOld now [i',o]+  | otherwise = [entryFromTimeclockInOut True i o]+  where+    o = TimeclockEntry (tlsourcepos i) Out end "" "" "" []+    end = if itime > now then itime else now+    (itime,otime) = (tldatetime i,tldatetime o)+    (idate,odate) = (localDay itime,localDay otime)+    o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+    i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+timeclockToTransactionsOld now (i:o:rest)+  | tlcode i /= In  = errorExpectedCodeButGot In i+  | tlcode o /= Out = errorExpectedCodeButGot Out o+  | odate > idate   = entryFromTimeclockInOut True i o' : timeclockToTransactionsOld now (i':o:rest)+  | otherwise       = entryFromTimeclockInOut True i o : timeclockToTransactionsOld now rest+  where+    (itime,otime) = (tldatetime i,tldatetime o)+    (idate,odate) = (localDay itime,localDay otime)+    o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+    i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+{- HLINT ignore timeclockToTransactionsOld -}++-- | Convert timeclock entries to journal transactions.+-- This is the new, default version added in hledger 1.43 and improved in 1.50.+-- It allows concurrent clocked-in sessions (though not with the same account name),+-- and clock-in/clock-out entries in any order.+--+-- Entries are processed in parse order.+-- Sessions crossing midnight are split into days to give accurate per-day totals.+-- At the end, any sessions with no clockout get an implicit clockout with the provided "now" time.+-- If any entries cannot be paired as expected, an error is raised.+--+timeclockToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockToTransactions now entries0 = transactions+  where+    -- don't sort by time, it messes things up; just reverse to get the parsed order+    entries = dbg7 "timeclock entries" $ reverse entries0+    sessions = dbg6 "sessions" $ pairClockEntries entries [] []+    transactionsFromSession s = entryFromTimeclockInOut False (in' s) (out s)+    -- If any "in" sessions are in the future, then set their out time to the initial time+    outtime te = max now (tldatetime te)+    createout te = TimeclockEntry (tlsourcepos te) Out (outtime te) (tlaccount te) "" "" []+    outs = map createout (active sessions)+    stillopen = dbg6 "stillopen" $ pairClockEntries ((active sessions) <> outs) [] []+    transactions = map transactionsFromSession $ sortBy (\s1 s2 -> compare (in' s1) (in' s2)) (completed sessions ++ completed stillopen)++    -- | Assuming that entries have been sorted, we go through each time log entry.+    -- We collect all of the "i" in the list "actives," and each time we encounter+    -- an "o," we look for the corresponding "i" in actives.+    -- If we cannot find it, then it is an error (since the list is sorted).+    -- If the "o" is recorded on a different day than the "i" then we close the+    -- active entry at the end of its day, replace it in the active list+    -- with a start at midnight on the next day, and try again.+    -- This raises an error if any outs cannot be paired with an in.+    pairClockEntries :: [TimeclockEntry] -> [TimeclockEntry] -> [Session] -> Sessions+    pairClockEntries [] actives sessions1 = Sessions {completed = sessions1, active = actives}+    pairClockEntries (entry:es) actives sessions1+      | tlcode entry == In  = pairClockEntries es inentries sessions1+      | tlcode entry == Out = pairClockEntries es' actives' sessions2+      | otherwise = pairClockEntries es actives sessions1+      where+        (inentry, newactive) = findInForOut entry (partition (\e -> tlaccount e == tlaccount entry) actives)+        (itime, otime) = (tldatetime inentry, tldatetime entry)+        (idate, odate) = (localDay itime, localDay otime)+        omidnight = entry {tldatetime = itime {localDay = idate, localTimeOfDay = TimeOfDay 23 59 59}}+        imidnight = inentry {tldatetime = itime {localDay = addDays 1 idate, localTimeOfDay = midnight}}+        (sessions2, actives', es')+          | odate > idate = (Session {in' = inentry, out = omidnight} : sessions1, imidnight:newactive, entry:es)+          | otherwise     = (Session {in' = inentry, out = entry} : sessions1, newactive, es)+        inentries = case filter ((== tlaccount entry) . tlaccount) actives of+          []                -> entry:actives+          activesinthisacct -> error' $ T.unpack $ makeTimeClockErrorExcerpt entry $ T.unlines $ [+            ""+            ,"overlaps with session beginning at:"+            ,""+            ]+            <> map (flip makeTimeClockErrorExcerpt "") activesinthisacct+            <> [ "Overlapping sessions with the same account name are not supported." ]+            -- XXX better to show full session(s)+            -- <> map (T.pack . show) (filter ((`elem` activesinthisacct).in') sessions)++        -- | Find the relevant clockin in the actives list that should be paired with this clockout.+        -- If there is a session that has the same account name, then use that.+        -- Otherwise, if there is an active anonymous session, use that.+        -- Otherwise, raise an error.+        findInForOut :: TimeclockEntry -> ([TimeclockEntry], [TimeclockEntry]) -> (TimeclockEntry, [TimeclockEntry])+        findInForOut _ (matchingout:othermatches, rest) = (matchingout, othermatches <> rest)+        findInForOut o ([], activeins) =+            if emptyname then (first, rest) else error' errmsg+            where+                l = show $ unPos $ sourceLine $ tlsourcepos o+                c = unPos $ sourceColumn $ tlsourcepos o+                emptyname = tlaccount o == ""+                (first, rest) = case uncons activeins of+                    Just (hd, tl) -> (hd, tl)+                    Nothing -> error' errmsg+                errmsg =+                    printf+                      "%s:\n%s\n%s\n\nCould not find previous clockin to match this clockout."+                      (sourcePosPretty $ tlsourcepos o)+                      (l ++ " | " ++ show o)+                      (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")++errorExpectedCodeButGot :: TimeclockCode -> TimeclockEntry -> a+errorExpectedCodeButGot expected actual = error' $ printf+  ("%s:\n%s\n%s\n\nExpected a timeclock %s entry but got %s.\n"+  ++"Please alternate i and o, beginning with i.")+  (sourcePosPretty $ tlsourcepos actual)+  (l ++ " | " ++ show actual)+  (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")+  (show expected)+  (show $ tlcode actual)+  where+    l = show $ unPos $ sourceLine $ tlsourcepos actual+    c = unPos $ sourceColumn $ tlsourcepos actual++makeTimeClockErrorExcerpt :: TimeclockEntry -> T.Text -> T.Text+makeTimeClockErrorExcerpt e@TimeclockEntry{tlsourcepos=pos} msg = T.unlines [+  T.pack (sourcePosPretty pos) <> ":"+  ,l <> " | " <> T.pack (show e)+  -- ,T.replicate (T.length l) " " <> " |" -- <> T.replicate c " " <> "^")+  ] <> msg+  where+    l = T.pack $ show $ unPos $ sourceLine $ tlsourcepos e+    -- c = unPos $ sourceColumn $ tlsourcepos e+ -- | Convert a timeclock clockin and clockout entry to an equivalent journal -- transaction, representing the time expenditure. Note this entry is  not balanced, -- since we omit the \"assets:time\" transaction for simpler output.-entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction-entryFromTimeclockInOut i o-    | otime >= itime = t+entryFromTimeclockInOut :: Bool -> TimeclockEntry -> TimeclockEntry -> Transaction+entryFromTimeclockInOut requiretimeordered i o+    | not requiretimeordered || otime >= itime = t     | otherwise =-        error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t+      -- Clockout time earlier than clockin is an error.+      -- (Clockin earlier than preceding clockin/clockout is allowed.)+      -- We should never encounter this case now that we sort the entries,+      -- but let's leave it in case of error.+      error' $ printf+        ("%s:\n%s\nThis clockout time (%s) is earlier than the previous clockin.\n"+        ++"Please adjust it to be later than %s.")+        (sourcePosPretty $ tlsourcepos o)+        (unlines [+          replicate (length l) ' '++ " | " ++ show i,+          l ++ " | " ++ show o,+          (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ replicate 19 '^')+          ])+        (show $ tldatetime o)+        (show $ tldatetime i)     where+      l = show $ unPos $ sourceLine $ tlsourcepos o+      c = (unPos $ sourceColumn $ tlsourcepos o) + 2       t = Transaction {             tindex       = 0,-            tsourcepos   = tlsourcepos i,+            tsourcepos   = (tlsourcepos i, tlsourcepos i),             tdate        = idate,             tdate2       = Nothing,             tstatus      = Cleared,             tcode        = "",             tdescription = desc,-            tcomment     = "",-            ttags        = [],+            tcomment     = tlcomment i <> tlcomment o,+            ttags        = tltags i ++ tltags o,             tpostings    = ps,             tprecedingcomment=""           }@@ -108,39 +252,54 @@       showtime = take 5 . show       hours    = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc       acctname = tlaccount i-      amount   = Mixed [hrs hours]-      ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]+      -- Generate an hours amount. Unusually, we also round the internal Decimal value,+      -- since otherwise it will often have large recurring decimal parts which (since 1.21)+      -- print would display all 255 digits of. timeclock amounts have one second resolution,+      -- so two decimal places is precise enough (#1527).+      amt = case mixedAmount $ setAmountInternalPrecision 2 $ hrs hours of+        a | not $ a < 0 -> a+        _ -> error' $ printf+          "%s%s:\nThis clockout is earlier than the clockin."+          (makeTimeClockErrorExcerpt i "")+          (makeTimeClockErrorExcerpt o "")+      ps = [posting{paccount=acctname, pamount=amt, ptype=VirtualPosting, ptransaction=Just t}]   -- tests -tests_Timeclock = tests "Timeclock" [-  do-   today <- io getCurrentDay-   now' <- io getCurrentTime-   tz <- io getCurrentTimeZone-   let now = utcToLocalTime tz now'-       nowstr = showtime now-       yesterday = prevday today-       clockin = TimeclockEntry nullsourcepos In-       mktime d = LocalTime d . fromMaybe midnight .-#if MIN_VERSION_time(1,5,0)-                  parseTimeM True defaultTimeLocale "%H:%M:%S"-#else-                  parseTime defaultTimeLocale "%H:%M:%S"-#endif-       showtime = formatTime defaultTimeLocale "%H:%M"-       txndescs = map (T.unpack . tdescription) . timeclockEntriesToTransactions now -       future = utcToLocalTime tz $ addUTCTime 100 now'-       futurestr = showtime future-   tests "timeclockEntriesToTransactions" [ -     test "started yesterday, split session at midnight" $-      txndescs [clockin (mktime yesterday "23:00:00") "" ""] `is` ["23:00-23:59","00:00-"++nowstr]-     ,test "split multi-day sessions at each midnight" $-      txndescs [clockin (mktime (addDays (-2) today) "23:00:00") "" ""] `is `["23:00-23:59","00:00-23:59","00:00-"++nowstr]-     ,test "auto-clock-out if needed" $-      txndescs [clockin (mktime today "00:00:00") "" ""] `is` ["00:00-"++nowstr]-     ,test "use the clockin time for auto-clockout if it's in the future" $-      txndescs [clockin future "" ""] `is` [printf "%s-%s" futurestr futurestr]-     ]+tests_Timeclock = testGroup "Timeclock" [+  testCaseSteps "timeclockToTransactions tests" $ \step -> do+      step "gathering data"+      today <- getCurrentDay+      now' <- getCurrentTime+      tz <- getCurrentTimeZone+      let now = utcToLocalTime tz now'+          nowstr = showtime now+          yesterday = prevday today+          clockin = TimeclockEntry (initialPos "") In+          clockout = TimeclockEntry (initialPos "") Out+          mktime d = LocalTime d . fromMaybe midnight .+                     parseTimeM True defaultTimeLocale "%H:%M:%S"+          showtime = formatTime defaultTimeLocale "%H:%M"+          txndescs = map (T.unpack . tdescription) . timeclockToTransactions now+          future = utcToLocalTime tz $ addUTCTime 100 now'+          futurestr = showtime future+      step "started yesterday, split session at midnight"+      txndescs [clockin (mktime yesterday "23:00:00") "" "" "" []] @?= ["23:00-23:59","00:00-"++nowstr]+      step "split multi-day sessions at each midnight"+      txndescs [clockin (mktime (addDays (-2) today) "23:00:00") "" "" "" []] @?= ["23:00-23:59","00:00-23:59","00:00-"++nowstr]+      step "auto-clock-out if needed"+      txndescs [clockin (mktime today "00:00:00") "" "" "" []] @?= ["00:00-"++nowstr]+      step "use the clockin time for auto-clockout if it's in the future"+      txndescs [clockin future "" "" "" []] @?= [printf "%s-%s" futurestr futurestr]+      step "multiple open sessions"+      txndescs (reverse [+        clockin (mktime today "00:00:00") "a" "" "" [],+        clockin (mktime today "01:00:00") "b" "" "" [],+        clockin (mktime today "02:00:00") "c" "" "" [],+        clockout (mktime today "03:00:00") "b" "" "" [],+        clockout (mktime today "04:00:00") "a" "" "" [],+        clockout (mktime today "05:00:00") "c" "" "" []+        ])+        @?= ["00:00-04:00", "01:00-03:00", "02:00-05:00"]  ]
Hledger/Data/Transaction.hs view
@@ -7,1009 +7,709 @@  -} -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}--module Hledger.Data.Transaction (-  -- * Transaction-  nulltransaction,-  transaction,-  txnTieKnot,-  txnUntieKnot,-  -- * operations-  showAccountName,-  hasRealPostings,-  realPostings,-  assignmentPostings,-  virtualPostings,-  balancedVirtualPostings,-  transactionsPostings,-  isTransactionBalanced,-  balanceTransaction,-  balanceTransactionHelper,-  -- nonzerobalanceerror,-  -- * date operations-  transactionDate2,-  -- * arithmetic-  transactionPostingBalances,-  -- * rendering-  showTransaction,-  showTransactionUnelided,-  showTransactionUnelidedOneLineAmounts,-  -- showPostingLine,-  showPostingLines,-  -- * GenericSourcePos-  sourceFilePath,-  sourceFirstLine,-  showGenericSourcePos,-  annotateErrorWithTransaction,-  -- * tests-  tests_Transaction-)-where-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar-import Text.Printf-import qualified Data.Map as Map--import Hledger.Utils -import Hledger.Data.Types-import Hledger.Data.Dates-import Hledger.Data.Posting-import Hledger.Data.Amount--sourceFilePath :: GenericSourcePos -> FilePath-sourceFilePath = \case-    GenericSourcePos fp _ _ -> fp-    JournalSourcePos fp _ -> fp--sourceFirstLine :: GenericSourcePos -> Int-sourceFirstLine = \case-    GenericSourcePos _ line _ -> line-    JournalSourcePos _ (line, _) -> line---- | Render source position in human-readable form.--- Keep in sync with Hledger.UI.ErrorScreen.hledgerparseerrorpositionp (temporary). XXX-showGenericSourcePos :: GenericSourcePos -> String-showGenericSourcePos = \case-    GenericSourcePos fp line column -> show fp ++ " (line " ++ show line ++ ", column " ++ show column ++ ")"-    JournalSourcePos fp (line, line') -> show fp ++ " (lines " ++ show line ++ "-" ++ show line' ++ ")"--nulltransaction :: Transaction-nulltransaction = Transaction {-                    tindex=0,-                    tsourcepos=nullsourcepos,-                    tdate=nulldate,-                    tdate2=Nothing,-                    tstatus=Unmarked,-                    tcode="",-                    tdescription="",-                    tcomment="",-                    ttags=[],-                    tpostings=[],-                    tprecedingcomment=""-                  }---- | Make a simple transaction with the given date and postings.-transaction :: String -> [Posting] -> Transaction -transaction datestr ps = txnTieKnot $ nulltransaction{tdate=parsedate datestr, tpostings=ps}--{-|-Render a journal transaction as text in the style of Ledger's print command. --Ledger 2.x's standard format looks like this:--@-yyyy/mm/dd[ *][ CODE] description.........          [  ; comment...............]-    account name 1.....................  ...$amount1[  ; comment...............]-    account name 2.....................  ..$-amount1[  ; comment...............]--pcodewidth    = no limit -- 10          -- mimicking ledger layout.-pdescwidth    = no limit -- 20          -- I don't remember what these mean,-pacctwidth    = 35 minimum, no maximum  -- they were important at the time.-pamtwidth     = 11-pcommentwidth = no limit -- 22-@--The output will be parseable journal syntax.-To facilitate this, postings with explicit multi-commodity amounts -are displayed as multiple similar postings, one per commodity.-(Normally does not happen with this function).--If there are multiple postings, all with explicit amounts,-and the transaction appears obviously balanced-(postings sum to 0, without needing to infer conversion prices),-the last posting's amount will not be shown.--}--- XXX why that logic ? --- XXX where is/should this be still used ? --- XXX rename these, after amount expressions/mixed posting amounts lands---     eg showTransactionSimpleAmountsElidingLast, showTransactionSimpleAmounts, showTransaction-showTransaction :: Transaction -> String-showTransaction = showTransactionHelper True False---- | Like showTransaction, but does not change amounts' explicitness.--- Explicit amounts are shown and implicit amounts are not.--- The output will be parseable journal syntax.--- To facilitate this, postings with explicit multi-commodity amounts --- are displayed as multiple similar postings, one per commodity.--- Most often, this is the one you want to use.-showTransactionUnelided :: Transaction -> String-showTransactionUnelided = showTransactionHelper False False---- | Like showTransactionUnelided, but explicit multi-commodity amounts --- are shown on one line, comma-separated. In this case the output will --- not be parseable journal syntax.-showTransactionUnelidedOneLineAmounts :: Transaction -> String-showTransactionUnelidedOneLineAmounts = showTransactionHelper False True---- | Helper for showTransaction*. -showTransactionHelper :: Bool -> Bool -> Transaction -> String-showTransactionHelper elide onelineamounts t =-    unlines $ [descriptionline]-              ++ newlinecomments-              ++ (postingsAsLines elide onelineamounts t (tpostings t))-              ++ [""]-    where-      descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment]-      date = showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t)-      status | tstatus t == Cleared = " *"-             | tstatus t == Pending = " !"-             | otherwise            = ""-      code = if T.length (tcode t) > 0 then printf " (%s)" $ T.unpack $ tcode t else ""-      desc = if null d then "" else " " ++ d where d = T.unpack $ tdescription t-      (samelinecomment, newlinecomments) =-        case renderCommentLines (tcomment t) of []   -> ("",[])-                                                c:cs -> (c,cs)---- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines.-renderCommentLines :: Text -> [String]-renderCommentLines t  = case lines $ T.unpack t of ("":ls) -> "":map commentprefix ls-                                                   ls      -> map commentprefix ls-    where-      commentprefix = indent . ("; "++)---- | Given a transaction and its postings, render the postings, suitable--- for `print` output. Normally this output will be valid journal syntax which--- hledger can reparse (though it may include no-longer-valid balance assertions).------ Explicit amounts are shown, any implicit amounts are not. ------ Setting elide to true forces the last posting's amount to be implicit, if:--- there are other postings, all with explicit amounts, and the transaction--- appears balanced.------ Postings with multicommodity explicit amounts are handled as follows:--- if onelineamounts is true, these amounts are shown on one line,--- comma-separated, and the output will not be valid journal syntax.--- Otherwise, they are shown as several similar postings, one per commodity.--- --- The output will appear to be a balanced transaction.--- Amounts' display precisions, which may have been limited by commodity--- directives, will be increased if necessary to ensure this.------ Posting amounts will be aligned with each other, starting about 4 columns--- beyond the widest account name (see postingAsLines for details).--- -postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String]-postingsAsLines elide onelineamounts t ps-  | elide && length ps > 1 && all hasAmount ps && isTransactionBalanced Nothing t -- imprecise balanced check-   = concatMap (postingAsLines False onelineamounts ps) (init ps) ++ postingAsLines True onelineamounts ps (last ps)-  | otherwise = concatMap (postingAsLines False onelineamounts ps) ps---- | Render one posting, on one or more lines, suitable for `print` output.  --- There will be an indented account name, plus one or more of status flag,--- posting amount, balance assertion, same-line comment, next-line comments.--- --- If the posting's amount is implicit or if elideamount is true, no amount is shown.------ If the posting's amount is explicit and multi-commodity, multiple similar --- postings are shown, one for each commodity, to help produce parseable journal syntax.--- Or if onelineamounts is true, such amounts are shown on one line, comma-separated--- (and the output will not be valid journal syntax).------ By default, 4 spaces (2 if there's a status flag) are shown between --- account name and start of amount area, which is typically 12 chars wide--- and contains a right-aligned amount (so 10-12 visible spaces between --- account name and amount is typical).--- When given a list of postings to be aligned with, the whitespace will be --- increased if needed to match the posting with the longest account name.--- This is used to align the amounts of a transaction's postings.----postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [String]-postingAsLines elideamount onelineamounts pstoalignwith p = concat [-    postingblock-    ++ newlinecomments-    | postingblock <- postingblocks]-  where-    postingblocks = [map rstrip $ lines $ concatTopPadded [statusandaccount, "  ", amount, assertion, samelinecomment] | amount <- shownAmounts]-    assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p -    statusandaccount = indent $ fitString (Just $ minwidth) Nothing False True $ pstatusandacct p-        where-          -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned  -          minwidth = maximum $ map ((2+) . textWidth . T.pack . pacctstr) pstoalignwith-          pstatusandacct p' = pstatusprefix p' ++ pacctstr p'-          pstatusprefix p' | null s    = ""-                           | otherwise = s ++ " "-            where s = show $ pstatus p'-          pacctstr p' = showAccountName Nothing (ptype p') (paccount p')--    -- currently prices are considered part of the amount string when right-aligning amounts-    shownAmounts-      | elideamount    = [""]-      | onelineamounts = [fitString (Just amtwidth) Nothing False False $ showMixedAmountOneLine $ pamount p]-      | null (amounts $ pamount p) = [""]-      | otherwise      = map (fitStringMulti (Just amtwidth) Nothing False False . showAmount ) . amounts $ pamount p-      where-        amtwidth = maximum $ 12 : map (strWidth . showMixedAmount . pamount) pstoalignwith  -- min. 12 for backwards compatibility--    (samelinecomment, newlinecomments) =-      case renderCommentLines (pcomment p) of []   -> ("",[])-                                              c:cs -> (c,cs)---- | Render a balance assertion, as the =[=][*] symbol and expected amount. -showBalanceAssertion BalanceAssertion{..} = -  "=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount---- | Render a posting, simply. Used in balance assertion errors.--- showPostingLine p =---   indent $---   if pstatus p == Cleared then "* " else "" ++  -- XXX show !---   showAccountName Nothing (ptype p) (paccount p) ++---   "    " ++---   showMixedAmountOneLine (pamount p) ++---   assertion---   where---     -- XXX extract, handle ==---     assertion = maybe "" ((" = " ++) . showAmountWithZeroCommodity . baamount) $ pbalanceassertion p---- | Render a posting, at the appropriate width for aligning with--- its siblings if any. Used by the rewrite command. -showPostingLines :: Posting -> [String]-showPostingLines p = postingAsLines False False ps p where-    ps | Just t <- ptransaction p = tpostings t-       | otherwise = [p]--indent :: String -> String-indent = ("    "++)---- | Show an account name, clipped to the given width if any, and--- appropriately bracketed/parenthesised for the given posting type.-showAccountName :: Maybe Int -> PostingType -> AccountName -> String-showAccountName w = fmt-    where-      fmt RegularPosting = take w' . T.unpack-      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse . T.unpack-      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse . T.unpack-      w' = fromMaybe 999999 w--parenthesise :: String -> String-parenthesise s = "("++s++")"--bracket :: String -> String-bracket s = "["++s++"]"--hasRealPostings :: Transaction -> Bool-hasRealPostings = not . null . realPostings--realPostings :: Transaction -> [Posting]-realPostings = filter isReal . tpostings--assignmentPostings :: Transaction -> [Posting]-assignmentPostings = filter hasBalanceAssignment . tpostings--virtualPostings :: Transaction -> [Posting]-virtualPostings = filter isVirtual . tpostings--balancedVirtualPostings :: Transaction -> [Posting]-balancedVirtualPostings = filter isBalancedVirtual . tpostings--transactionsPostings :: [Transaction] -> [Posting]-transactionsPostings = concatMap tpostings---- | Get the sums of a transaction's real, virtual, and balanced virtual postings.-transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount)-transactionPostingBalances t = (sumPostings $ realPostings t-                               ,sumPostings $ virtualPostings t-                               ,sumPostings $ balancedVirtualPostings t)---- | Does this transaction appear balanced when rendered, optionally with the--- given commodity display styles ? More precisely:--- after converting amounts to cost using explicit transaction prices if any;--- and summing the real postings, and summing the balanced virtual postings;--- and applying the given display styles if any (maybe affecting decimal places);--- do both totals appear to be zero when rendered ?-isTransactionBalanced :: Maybe (Map.Map CommoditySymbol AmountStyle) -> Transaction -> Bool-isTransactionBalanced styles t =-    -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum-    isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'-    where-      (rsum, _, bvsum) = transactionPostingBalances t-      rsum'  = canonicalise $ costOfMixedAmount rsum-      bvsum' = canonicalise $ costOfMixedAmount bvsum-      canonicalise = maybe id canonicaliseMixedAmount styles---- | Balance this transaction, ensuring that its postings --- (and its balanced virtual postings) sum to 0,--- by inferring a missing amount or conversion price(s) if needed. --- Or if balancing is not possible, because the amounts don't sum to 0 or--- because there's more than one missing amount, return an error message.------ Transactions with balance assignments can have more than one--- missing amount; to balance those you should use the more powerful  --- journalBalanceTransactions.------ The "sum to 0" test is done using commodity display precisions,--- if provided, so that the result agrees with the numbers users can see.----balanceTransaction ::-     Maybe (Map.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles-  -> Transaction-  -> Either String Transaction-balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles ---- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;--- use one of those instead. It also returns a list of accounts --- and amounts that were inferred.-balanceTransactionHelper ::-     Maybe (Map.Map CommoditySymbol AmountStyle)  -- ^ commodity display styles-  -> Transaction-  -> Either String (Transaction, [(AccountName, MixedAmount)])-balanceTransactionHelper mstyles t = do-  (t', inferredamtsandaccts) <- -    inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t -  if isTransactionBalanced mstyles t'-  then Right (txnTieKnot t', inferredamtsandaccts)-  else Left $ annotateErrorWithTransaction t' $ nonzerobalanceerror t'--  where-    nonzerobalanceerror :: Transaction -> String-    nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg-        where-          (rsum, _, bvsum) = transactionPostingBalances t-          rmsg | isReallyZeroMixedAmountCost rsum = ""-               | otherwise = "real postings are off by "-                 ++ showMixedAmount (costOfMixedAmount rsum)-          bvmsg | isReallyZeroMixedAmountCost bvsum = ""-                | otherwise = "balanced virtual postings are off by "-                  ++ showMixedAmount (costOfMixedAmount bvsum)-          sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String--annotateErrorWithTransaction :: Transaction -> String -> String-annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]    ---- | Infer up to one missing amount for this transactions's real postings, and--- likewise for its balanced virtual postings, if needed; or return an error--- message if we can't. Returns the updated transaction and any inferred posting amounts,--- with the corresponding accounts, in order).------ We can infer a missing amount when there are multiple postings and exactly--- one of them is amountless. If the amounts had price(s) the inferred amount--- have the same price(s), and will be converted to the price commodity.-inferBalancingAmount :: -     Map.Map CommoditySymbol AmountStyle -- ^ commodity display styles-  -> Transaction-  -> Either String (Transaction, [(AccountName, MixedAmount)])-inferBalancingAmount styles t@Transaction{tpostings=ps}-  | length amountlessrealps > 1-      = Left $ annotateErrorWithTransaction t "could not balance this transaction - can't have more than one real posting with no amount (remember to put 2 or more spaces before amounts)"-  | length amountlessbvps > 1-      = Left $ annotateErrorWithTransaction t "could not balance this transaction - can't have more than one balanced virtual posting with no amount (remember to put 2 or more spaces before amounts)"-  | otherwise-      = let psandinferredamts = map inferamount ps-            inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts]-        in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts)-  where-    (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t)-    realsum = sumStrict $ map pamount amountfulrealps-    (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t)-    bvsum = sumStrict $ map pamount amountfulbvps--    inferamount :: Posting -> (Posting, Maybe MixedAmount)-    inferamount p =-      let-        minferredamt = case ptype p of-          RegularPosting         | not (hasAmount p) -> Just realsum -          BalancedVirtualPosting | not (hasAmount p) -> Just bvsum -          _                                          -> Nothing -      in-        case minferredamt of-          Nothing -> (p, Nothing)-          Just a  -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a') -            where-              -- Inferred amounts are converted to cost.-              -- Also ensure the new amount has the standard style for its commodity  -              -- (since the main amount styling pass happened before this balancing pass);-              a' = styleMixedAmount styles $ normaliseMixedAmount $ costOfMixedAmount (-a)---- | Infer prices for this transaction's posting amounts, if needed to make--- the postings balance, and if possible. This is done once for the real--- postings and again (separately) for the balanced virtual postings. When--- it's not possible, the transaction is left unchanged.------ The simplest example is a transaction with two postings, each in a--- different commodity, with no prices specified. In this case we'll add a--- price to the first posting such that it can be converted to the commodity--- of the second posting (with -B), and such that the postings balance.------ In general, we can infer a conversion price when the sum of posting amounts--- contains exactly two different commodities and no explicit prices.  Also--- all postings are expected to contain an explicit amount (no missing--- amounts) in a single commodity. Otherwise no price inferring is attempted.------ The transaction itself could contain more than two commodities, and/or--- prices, if they cancel out; what matters is that the sum of posting amounts--- contains exactly two commodities and zero prices.------ There can also be more than two postings in either of the commodities.------ We want to avoid excessive display of digits when the calculated price is--- an irrational number, while hopefully also ensuring the displayed numbers--- make sense if the user does a manual calculation. This is (mostly) achieved--- in two ways:------ - when there is only one posting in the "from" commodity, a total price---   (@@) is used, and all available decimal digits are shown------ - otherwise, a suitable averaged unit price (@) is applied to the relevant---   postings, with display precision equal to the summed display precisions---   of the two commodities being converted between, or 2, whichever is larger.------ (We don't always calculate a good-looking display precision for unit prices--- when the commodity display precisions are low, eg when a journal doesn't--- use any decimal places. The minimum of 2 helps make the prices shown by the--- print command a bit less surprising in this case. Could do better.)----inferBalancingPrices :: Transaction -> Transaction-inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'}-  where-    ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps---- | Generate a posting update function which assigns a suitable balancing--- price to the posting, if and as appropriate for the given transaction and--- posting type (real or balanced virtual).-priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting)-priceInferrerFor t pt = inferprice-  where-    postings       = filter ((==pt).ptype) $ tpostings t-    pmixedamounts  = map pamount postings-    pamounts       = concatMap amounts pmixedamounts-    pcommodities   = map acommodity pamounts-    sumamounts     = amounts $ sumStrict pmixedamounts -- sum normalises to one amount per commodity & price-    sumcommodities = map acommodity sumamounts-    sumprices      = filter (/=NoPrice) $ map aprice sumamounts-    caninferprices = length sumcommodities == 2 && null sumprices--    inferprice p@Posting{pamount=Mixed [a]}-      | caninferprices && ptype p == pt && acommodity a == fromcommodity-        = p{pamount=Mixed [a{aprice=conversionprice}], poriginal=Just $ originalPosting p}-      where-        fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe-        conversionprice-          | fromcount==1 = TotalPrice $ abs toamount `withPrecision` maxprecision-          | otherwise    = UnitPrice $ abs unitprice `withPrecision` unitprecision-          where-            fromcount     = length $ filter ((==fromcommodity).acommodity) pamounts-            fromamount    = head $ filter ((==fromcommodity).acommodity) sumamounts-            tocommodity   = head $ filter (/=fromcommodity) sumcommodities-            toamount      = head $ filter ((==tocommodity).acommodity) sumamounts-            unitprice     = (aquantity fromamount) `divideAmount` toamount-            unitprecision = max 2 (asprecision (astyle toamount) + asprecision (astyle fromamount))-    inferprice p = p---- Get a transaction's secondary date, defaulting to the primary date.-transactionDate2 :: Transaction -> Day-transactionDate2 t = fromMaybe (tdate t) $ tdate2 t---- | Ensure a transaction's postings refer back to it, so that eg--- relatedPostings works right.-txnTieKnot :: Transaction -> Transaction-txnTieKnot t@Transaction{tpostings=ps} = t' where-    t' = t{tpostings=map (postingSetTransaction t') ps}---- | Ensure a transaction's postings do not refer back to it, so that eg--- recursiveSize and GHCI's :sprint work right.-txnUntieKnot :: Transaction -> Transaction-txnUntieKnot t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}---- | Set a posting's parent transaction.-postingSetTransaction :: Transaction -> Posting -> Posting-postingSetTransaction t p = p{ptransaction=Just t}---- tests--tests_Transaction =-  tests-    "Transaction"-    [ tests-        "showTransactionUnelided"-        [ showTransactionUnelided nulltransaction `is` "0000/01/01\n\n"-        , showTransactionUnelided-            nulltransaction-              { tdate = parsedate "2012/05/14"-              , tdate2 = Just $ parsedate "2012/05/15"-              , tstatus = Unmarked-              , tcode = "code"-              , tdescription = "desc"-              , tcomment = "tcomment1\ntcomment2\n"-              , ttags = [("ttag1", "val1")]-              , tpostings =-                  [ nullposting-                      { pstatus = Cleared-                      , paccount = "a"-                      , pamount = Mixed [usd 1, hrs 2]-                      , pcomment = "\npcomment2\n"-                      , ptype = RegularPosting-                      , ptags = [("ptag1", "val1"), ("ptag2", "val2")]-                      }-                  ]-              } `is`-          unlines-            [ "2012/05/14=2012/05/15 (code) desc    ; tcomment1"-            , "    ; tcomment2"-            , "    * a         $1.00"-            , "    ; pcomment2"-            , "    * a         2.00h"-            , "    ; pcomment2"-            , ""-            ]-        ]-    , tests-        "postingAsLines"-        [ postingAsLines False False [posting] posting `is` [""]-        , let p =-                posting-                  { pstatus = Cleared-                  , paccount = "a"-                  , pamount = Mixed [usd 1, hrs 2]-                  , pcomment = "pcomment1\npcomment2\n  tag3: val3  \n"-                  , ptype = RegularPosting-                  , ptags = [("ptag1", "val1"), ("ptag2", "val2")]-                  }-           in postingAsLines False False [p] p `is`-              [ "    * a         $1.00    ; pcomment1"-              , "    ; pcomment2"-              , "    ;   tag3: val3  "-              , "    * a         2.00h    ; pcomment1"-              , "    ; pcomment2"-              , "    ;   tag3: val3  "-              ]-        ]-   -- postingsAsLines-    -- one implicit amount -    , let timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]}-    -- explicit amounts, balanced-          texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]}-    -- explicit amount, only one posting-          texp1 = nulltransaction {tpostings = ["(a)" `post` usd 1]}-    -- explicit amounts, two commodities, explicit balancing price-          texp2 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` (hrs (-1) `at` usd 1)]}-    -- explicit amounts, two commodities, implicit balancing price-          texp2b = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` hrs (-1)]}-    -- one missing amount, not the last one-          t3 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt, "c" `post` usd (-1)]}-    -- unbalanced amounts when precision is limited (#931)-          t4 = nulltransaction {tpostings = ["a" `post` usd (-0.01), "b" `post` usd (0.005), "c" `post` usd (0.005)]}-       in tests-            "postingsAsLines"-            [ test "null-transaction" $-              let t = nulltransaction-               in postingsAsLines True False t (tpostings t) `is` []-            , test "implicit-amount-elide-false" $-              let t = timp-               in postingsAsLines False False t (tpostings t) `is`-                  [ "    a           $1.00"-                  , "    b" -- implicit amount remains implicit-                  ]-            , test "implicit-amount-elide-true" $-              let t = timp-               in postingsAsLines True False t (tpostings t) `is`-                  [ "    a           $1.00"-                  , "    b" -- implicit amount remains implicit-                  ]-            , test "explicit-amounts-elide-false" $-              let t = texp-               in postingsAsLines False False t (tpostings t) `is`-                  [ "    a           $1.00"-                  , "    b          $-1.00" -- both amounts remain explicit-                  ]-            , test "explicit-amounts-elide-true" $-              let t = texp-               in postingsAsLines True False t (tpostings t) `is`-                  [ "    a           $1.00"-                  , "    b" -- explicit amount is made implicit-                  ]-            , test "one-explicit-amount-elide-true" $-              let t = texp1-               in postingsAsLines True False t (tpostings t) `is`-                  [ "    (a)           $1.00" -- explicit amount remains explicit since only one posting -                  ]-            , test "explicit-amounts-two-commodities-elide-true" $-              let t = texp2-               in postingsAsLines True False t (tpostings t) `is`-                  [ "    a             $1.00"-                  , "    b" -- explicit amount is made implicit since txn is explicitly balanced-                  ]-            , test "explicit-amounts-not-explicitly-balanced-elide-true" $-              let t = texp2b-               in postingsAsLines True False t (tpostings t) `is`-                  [ "    a           $1.00"-                  , "    b          -1.00h" -- explicit amount remains explicit since a conversion price would have be inferred to balance-                  ]-            , test "implicit-amount-not-last" $-              let t = t3-               in postingsAsLines True False t (tpostings t) `is`-                  ["    a           $1.00", "    b", "    c          $-1.00"]-            , _test "ensure-visibly-balanced" $-              let t = t4-               in postingsAsLines False False t (tpostings t) `is`-                  ["    a          $-0.01", "    b           $0.005", "    c           $0.005"]-            ]-    , tests-         "inferBalancingAmount"-         [ (fst <$> inferBalancingAmount Map.empty nulltransaction) `is` Right nulltransaction-         , (fst <$> inferBalancingAmount Map.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) `is`-           Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]}-         , (fst <$> inferBalancingAmount Map.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) `is`-           Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}-         ]-    , tests-        "showTransaction"-        [ test "show a balanced transaction, eliding last amount" $-          let t =-                Transaction-                  0-                  ""-                  nullsourcepos-                  (parsedate "2007/01/28")-                  Nothing-                  Unmarked-                  ""-                  "coopportunity"-                  ""-                  []-                  [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18], ptransaction = Just t}-                  , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t}-                  ]-           in showTransaction t `is`-              unlines-                ["2007/01/28 coopportunity", "    expenses:food:groceries          $47.18", "    assets:checking", ""]-        , test "show a balanced transaction, no eliding" $-          (let t =-                 Transaction-                   0-                   ""-                   nullsourcepos-                   (parsedate "2007/01/28")-                   Nothing-                   Unmarked-                   ""-                   "coopportunity"-                   ""-                   []-                   [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18], ptransaction = Just t}-                   , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t}-                   ]-            in showTransactionUnelided t) `is`-          (unlines-             [ "2007/01/28 coopportunity"-             , "    expenses:food:groceries          $47.18"-             , "    assets:checking                 $-47.18"-             , ""-             ])-     -- document some cases that arise in debug/testing:-        , test "show an unbalanced transaction, should not elide" $-          (showTransaction-             (txnTieKnot $-              Transaction-                0-                ""-                nullsourcepos-                (parsedate "2007/01/28")-                Nothing-                Unmarked-                ""-                "coopportunity"-                ""-                []-                [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]}-                , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]}-                ])) `is`-          (unlines-             [ "2007/01/28 coopportunity"-             , "    expenses:food:groceries          $47.18"-             , "    assets:checking                 $-47.19"-             , ""-             ])-        , test "show an unbalanced transaction with one posting, should not elide" $-          (showTransaction-             (txnTieKnot $-              Transaction-                0-                ""-                nullsourcepos-                (parsedate "2007/01/28")-                Nothing-                Unmarked-                ""-                "coopportunity"-                ""-                []-                [posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]}])) `is`-          (unlines ["2007/01/28 coopportunity", "    expenses:food:groceries          $47.18", ""])-        , test "show a transaction with one posting and a missing amount" $-          (showTransaction-             (txnTieKnot $-              Transaction-                0-                ""-                nullsourcepos-                (parsedate "2007/01/28")-                Nothing-                Unmarked-                ""-                "coopportunity"-                ""-                []-                [posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) `is`-          (unlines ["2007/01/28 coopportunity", "    expenses:food:groceries", ""])-        , test "show a transaction with a priced commodityless amount" $-          (showTransaction-             (txnTieKnot $-              Transaction-                0-                ""-                nullsourcepos-                (parsedate "2010/01/01")-                Nothing-                Unmarked-                ""-                "x"-                ""-                []-                [ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}-                , posting {paccount = "b", pamount = missingmixedamt}-                ])) `is`-          (unlines ["2010/01/01 x", "    a          1 @ $2", "    b", ""])-        ]-    , tests-        "balanceTransaction"-        [ test "detect unbalanced entry, sign error" $-          expectLeft-            (balanceTransaction-               Nothing-               (Transaction-                  0-                  ""-                  nullsourcepos-                  (parsedate "2007/01/28")-                  Nothing-                  Unmarked-                  ""-                  "test"-                  ""-                  []-                  [posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = Mixed [usd 1]}]))-        , test "detect unbalanced entry, multiple missing amounts" $-          expectLeft $-             balanceTransaction-               Nothing-               (Transaction-                  0-                  ""-                  nullsourcepos-                  (parsedate "2007/01/28")-                  Nothing-                  Unmarked-                  ""-                  "test"-                  ""-                  []-                  [ posting {paccount = "a", pamount = missingmixedamt}-                  , posting {paccount = "b", pamount = missingmixedamt}-                  ])-        , test "one missing amount is inferred" $-          (pamount . last . tpostings <$>-           balanceTransaction-             Nothing-             (Transaction-                0-                ""-                nullsourcepos-                (parsedate "2007/01/28")-                Nothing-                Unmarked-                ""-                ""-                ""-                []-                [posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = missingmixedamt}])) `is`-          Right (Mixed [usd (-1)])-        , test "conversion price is inferred" $-          (pamount . head . tpostings <$>-           balanceTransaction-             Nothing-             (Transaction-                0-                ""-                nullsourcepos-                (parsedate "2007/01/28")-                Nothing-                Unmarked-                ""-                ""-                ""-                []-                [ posting {paccount = "a", pamount = Mixed [usd 1.35]}-                , posting {paccount = "b", pamount = Mixed [eur (-1)]}-                ])) `is`-          Right (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)])-        , test "balanceTransaction balances based on cost if there are unit prices" $-          expectRight $-          balanceTransaction-            Nothing-            (Transaction-               0-               ""-               nullsourcepos-               (parsedate "2011/01/01")-               Nothing-               Unmarked-               ""-               ""-               ""-               []-               [ posting {paccount = "a", pamount = Mixed [usd 1 `at` eur 2]}-               , posting {paccount = "a", pamount = Mixed [usd (-2) `at` eur 1]}-               ])-        , test "balanceTransaction balances based on cost if there are total prices" $-          expectRight $-          balanceTransaction-            Nothing-            (Transaction-               0-               ""-               nullsourcepos-               (parsedate "2011/01/01")-               Nothing-               Unmarked-               ""-               ""-               ""-               []-               [ posting {paccount = "a", pamount = Mixed [usd 1 @@ eur 1]}-               , posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur 1]}-               ])-        ]-    , tests-        "isTransactionBalanced"-        [ test "detect balanced" $-          expect $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [ posting {paccount = "b", pamount = Mixed [usd 1.00]}-            , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}-            ]-        , test "detect unbalanced" $-          expect $-          not $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [ posting {paccount = "b", pamount = Mixed [usd 1.00]}-            , posting {paccount = "c", pamount = Mixed [usd (-1.01)]}-            ]-        , test "detect unbalanced, one posting" $-          expect $-          not $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [posting {paccount = "b", pamount = Mixed [usd 1.00]}]-        , test "one zero posting is considered balanced for now" $-          expect $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [posting {paccount = "b", pamount = Mixed [usd 0]}]-        , test "virtual postings don't need to balance" $-          expect $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [ posting {paccount = "b", pamount = Mixed [usd 1.00]}-            , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}-            , posting {paccount = "d", pamount = Mixed [usd 100], ptype = VirtualPosting}-            ]-        , test "balanced virtual postings need to balance among themselves" $-          expect $-          not $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [ posting {paccount = "b", pamount = Mixed [usd 1.00]}-            , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}-            , posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting}-            ]-        , test "balanced virtual postings need to balance among themselves (2)" $-          expect $-          isTransactionBalanced Nothing $-          Transaction-            0-            ""-            nullsourcepos-            (parsedate "2009/01/01")-            Nothing-            Unmarked-            ""-            "a"-            ""-            []-            [ posting {paccount = "b", pamount = Mixed [usd 1.00]}-            , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}-            , posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting}-            , posting {paccount = "3", pamount = Mixed [usd (-100)], ptype = BalancedVirtualPosting}-            ]+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.Transaction+( -- * Transaction+  nulltransaction+, transaction+, txnTieKnot+, txnUntieKnot+  -- * operations+, hasRealPostings+, realPostings+, assignmentPostings+, virtualPostings+, balancedVirtualPostings+, transactionsPostings+, transactionTransformPostings+, transactionApplyValuation+, transactionToCost+, transactionInferEquityPostings+, transactionTagCostsAndEquityAndMaybeInferCosts+, transactionApplyAliases+, transactionMapPostings+, transactionMapPostingAmounts+, transactionAmounts+, transactionCommodityStyles+, transactionCommodityStylesWith+, transactionNegate+, partitionAndCheckConversionPostings+, transactionAddTags+, transactionAddHiddenAndMaybeVisibleTag+  -- * helpers+, TransactionBalancingPrecision(..)+, payeeAndNoteFromDescription+, payeeAndNoteFromDescription'+  -- nonzerobalanceerror+  -- * date operations+, transactionDate2+, transactionDateOrDate2+  -- * transaction description parts+, transactionPayee+, transactionNote+  -- payeeAndNoteFromDescription+  -- * rendering+, showTransaction+, showTransactionOneLineAmounts+, showTransactionLineFirstPart+, transactionFile+  -- * transaction errors+, annotateErrorWithTransaction+  -- * tests+, tests_Transaction+) where++import Control.Monad.Trans.State (StateT(..), evalStateT)+import Data.Bifunctor (first, second)+import Data.Foldable (foldlM)+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Semigroup (Endo(..))+import Data.Text (Text)+import Data.Map qualified as M+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Time.Calendar (Day, fromGregorian)++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.Dates+import Hledger.Data.Posting+import Hledger.Data.Amount+import Hledger.Data.Valuation+import Data.Decimal (normalizeDecimal, decimalPlaces)+import Data.Functor ((<&>))+import Data.Function ((&))+import Data.List (union)+++-- | How to determine the precision used for checking that transactions are balanced. See #2402.+data TransactionBalancingPrecision =+    TBPOld+    -- ^ Legacy behaviour, as in hledger <1.50, included to ease upgrades.+    -- use precision inferred from the whole journal, overridable by commodity directive or -c.+    -- Display precision is also transaction balancing precision; increasing it can break journal reading.+    -- Some valid journals are rejected until commodity directives are added.+    -- Small unbalanced remainders can be hidden, and in accounts that are never reconciled, can accumulate over time.+  | TBPExact+    -- ^ Simpler, more robust behaviour, as in Ledger: use precision inferred from the transaction.+    -- Display precision and transaction balancing precision are independent; display precision never affects journal reading.+    -- Valid journals from ledger or beancount are accepted without needing commodity directives.+    -- Every imbalance in a transaction is visibly accounted for in that transaction's journal entry.++  deriving (Bounded, Enum, Eq, Ord, Read, Show)++instance HasAmounts Transaction where+  styleAmounts styles t = t{tpostings=styleAmounts styles $ tpostings t}++nulltransaction :: Transaction+nulltransaction = Transaction {+                    tindex=0,+                    tsourcepos=nullsourcepospair,+                    tdate=nulldate,+                    tdate2=Nothing,+                    tstatus=Unmarked,+                    tcode="",+                    tdescription="",+                    tcomment="",+                    ttags=[],+                    tpostings=[],+                    tprecedingcomment=""+                  }++-- | Make a simple transaction with the given date and postings.+transaction :: Day -> [Posting] -> Transaction+transaction day ps = txnTieKnot $ nulltransaction{tdate=day, tpostings=ps}++transactionPayee :: Transaction -> Text+transactionPayee = fst . payeeAndNoteFromDescription . tdescription++transactionNote :: Transaction -> Text+transactionNote = snd . payeeAndNoteFromDescription . tdescription++-- | Parse a transaction's description into payee and note (aka narration) fields,+-- assuming a convention of separating these with | (like Beancount).+-- Ie, everything up to the first | is the payee, everything after it is the note.+-- When there's no |, payee == note == description.+payeeAndNoteFromDescription :: Text -> (Text,Text)+payeeAndNoteFromDescription t+  | T.null n = (t, t)+  | otherwise = (T.strip p, T.strip $ T.drop 1 n)+  where+    (p, n) = T.span (/= '|') t++-- | Like payeeAndNoteFromDescription, but if there's no | then payee is empty.+payeeAndNoteFromDescription' :: Text -> (Text,Text)+payeeAndNoteFromDescription' t =+  if isJust $ T.find (=='|') t then payeeAndNoteFromDescription t else ("",t)+++{-|+Render a journal transaction as text similar to the style of Ledger's print command.++Adapted from Ledger 2.x and 3.x standard format:++@+yyyy-mm-dd[ *][ CODE] description.........          [  ; comment...............]+    account name 1.....................  ...$amount1[  ; comment...............]+    account name 2.....................  ..$-amount1[  ; comment...............]++pcodewidth    = no limit -- 10          -- mimicking ledger layout.+pdescwidth    = no limit -- 20          -- I don't remember what these mean,+pacctwidth    = 35 minimum, no maximum  -- they were important at the time.+pamtwidth     = 11+pcommentwidth = no limit -- 22+@++The output will be parseable journal syntax.+To facilitate this, postings with explicit multi-commodity amounts+are displayed as multiple similar postings, one per commodity.+(Normally does not happen with this function).+-}+showTransaction :: Transaction -> Text+showTransaction = TL.toStrict . TB.toLazyText . showTransactionHelper False++-- | Like showTransaction, but explicit multi-commodity amounts+-- are shown on one line, comma-separated. In this case the output will+-- not be parseable journal syntax.+showTransactionOneLineAmounts :: Transaction -> Text+showTransactionOneLineAmounts = TL.toStrict . TB.toLazyText . showTransactionHelper True++-- | Helper for showTransaction*.+showTransactionHelper :: Bool -> Transaction -> TB.Builder+showTransactionHelper onelineamounts t =+      TB.fromText descriptionline <> newline+    <> foldMap ((<> newline) . TB.fromText) newlinecomments+    <> foldMap ((<> newline) . TB.fromText) (postingsAsLines onelineamounts $ tpostings t)+    <> newline+  where+    descriptionline = T.stripEnd $ showTransactionLineFirstPart t <> T.concat [desc, samelinecomment]+    desc = if T.null d then "" else " " <> d where d = tdescription t+    (samelinecomment, newlinecomments) =+      case renderCommentLines (tcomment t) of []   -> ("",[])+                                              c:cs -> (c,cs)+    newline = TB.singleton '\n'++-- Useful when rendering error messages.+showTransactionLineFirstPart t = T.concat [date, status, code]+  where+    date = showDate (tdate t) <> maybe "" (("="<>) . showDate) (tdate2 t)+    status | tstatus t == Cleared = " *"+           | tstatus t == Pending = " !"+           | otherwise            = ""+    code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t++hasRealPostings :: Transaction -> Bool+hasRealPostings = not . null . realPostings++realPostings :: Transaction -> [Posting]+realPostings = filter isReal . tpostings++assignmentPostings :: Transaction -> [Posting]+assignmentPostings = filter hasBalanceAssignment . tpostings++virtualPostings :: Transaction -> [Posting]+virtualPostings = filter isVirtual . tpostings++balancedVirtualPostings :: Transaction -> [Posting]+balancedVirtualPostings = filter isBalancedVirtual . tpostings++transactionsPostings :: [Transaction] -> [Posting]+transactionsPostings = concatMap tpostings++-- Get a transaction's secondary date, or the primary date if there is none.+transactionDate2 :: Transaction -> Day+transactionDate2 t = fromMaybe (tdate t) $ tdate2 t++-- Get a transaction's primary or secondary date, as specified.+transactionDateOrDate2 :: WhichDate -> Transaction -> Day+transactionDateOrDate2 PrimaryDate   = tdate+transactionDateOrDate2 SecondaryDate = transactionDate2++-- | Ensure a transaction's postings refer back to it, so that eg+-- relatedPostings works right.+txnTieKnot :: Transaction -> Transaction+txnTieKnot t@Transaction{tpostings=ps} = t' where+    t' = t{tpostings=map (postingSetTransaction t') ps}++-- | Ensure a transaction's postings do not refer back to it, so that eg+-- recursiveSize and GHCI's :sprint work right.+txnUntieKnot :: Transaction -> Transaction+txnUntieKnot t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}++-- | Set a posting's parent transaction.+postingSetTransaction :: Transaction -> Posting -> Posting+postingSetTransaction t p = p{ptransaction=Just t}++-- | Apply a transform function to this transaction's amounts.+transactionTransformPostings :: (Posting -> Posting) -> Transaction -> Transaction+transactionTransformPostings f t@Transaction{tpostings=ps} = t{tpostings=map f ps}++-- | Apply a specified valuation to this transaction's amounts, using+-- the provided price oracle, commodity styles, and reference dates.+-- See amountApplyValuation.+transactionApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> ValuationType -> Transaction -> Transaction+transactionApplyValuation priceoracle styles periodlast today v =+  transactionTransformPostings (postingApplyValuation priceoracle styles periodlast today v)++-- | Maybe convert this 'Transaction's amounts to cost.+transactionToCost :: ConversionOp -> Transaction -> Transaction+transactionToCost cost t = t{tpostings = mapMaybe (postingToCost cost) $ tpostings t}++-- | For any costs in this 'Transaction' which don't have associated equity conversion postings,+-- generate and add those.+transactionInferEquityPostings :: Bool -> AccountName -> Transaction -> Transaction+transactionInferEquityPostings verbosetags equityAcct t =+  t{tpostings=concatMap (postingAddInferredEquityPostings verbosetags equityAcct) $ tpostings t}++type IdxPosting = (Int, Posting)++-- XXX Warning: The following code - for analysing equity conversion postings,+-- inferring missing costs and ignoring redundant costs -+-- is twisty and hard to follow.++label s = ((s <> ": ")++)++-- | Add tags to a transaction, discarding any for which it already has a value.+-- Note this does not add tags to the transaction's comment.+transactionAddTags :: Transaction -> [Tag] -> Transaction+transactionAddTags t@Transaction{ttags} tags = t{ttags=ttags `union` tags}++-- | Add the given hidden tag to a transaction; and with a true argument,+-- also add the equivalent visible tag to the transaction's tags and comment fields.+-- If the transaction already has these tags (with any value), do nothing.+transactionAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Transaction -> Transaction+transactionAddHiddenAndMaybeVisibleTag verbosetags ht t@Transaction{tcomment=c, ttags} =+  (t `transactionAddTags` ([ht] <> [ vt|verbosetags]))+  {tcomment=if verbosetags && not hadtag then c `commentAddTagNextLine` vt else c}+  where+    vt@(vname,_) = toVisibleTag ht+    hadtag = any ((== (T.toLower vname)) . T.toLower . fst) ttags  -- XXX should regex-quote vname++-- | Find, associate, and tag the corresponding equity conversion postings and costful or potentially costful postings in this transaction.+-- With a true addcosts argument, also generate and add any equivalent costs that are missing.+-- The (previously detected) names of all equity conversion accounts should be provided.+--+-- For every pair of adjacent conversion postings, this first searches for a posting with equivalent cost (1).+-- If no such posting is found, it then searches the costless postings, for one matching one of the conversion amounts (2).+-- If either of these found a candidate posting, it is tagged with costPostingTagName.+-- Then if in addcosts mode, if a costless posting was found, a cost equivalent to the conversion amounts is added to it.+--+-- The name reflects the complexity of this and its helpers; clarification is ongoing.+--+transactionTagCostsAndEquityAndMaybeInferCosts :: Bool -> Bool -> [AccountName] -> Transaction -> Either String Transaction+transactionTagCostsAndEquityAndMaybeInferCosts verbosetags1 addcosts conversionaccts t = first (annotateErrorWithTransaction t . T.unpack) $ do+  -- number the postings+  let npostings = zip [0..] $ tpostings t++  -- Identify all pairs of conversion postings and all other postings (with and without costs) in the transaction.+  (conversionPairs, otherps) <- partitionAndCheckConversionPostings False conversionaccts npostings++  -- Generate a pure function that can be applied to each of this transaction's postings,+  -- possibly modifying it, to produce the following end result:+  -- 1. each pair of conversion postings, and the corresponding postings which balance them, are tagged for easy identification+  -- 2. each pair of balancing postings which did't have an explicit cost, have had a cost calculated and added to one of them+  -- 3. if any ambiguous situation was detected, an informative error is raised+  processposting <- transformIndexedPostingsF (tagAndMaybeAddCostsForEquityPostings verbosetags1 addcosts) conversionPairs otherps++  -- And if there was no error, use it to modify the transaction's postings.+  return t{tpostings = map (snd . processposting) npostings}++  where++    -- Generate the tricksy processposting function,+    -- which when applied to each posting in turn, rather magically has the effect of+    -- applying tagAndMaybeAddCostsForEquityPostings to each pair of conversion postings in the transaction,+    -- matching them with the other postings, tagging them and perhaps adding cost information to the other postings.+    -- General type:+    -- transformIndexedPostingsF :: (Monad m, Foldable t, Traversable t) =>+    --   (a -> StateT s m (a1 -> a1)) ->+    --   t a ->+    --   s ->+    --   m (a1 -> a1)+    -- Concrete type:+    transformIndexedPostingsF ::+      ((IdxPosting, IdxPosting) -> StateT ([IdxPosting],[IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)) ->  -- state update function (tagAndMaybeAddCostsForEquityPostings with the bool applied)+      [(IdxPosting, IdxPosting)] ->   -- initial state: the pairs of adjacent conversion postings in the transaction+      ([IdxPosting],[IdxPosting]) ->  -- initial state: the other postings in the transaction, separated into costful and costless+      (Either Text (IdxPosting -> IdxPosting))  -- returns an error message or a posting transform function+    transformIndexedPostingsF updatefn = evalStateT . fmap (appEndo . foldMap Endo) . traverse (updatefn)++    -- A tricksy state update helper for processposting/transformIndexedPostingsF.+    -- Approximately: given a pair of equity conversion postings to match,+    -- and lists of the remaining unmatched costful and costless other postings,+    -- 1. find (and consume) two other postings whose amounts/cost match the two conversion postings+    -- 2. add hidden identifying tags to the conversion postings and the other posting which has (or could have) an equivalent cost+    -- 3. if in add costs mode, and the potential equivalent-cost posting does not have that explicit cost, add it+    -- 4. or if there is a problem, raise an informative error or do nothing, as appropriate.+    -- Or if there are no costful postings at all, do nothing.+    tagAndMaybeAddCostsForEquityPostings :: Bool -> Bool -> (IdxPosting, IdxPosting) -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)+    tagAndMaybeAddCostsForEquityPostings verbosetags addcosts' ((n1, cp1), (n2, cp2)) = StateT $ \(costps, otherps) -> do+      -- Get the two conversion posting amounts, if possible+      ca1 <- conversionPostingAmountNoCost cp1+      ca2 <- conversionPostingAmountNoCost cp2+      let +        -- All costful postings whose cost is equivalent to the conversion postings' amounts.+        matchingCostfulPs =+          dbg7With (label "matched costful postings".show.length) $ +          mapMaybe (mapM $ costfulPostingIfMatchesBothAmounts ca1 ca2) costps++        -- In dry run mode: all other costless, single-commodity postings.+        -- In add costs mode: all other costless, single-commodity postings whose amount matches at least one of the conversion postings,+        -- with the equivalent cost added to one of them. (?)+        matchingCostlessPs =+          dbg7With (label "matched costless postings".show.length) $+          if addcosts'+          then mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps+          else [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p]++        -- A function that adds a cost and/or tag to a numbered posting if appropriate.+        postingAddCostAndOrTag np costp (n,p) =+          (n, if | n == np            -> costp & postingAddHiddenAndMaybeVisibleTag verbosetags (costPostingTagName,"")        -- if it's the specified posting number, replace it with the costful posting, and tag it+                 | n == n1 || n == n2 -> p     & postingAddHiddenAndMaybeVisibleTag verbosetags (conversionPostingTagName,"")  -- if it's one of the equity conversion postings, tag it+                 | otherwise          -> p)++      -- Annotate any errors with the conversion posting pair+      first (annotateWithPostings [cp1, cp2]) $+        if+          -- If a single costful posting matches the conversion postings,+          -- delete it from the list of costful postings in the state, delete the+          -- first matching costless posting from the list of costless postings+          -- in the state, and return the transformation function with the new state.+          | [(np, costp)] <- matchingCostfulPs+          , Just newcostps <- deleteIdx np costps+              -> Right (postingAddCostAndOrTag np costp, (if addcosts' then newcostps else costps, otherps))++          -- If no costful postings match the conversion postings, but some+          -- of the costless postings match, check that the first such posting has a+          -- different amount from all the others, and if so add a cost to it,+          -- then delete it from the list of costless postings in the state,+          -- and return the transformation function with the new state.+          | [] <- matchingCostfulPs+          , (np, (costp, amt)):nps <- matchingCostlessPs+          , not $ any (amountsMatch amt . snd . snd) nps+          , Just newotherps <- deleteIdx np otherps+              -> Right (postingAddCostAndOrTag np costp, (costps, if addcosts' then newotherps else otherps))++          -- Otherwise, do nothing, leaving the transaction unchanged.+          -- We don't want to be over-zealous reporting problems here+          -- since this is always called at least in dry run mode by+          -- journalFinalise > journalMarkRedundantCosts. (#2045)+          | otherwise -> Right (id, (costps, otherps))++    -- If a posting with cost matches both the conversion amounts, return it along+    -- with the matching amount which must be present in another non-conversion posting.+    costfulPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe Posting+    costfulPostingIfMatchesBothAmounts a1 a2 costfulp = do+        a@Amount{acost=Just _} <- postingSingleAmount costfulp+        if+           | dbgamtmatch 1 a1 a (amountsMatch (-a1) a)  &&  dbgcostmatch 2 a2 a (amountsMatch a2 (amountCost a)) -> Just costfulp+           | dbgamtmatch 2 a2 a (amountsMatch (-a2) a)  &&  dbgcostmatch 1 a1 a (amountsMatch a1 (amountCost a)) -> Just costfulp+           | otherwise -> Nothing+           where+            dbgamtmatch  n a b = dbg7 ("conversion posting "     <>show n<>" "<>showAmount a<>" balances amount "<>showAmountWithoutCost b <>" of costful posting "<>showAmount b<>" at precision "<>dbgShowAmountPrecision a<>" ?")+            dbgcostmatch n a b = dbg7 ("and\nconversion posting "<>show n<>" "<>showAmount a<>" matches cost "   <>showAmount (amountCost b)<>" of costful posting "<>showAmount b<>" at precision "<>dbgShowAmountPrecision a<>" ?") ++    -- Add a cost to a posting if it matches (negative) one of the+    -- supplied conversion amounts, adding the other amount as the cost.+    addCostIfMatchesOneAmount :: Amount -> Amount -> Posting -> Maybe (Posting, Amount)+    addCostIfMatchesOneAmount a1 a2 p = do+        a <- postingSingleAmount p+        let newp cost = p{pamount = mixedAmount a{acost = Just $ TotalCost cost}}+        if+           | amountsMatch (-a1) a -> Just (newp a2, a2)+           | amountsMatch (-a2) a -> Just (newp a1, a1)+           | otherwise            -> Nothing++    -- Get the single-commodity costless amount from a conversion posting, or raise an error.+    conversionPostingAmountNoCost p = case postingSingleAmount p of+        Just a@Amount{acost=Nothing} -> Right a+        Just Amount{acost=Just _} -> Left $ annotateWithPostings [p] "Conversion postings must not have a cost:"+        Nothing                    -> Left $ annotateWithPostings [p] "Conversion postings must have a single-commodity amount:"++    -- Do these amounts look the same when compared at the first's display precision ?+    amountsMatch a b = amountLooksZero $ amountSetPrecision (asprecision $ astyle a) $ a - b++    -- Delete a posting from the indexed list of postings based on either its+    -- index or its posting amount.+    -- Note: traversing the whole list to delete a single match is generally not efficient,+    -- but given that a transaction probably doesn't have more than four postings, it should+    -- still be more efficient than using a Map or another data structure. Even monster+    -- transactions with up to 10 postings, which are generally not a good+    -- idea, are still too small for there to be an advantage.+    -- XXX shouldn't assume transactions have few postings+    deleteIdx n = deleteUniqueMatch ((n==) . fst)+    deleteUniqueMatch p (x:xs) | p x       = if any p xs then Nothing else Just xs+                               | otherwise = (x:) <$> deleteUniqueMatch p xs+    deleteUniqueMatch _ []                 = Nothing+    annotateWithPostings xs str = T.unlines $ str : postingsAsLines False xs++dbgShowAmountPrecision a =+  case asprecision $ astyle a of+    Precision n      -> show n+    NaturalPrecision -> show $ decimalPlaces $ normalizeDecimal $ aquantity a++-- Given the names of conversion equity accounts, sort the given indexed postings+-- into three lists of posting numbers (stored in two pairs), like so:+-- (conversion postings, (costful other postings, costless other postings)).+-- A true first argument activates its secondary function: check that all+-- conversion postings occur in adjacent pairs, otherwise return an error.+partitionAndCheckConversionPostings :: Bool -> [AccountName] -> [IdxPosting] -> Either Text ( [(IdxPosting, IdxPosting)], ([IdxPosting], [IdxPosting]) )+partitionAndCheckConversionPostings check conversionaccts =+  -- Left fold processes postings in parse order, so that eg inferred costs+  -- will be added to the first (top-most) posting, not the last one.+  foldlM select (([], ([], [])), Nothing)+    -- The costless other postings are somehow reversed still; "second (second reverse)" fixes that.+    <&> fmap (second (second reverse) . fst)+  where+    select ((cs, others@(ps, os)), Nothing) np@(_, p)+      | isConversion p = Right ((cs, others),      Just np)+      | hasCost p      = Right ((cs, (np:ps, os)), Nothing)+      | otherwise      = Right ((cs, (ps, np:os)), Nothing)+    select ((cs, others@(ps,os)), Just lst) np@(_, p)+      | isConversion p = Right (((lst, np):cs, others), Nothing)+      | check          = Left "Conversion postings must occur in adjacent pairs"+      | otherwise      = Right ((cs, (ps, np:os)), Nothing)+    isConversion p = paccount p `elem` conversionaccts+    hasCost p = isJust $ acost =<< postingSingleAmount p++-- | Get a posting's amount if it is single-commodity.+postingSingleAmount :: Posting -> Maybe Amount+postingSingleAmount p = case amountsRaw (pamount p) of+  [a] -> Just a+  _   -> Nothing++-- | Apply some account aliases to all posting account names in the transaction, as described by accountNameApplyAliases.+-- This can fail due to a bad replacement pattern in a regular expression alias.+transactionApplyAliases :: [AccountAlias] -> Transaction -> Either RegexError Transaction+transactionApplyAliases aliases t =+  case mapM (postingApplyAliases aliases) $ tpostings t of+    Right ps -> Right $ txnTieKnot $ t{tpostings=ps}+    Left err -> Left err++-- | Apply a transformation to a transaction's postings.+transactionMapPostings :: (Posting -> Posting) -> Transaction -> Transaction+transactionMapPostings f t@Transaction{tpostings=ps} = t{tpostings=map f ps}++-- | Apply a transformation to a transaction's posting amounts.+transactionMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Transaction -> Transaction+transactionMapPostingAmounts f  = transactionMapPostings (postingTransformAmount f)++-- | All posting amounts from this transaction, in order.+transactionAmounts :: Transaction -> [MixedAmount]+transactionAmounts = map pamount . tpostings++-- | Get the canonical amount styles inferred from this transaction's amounts.+transactionCommodityStyles :: Transaction -> M.Map CommoditySymbol AmountStyle+transactionCommodityStyles =+  either (const mempty) id .  -- ignore style problems, commodityStylesFromAmounts doesn't report them currently+  commodityStylesFromAmounts . concatMap (amountsRaw . pamount) . tpostings++-- | Like transactionCommodityStyles, but attach a particular rounding strategy to the styles,+-- affecting how they will affect display precisions when applied.+transactionCommodityStylesWith :: Rounding -> Transaction -> M.Map CommoditySymbol AmountStyle+transactionCommodityStylesWith r = amountStylesSetRounding r . transactionCommodityStyles++-- | Flip the sign of this transaction's posting amounts (and balance assertion amounts).+transactionNegate :: Transaction -> Transaction+transactionNegate = transactionMapPostings postingNegate++-- | The file path from which this transaction was parsed.+transactionFile :: Transaction -> FilePath+transactionFile Transaction{tsourcepos} = sourceName $ fst tsourcepos++-- Add transaction information to an error message.+annotateErrorWithTransaction :: Transaction -> String -> String+annotateErrorWithTransaction t s =+  unlines [ sourcePosPairPretty $ tsourcepos t, s+          , T.unpack . T.stripEnd $ showTransaction t+          ]++-- tests++tests_Transaction :: TestTree+tests_Transaction =+  testGroup "Transaction" [++      testGroup "showPostingLines" [+          testCase "null posting" $ showPostingLines nullposting @?= ["                   0"]+        , testCase "non-null posting" $+           let p =+                posting+                  { pstatus = Cleared+                  , paccount = "a"+                  , pamount = mixed [usd 1, hrs 2]+                  , pcomment = "pcomment1\npcomment2\n  tag3: val3  \n"+                  , ptype = RegularPosting+                  , ptags = [("ptag1", "val1"), ("ptag2", "val2")]+                  }+           in showPostingLines p @?=+              [ "    * a         $1.00  ; pcomment1"+              , "    ; pcomment2"+              , "    ;   tag3: val3  "+              , "    * a         2.00h  ; pcomment1"+              , "    ; pcomment2"+              , "    ;   tag3: val3  "+              ]+        ]++    , let+        -- one implicit amount+        timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]}+        -- explicit amounts, balanced+        texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]}+        -- explicit amount, only one posting+        texp1 = nulltransaction {tpostings = ["(a)" `post` usd 1]}+        -- explicit amounts, two commodities, explicit balancing price+        texp2 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` (hrs (-1) `at` usd 1)]}+        -- explicit amounts, two commodities, implicit balancing price+        texp2b = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` hrs (-1)]}+        -- one missing amount, not the last one+        t3 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt, "c" `post` usd (-1)]}+        -- unbalanced amounts when precision is limited (#931)+        -- t4 = nulltransaction {tpostings = ["a" `post` usd (-0.01), "b" `post` usd (0.005), "c" `post` usd (0.005)]}+      in testGroup "postingsAsLines" [+              testCase "null-transaction" $ postingsAsLines False (tpostings nulltransaction) @?= []+            , testCase "implicit-amount" $ postingsAsLines False (tpostings timp) @?=+                  [ "    a           $1.00"+                  , "    b" -- implicit amount remains implicit+                  ]+            , testCase "explicit-amounts" $ postingsAsLines False (tpostings texp) @?=+                  [ "    a           $1.00"+                  , "    b          $-1.00"+                  ]+            , testCase "one-explicit-amount" $ postingsAsLines False (tpostings texp1) @?=+                  [ "    (a)           $1.00"+                  ]+            , testCase "explicit-amounts-two-commodities" $ postingsAsLines False (tpostings texp2) @?=+                  [ "    a             $1.00"+                  , "    b    -1.00h @ $1.00"+                  ]+            , testCase "explicit-amounts-not-explicitly-balanced" $ postingsAsLines False (tpostings texp2b) @?=+                  [ "    a           $1.00"+                  , "    b          -1.00h"+                  ]+            , testCase "implicit-amount-not-last" $ postingsAsLines False (tpostings t3) @?=+                  ["    a           $1.00", "    b", "    c          $-1.00"]+            -- , testCase "ensure-visibly-balanced" $+            --    in postingsAsLines False (tpostings t4) @?=+            --       ["    a          $-0.01", "    b           $0.005", "    c           $0.005"]++            ]++    , testGroup "showTransaction" [+          testCase "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n"+        , testCase "non-null transaction" $ showTransaction+            nulltransaction+              { tdate = fromGregorian 2012 05 14+              , tdate2 = Just $ fromGregorian 2012 05 15+              , tstatus = Unmarked+              , tcode = "code"+              , tdescription = "desc"+              , tcomment = "tcomment1\ntcomment2\n"+              , ttags = [("ttag1", "val1")]+              , tpostings =+                  [ nullposting+                      { pstatus = Cleared+                      , paccount = "a"+                      , pamount = mixed [usd 1, hrs 2]+                      , pcomment = "\npcomment2\n"+                      , ptype = RegularPosting+                      , ptags = [("ptag1", "val1"), ("ptag2", "val2")]+                      }+                  ]+              } @?=+          T.unlines+            [ "2012-05-14=2012-05-15 (code) desc  ; tcomment1"+            , "    ; tcomment2"+            , "    * a         $1.00"+            , "    ; pcomment2"+            , "    * a         2.00h"+            , "    ; pcomment2"+            , ""+            ]+        , testCase "show a balanced transaction" $+          (let t =+                 Transaction+                   0+                   ""+                   nullsourcepospair+                   (fromGregorian 2007 01 28)+                   Nothing+                   Unmarked+                   ""+                   "coopportunity"+                   ""+                   []+                   [ posting {paccount = "expenses:food:groceries", pamount = mixedAmount (usd 47.18), ptransaction = Just t}+                   , posting {paccount = "assets:checking", pamount = mixedAmount (usd (-47.18)), ptransaction = Just t}+                   ]+            in showTransaction t) @?=+          (T.unlines+             [ "2007-01-28 coopportunity"+             , "    expenses:food:groceries          $47.18"+             , "    assets:checking                 $-47.18"+             , ""+             ])+        , testCase "show an unbalanced transaction, should not elide" $+          (showTransaction+             (txnTieKnot $+              Transaction+                0+                ""+                nullsourcepospair+                (fromGregorian 2007 01 28)+                Nothing+                Unmarked+                ""+                "coopportunity"+                ""+                []+                [ posting {paccount = "expenses:food:groceries", pamount = mixedAmount (usd 47.18)}+                , posting {paccount = "assets:checking", pamount = mixedAmount (usd (-47.19))}+                ])) @?=+          (T.unlines+             [ "2007-01-28 coopportunity"+             , "    expenses:food:groceries          $47.18"+             , "    assets:checking                 $-47.19"+             , ""+             ])+        , testCase "show a transaction with one posting and a missing amount" $+          (showTransaction+             (txnTieKnot $+              Transaction+                0+                ""+                nullsourcepospair+                (fromGregorian 2007 01 28)+                Nothing+                Unmarked+                ""+                "coopportunity"+                ""+                []+                [posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?=+          (T.unlines ["2007-01-28 coopportunity", "    expenses:food:groceries", ""])+        , testCase "show a transaction with a priced commodityless amount" $+          (showTransaction+             (txnTieKnot $+              Transaction+                0+                ""+                nullsourcepospair+                (fromGregorian 2010 01 01)+                Nothing+                Unmarked+                ""+                "x"+                ""+                []+                [ posting {paccount = "a", pamount = mixedAmount $ num 1 `at` (usd 2 `withPrecision` Precision 0)}+                , posting {paccount = "b", pamount = missingmixedamt}+                ])) @?=+          (T.unlines ["2010-01-01 x", "    a          1 @ $2", "    b", ""])         ]     ]
Hledger/Data/TransactionModifier.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-} {-|  A 'TransactionModifier' is a rule that modifies certain 'Transaction's,-typically adding automated postings to them. +typically adding automated postings to them.  -} module Hledger.Data.TransactionModifier (@@ -12,19 +12,22 @@ ) where -import Data.Maybe-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import qualified Data.Text as T-import Data.Time.Calendar+import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..), (<|>))+import Data.Function ((&))+import Data.Map qualified as M+import Data.Maybe (catMaybes)+import Data.Text qualified as T+import Data.Time.Calendar (Day)+import Safe (headDef) import Hledger.Data.Types-import Hledger.Data.Dates import Hledger.Data.Amount-import Hledger.Data.Transaction-import Hledger.Query-import Hledger.Utils.UTF8IOCompat (error')-import Hledger.Utils.Debug+import Hledger.Data.Dates+import Hledger.Data.Transaction (txnTieKnot, transactionAddHiddenAndMaybeVisibleTag)+import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra,+                      parseQuery, queryIsAmt, queryIsSym, simplifyQuery)+import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, modifiedTransactionTagName)+import Hledger.Utils (dbg6, wrap)  -- $setup -- >>> :set -XOverloadedStrings@@ -33,97 +36,123 @@ -- >>> import Hledger.Data.Journal  -- | Apply all the given transaction modifiers, in turn, to each transaction.-modifyTransactions :: [TransactionModifier] -> [Transaction] -> [Transaction]-modifyTransactions tmods = map applymods-  where-    applymods = foldr (flip (.) . transactionModifierToFunction) id tmods+-- Or if any of them fails to be parsed, return the first error. A reference+-- date is provided to help interpret relative dates in transaction modifier+-- queries.+modifyTransactions :: (AccountName -> Maybe AccountType)+                   -> (AccountName -> [Tag])+                   -> M.Map CommoditySymbol AmountStyle+                   -> Day -> Bool -> [TransactionModifier] -> [Transaction]+                   -> Either String [Transaction]+modifyTransactions atypes atags styles d verbosetags tmods ts = do+  fs <- mapM (transactionModifierToFunction atypes atags styles d verbosetags) tmods  -- convert modifiers to functions, or return a parse error+  let+    modifytxn t =+      t' & if t'/=t then transactionAddHiddenAndMaybeVisibleTag verbosetags (modifiedTransactionTagName,"") else id+      where+        t' = foldr (flip (.)) id fs t  -- apply each function in turn --- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,+  Right $ map modifytxn ts++-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function -- which applies the modification(s) specified by the TransactionModifier.--- Currently this means adding automated postings when certain other postings are present.--- The postings of the transformed transaction will reference it in the usual +-- Or, returns the error message there is a problem parsing the TransactionModifier's query.+-- A reference date is provided to help interpret relative dates in the query.+--+-- The postings of the transformed transaction will reference it in the usual -- way (ie, 'txnTieKnot' is called). ----- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}--- 0000/01/01+-- Currently the only kind of modification possible is adding automated+-- postings when certain other postings are present.+--+-- >>> import Data.Text.IO qualified as T+-- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]}+-- >>> tmpost acc amt = TMPostingRule (acc `post` amt) False+-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction (const Nothing) (const []) mempty nulldate True+-- >>> test $ TransactionModifier "" ["pong" `tmpost` usd 2]+-- 0000-01-01 --     ping           $1.00---     pong           $2.00+--     pong           $2.00  ; generated-posting: = -- <BLANKLINE>--- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "miss" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}--- 0000/01/01+-- >>> test $ TransactionModifier "miss" ["pong" `tmpost` usd 2]+-- 0000-01-01 --     ping           $1.00 -- <BLANKLINE>--- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "ping" ["pong" `post` amount{aismultiplier=True, aquantity=3}]) nulltransaction{tpostings=["ping" `post` usd 2]}--- 0000/01/01---     ping           $2.00---     pong           $6.00+-- >>> test $ TransactionModifier "ping" [("pong" `tmpost` nullamt{aquantity=3}){tmprIsMultiplier=True}]+-- 0000-01-01+--     ping           $1.00+--     pong           $3.00  ; generated-posting: = ping -- <BLANKLINE> ---transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction)-transactionModifierToFunction mt = -  \t@(tpostings -> ps) -> txnTieKnot t{ tpostings=generatePostings ps } -- TODO add modifier txn comment/tags ?-  where-    q = simplifyQuery $ tmParseQuery mt (error' "a transaction modifier's query cannot depend on current date")-    mods = map tmPostingRuleToFunction $ tmpostingrules mt-    generatePostings ps = [p' | p <- ps-                              , p' <- if q `matchesPosting` p then p:[ m p | m <- mods] else [p]]-    --- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt', --- and return it as a function requiring the current date. ------ >>> tmParseQuery (TransactionModifier "" []) undefined--- Any--- >>> tmParseQuery (TransactionModifier "ping" []) undefined--- Acct "ping"--- >>> tmParseQuery (TransactionModifier "date:2016" []) undefined--- Date (DateSpan 2016)--- >>> tmParseQuery (TransactionModifier "date:today" []) (read "2017-01-01")--- Date (DateSpan 2017/01/01)-tmParseQuery :: TransactionModifier -> (Day -> Query)-tmParseQuery mt = fst . flip parseQuery (tmquerytxt mt)+transactionModifierToFunction :: (AccountName -> Maybe AccountType)+                              -> (AccountName -> [Tag])+                              -> M.Map CommoditySymbol AmountStyle+                              -> Day -> Bool -> TransactionModifier+                              -> Either String (Transaction -> Transaction)+transactionModifierToFunction atypes atags styles refdate verbosetags TransactionModifier{tmquerytxt, tmpostingrules} = do+  q <- simplifyQuery . fst <$> parseQuery refdate tmquerytxt+  let+    fs = map (\tmpr -> addAccountTags . tmPostingRuleToFunction verbosetags styles q tmquerytxt tmpr) tmpostingrules+    addAccountTags p = p `postingAddTags` atags (paccount p)+    generatePostings p = p : map ($ p) (if matchesPostingExtra atypes q p then fs else [])+  Right $ \t@(tpostings -> ps) -> txnTieKnot t{tpostings=concatMap generatePostings ps}  -- | Converts a 'TransactionModifier''s posting rule to a 'Posting'-generating function, -- which will be used to make a new posting based on the old one (an "automated posting"). -- The new posting's amount can optionally be the old posting's amount multiplied by a constant.--- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced. -tmPostingRuleToFunction :: TMPostingRule -> (Posting -> Posting)-tmPostingRuleToFunction pr = -  \p -> renderPostingCommentDates $ pr-      { pdate = pdate p-      , pdate2 = pdate2 p-      , pamount = amount' p+-- If the old posting had a total-priced amount, the new posting's multiplied amount will be unit-priced.+-- The new posting will have a hidden _generated-posting: tag added,+-- and with a true first argument, also a visible generated-posting: tag.+-- The provided TransactionModifier's query text is saved as the tags' value.+tmPostingRuleToFunction :: Bool -> M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting)+tmPostingRuleToFunction verbosetags styles query querytxt tmpr =+  \p -> styleAmounts styles . renderPostingCommentDates $ pr+      { pdate    = pdate  pr <|> pdate  p+      , pdate2   = pdate2 pr <|> pdate2 p+      , paccount = account' p+      , pamount  = amount' p+      , pcomment = pcomment pr & (if verbosetags then (`commentAddTag` ("generated-posting",qry)) else id)+      , ptags    = ptags pr+                   & (("_generated-posting",qry) :)+                   & (if verbosetags then (("generated-posting", qry) :) else id)       }   where-    amount' = case postingRuleMultiplier pr of+    pr = tmprPosting tmpr+    qry = "= " <> querytxt+    symq = filterQuery (liftA2 (||) queryIsSym queryIsAmt) query+    account' = if accountTemplate `T.isInfixOf` paccount pr+                 then \p -> T.replace accountTemplate (paccount p) $ paccount pr+                 else const $ paccount pr+      where accountTemplate = "%account"+    amount' = case postingRuleMultiplier tmpr of         Nothing -> const $ pamount pr         Just n  -> \p ->           -- Multiply the old posting's amount by the posting rule's multiplier.           let-            pramount = dbg6 "pramount" $ head $ amounts $ pamount pr-            matchedamount = dbg6 "matchedamount" $ pamount p+            pramount = dbg6 "pramount" . headDef nullamt . amountsRaw $ pamount pr+            matchedamount = dbg6 "matchedamount" . filterMixedAmount (symq `matchesAmount`) $ pamount p             -- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928).             -- Approach 1: convert to a unit price and increase the display precision slightly-            -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount -            -- Approach 2: multiply the total price (keeping it positive) as well as the quantity -            Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmountAndPrice` matchedamount +            -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalCostToUnitCost matchedamount+            -- Approach 2: multiply the total price (keeping it positive) as well as the quantity+            as = dbg6 "multipliedamount" $ multiplyMixedAmount n matchedamount           in             case acommodity pramount of-              "" -> Mixed as+              "" -> as               -- TODO multipliers with commodity symbols are not yet a documented feature.-              -- For now: in addition to multiplying the quantity, it also replaces the -              -- matched amount's commodity, display style, and price with those of the posting rule.   -              c  -> Mixed [a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount} | a <- as]+              -- For now: in addition to multiplying the quantity, it also replaces the+              -- matched amount's commodity, display style, and price with those of the posting rule.+              c  -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, acost = acost pramount}) as  postingRuleMultiplier :: TMPostingRule -> Maybe Quantity-postingRuleMultiplier p =-    case amounts $ pamount p of-        [a] | aismultiplier a -> Just $ aquantity a-        _                   -> Nothing+postingRuleMultiplier tmpr = case amountsRaw . pamount $ tmprPosting tmpr of+    [a] | tmprIsMultiplier tmpr -> Just $ aquantity a+    _                           -> Nothing  renderPostingCommentDates :: Posting -> Posting renderPostingCommentDates p = p { pcomment = comment' }     where-        datesComment = T.concat $ catMaybes [T.pack . showDate <$> pdate p, ("=" <>) . T.pack . showDate <$> pdate2 p]+        dates = T.concat $ catMaybes [showDate <$> pdate p, ("=" <>) . showDate <$> pdate2 p]         comment'-            | T.null datesComment = pcomment p-            | otherwise = T.intercalate "\n" $ filter (not . T.null) [T.strip $ pcomment p, "[" <> datesComment <> "]"]+            | T.null dates = pcomment p+            | otherwise    = (wrap "[" "]" dates) `commentJoin` pcomment p
Hledger/Data/Types.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-|+  {-|  Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model:@@ -18,47 +16,56 @@  -} -module Hledger.Data.Types+-- {-# LANGUAGE DeriveAnyClass #-}  -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf+{-# LANGUAGE CPP        #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE StrictData           #-}++module Hledger.Data.Types (+  module Hledger.Data.Types,+#if MIN_VERSION_time(1,11,0)+  Year+#endif+) where  import GHC.Generics (Generic)-import Control.DeepSeq (NFData)-import Data.Data-import Data.Decimal-import Data.Default+import Control.DeepSeq (NFData(..))+import Data.Bifunctor (first)+import Data.Decimal (Decimal, DecimalRaw(..))+import Data.Default (Default(..)) import Data.Functor (($>))-import Data.List (intercalate)-import Text.Blaze (ToMarkup(..))---XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html +import Data.List (intercalate, sortBy)+--XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html --Note: You should use Data.Map.Strict instead of this module if: --You will eventually need all the values stored. --The stored values don't represent large virtual data structures to be lazily computed.-import qualified Data.Map as M+import Data.Map qualified as M+import Data.Ord (comparing)+import Data.Semigroup (Min(..)) import Data.Text (Text)--- import qualified Data.Text as T-import Data.Time.Calendar-import Data.Time.LocalTime-import System.Time (ClockTime(..))-import Text.Printf+import Data.Text qualified as T+import Data.Time.Calendar (Day)+import Data.Time.Clock.POSIX (POSIXTime)+import Data.Time.LocalTime (LocalTime)+import Data.Word (Word8)+import Text.Blaze (ToMarkup(..))+import Text.Megaparsec (SourcePos(SourcePos), mkPos)  import Hledger.Utils.Regex  --- | A possibly incomplete date, whose missing parts will be filled from a reference date.--- A numeric year, month, and day of month, or the empty string for any of these.--- See the smartdate parser.-type SmartDate = (String,String,String)--data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)--data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,Typeable)--instance Default DateSpan where def = DateSpan Nothing Nothing--instance NFData DateSpan- -- synonyms for various date-related scalars+#if MIN_VERSION_time(1,11,0)+import Data.Time.Calendar (Year)+#else type Year = Integer+#endif type Month = Int     -- 1-12 type Quarter = Int   -- 1-4 type YearWeek = Int  -- 1-52@@ -67,8 +74,65 @@ type MonthDay = Int  -- 1-31 type WeekDay = Int   -- 1-7 --- Typical report periods (spans of time), both finite and open-ended.--- A richer abstraction than DateSpan.+-- | A possibly incomplete year-month-day date provided by the user, to be+-- interpreted as either a date or a date span depending on context. Missing+-- parts "on the left" will be filled from the provided reference date, e.g. if+-- the year and month are missing, the reference date's year and month are used.+-- Missing parts "on the right" are assumed, when interpreting as a date, to be+-- 1, (e.g. if the year and month are present but the day is missing, it means+-- first day of that month); or when interpreting as a date span, to be a+-- wildcard (so it would mean all days of that month). See the `smartdate`+-- parser for more examples.+--+-- Or, one of the standard periods and a numeric offset relative to the reference date:+-- (last|this|next) (day|week|month|quarter|year), where "this" means the period+-- containing the reference date.+--+-- Or, (last|this|next) weekdayname, where "this" "next".+--+-- Or, (last|this|next) monthname, where "this" means the previous 1st if in that month,+-- otherwise the start of the next occurrence of that month.+--+data SmartDate+  = SmartCompleteDate Day+  | SmartAssumeStart Year (Maybe Month)         -- XXX improve these constructor names+  | SmartFromReference (Maybe Month) MonthDay   --+  | SmartMonth Month+  | SmartRelative Integer SmartInterval+  | SmartRelativeMonth Ordering Month           -- ^ EQ will be treated like GT+  | SmartRelativeWeekDay Ordering WeekDay+  deriving (Show)++data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show)++data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)++-- | A date which is either exact or flexible.+-- Flexible dates are allowed to be adjusted in certain situations.+data EFDay = Exact Day | Flex Day deriving (Eq,Generic,Show)++-- EFDay's Ord instance treats them like ordinary dates, ignoring exact/flexible.+instance Ord EFDay where compare d1 d2 = compare (fromEFDay d1) (fromEFDay d2)++-- instance Ord EFDay where compare = maCompare++fromEFDay :: EFDay -> Day+fromEFDay (Exact d) = d+fromEFDay (Flex  d) = d++modifyEFDay :: (Day -> Day) -> EFDay -> EFDay+modifyEFDay f (Exact d) = Exact $ f d+modifyEFDay f (Flex  d) = Flex  $ f d++-- | A possibly open-ended span of time, from an optional inclusive start date+-- to an optional exclusive end date. Each date can be either exact or flexible.+-- An "exact date span" is a Datepan with exact start and end dates.+data DateSpan = DateSpan (Maybe EFDay) (Maybe EFDay) deriving (Eq,Ord,Generic)++instance Default DateSpan where def = DateSpan Nothing Nothing++-- Some common report subperiods, both finite and open-ended.+-- A higher-level abstraction than DateSpan. data Period =     DayPeriod Day   | WeekPeriod Day@@ -79,20 +143,12 @@   | PeriodFrom Day   | PeriodTo Day   | PeriodAll-  deriving (Eq,Ord,Show,Data,Generic,Typeable)+  deriving (Eq,Ord,Show,Generic)  instance Default Period where def = PeriodAll ----- Typical report period/subperiod durations, from a day to a year.---data Duration =---    DayLong---   WeekLong---   MonthLong---   QuarterLong---   YearLong---  deriving (Eq,Ord,Show,Data,Generic,Typeable)---- Ways in which a period can be divided into subperiods.+-- All the kinds of report interval allowed in a period expression+-- (to generate periodic reports or periodic transactions). data Interval =     NoInterval   | Days Int@@ -100,31 +156,89 @@   | Months Int   | Quarters Int   | Years Int-  | DayOfMonth Int-  | WeekdayOfMonth Int Int-  | DayOfWeek Int-  | DayOfYear Int Int -- Month, Day-  -- WeekOfYear Int-  -- MonthOfYear Int-  -- QuarterOfYear Int-  deriving (Eq,Show,Ord,Data,Generic,Typeable)+  | NthWeekdayOfMonth Int Int  -- n,              weekday 1-7+  | MonthDay Int               -- 1-31+  | MonthAndDay Int Int        -- month 1-12,     monthday 1-31+  | DaysOfWeek [Int]           -- [weekday 1-7]+  deriving (Eq,Show,Ord,Generic)  instance Default Interval where def = NoInterval -instance NFData Interval+type Payee = Text  type AccountName = Text +-- A specification indicating how to depth-limit+data DepthSpec = DepthSpec {+  dsFlatDepth    :: Maybe Int,+  dsRegexpDepths :: [(Regexp, Int)]+  } deriving (Eq,Show)++-- Semigroup instance consider all regular expressions, but take the minimum of the simple flat depths+instance Semigroup DepthSpec where+    DepthSpec d1 l1 <> DepthSpec d2 l2 = DepthSpec (getMin <$> (Min <$> d1) <> (Min <$> d2)) (l1 ++ l2)++instance Monoid DepthSpec where+    mempty = DepthSpec Nothing []+ data AccountType =     Asset   | Liability   | Equity   | Revenue   | Expense-  deriving (Show,Eq,Ord,Data,Generic)+  | Cash            -- ^ a subtype of Asset - liquid assets to show in cashflow report+  | Conversion      -- ^ a subtype of Equity - account with which to balance commodity conversions+  | Gain            -- ^ a subtype of Revenue - realised capital gains/losses+  | UnrealisedGain  -- ^ a subtype of Equity - accumulated unrealised capital gains/losses (used by hledger 2)+  deriving (Eq,Ord,Generic) -instance NFData AccountType+instance Show AccountType where+  show Asset          = "A"+  show Liability      = "L"+  show Equity         = "E"+  show Revenue        = "R"+  show Expense        = "X"+  show Cash           = "C"+  show Conversion     = "V"+  show Gain           = "G"+  show UnrealisedGain = "U" +isBalanceSheetAccountType :: AccountType -> Bool+isBalanceSheetAccountType t = t `elem` [+  Asset,+  Liability,+  Equity,+  Cash,+  Conversion,+  UnrealisedGain+  ]++isIncomeStatementAccountType :: AccountType -> Bool+isIncomeStatementAccountType t = t `elem` [+  Revenue,+  Expense,+  Gain+  ]++-- | Check whether the first argument is a subtype of the second: either equal+-- or one of the defined subtypes.+isAccountSubtypeOf :: AccountType -> AccountType -> Bool+isAccountSubtypeOf Asset          Asset          = True+isAccountSubtypeOf Liability      Liability      = True+isAccountSubtypeOf Equity         Equity         = True+isAccountSubtypeOf Revenue        Revenue        = True+isAccountSubtypeOf Expense        Expense        = True+isAccountSubtypeOf Cash           Cash           = True+isAccountSubtypeOf Cash           Asset          = True+isAccountSubtypeOf Conversion     Conversion     = True+isAccountSubtypeOf Conversion     Equity         = True+isAccountSubtypeOf Gain           Gain           = True+isAccountSubtypeOf Gain           Revenue        = True+isAccountSubtypeOf UnrealisedGain UnrealisedGain = True+isAccountSubtypeOf UnrealisedGain Equity         = True+isAccountSubtypeOf _              _              = False+ -- not worth the trouble, letters defined in accountdirectivep for now --instance Read AccountType --  where@@ -137,152 +251,256 @@  data AccountAlias = BasicAlias AccountName AccountName                   | RegexAlias Regexp Replacement-  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)+  deriving (Eq, Read, Show, Ord, Generic) -instance NFData AccountAlias+data Side = L | R deriving (Eq,Show,Read,Ord,Generic) -data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic)+-- | One of the decimal marks we support: either period or comma.+type DecimalMark = Char -instance NFData Side+isDecimalMark :: Char -> Bool+isDecimalMark c = c == '.' || c == ','  -- | The basic numeric type used in amounts. type Quantity = Decimal-deriving instance Data Quantity -- The following is for hledger-web, and requires blaze-markup. -- Doing it here avoids needing a matching flag on the hledger-web package. instance ToMarkup Quantity  where    toMarkup = toMarkup . show---- | An amount's price (none, per unit, or total) in another commodity.--- The price amount should always be positive.-data Price = NoPrice | UnitPrice Amount | TotalPrice Amount -  deriving (Eq,Ord,Typeable,Data,Generic,Show)+deriving instance Generic (DecimalRaw a) -instance NFData Price+-- | An amount's per-unit or total cost/selling price in another+-- commodity, as recorded in the journal entry eg with @ or @@.+-- "Cost", formerly AKA "transaction price". The amount is always positive.+data AmountCost = UnitCost !Amount | TotalCost !Amount+  deriving (Eq,Ord,Generic,Show) --- | Display style for an amount.+-- | Display styles for amounts - things which can be detected during parsing, such as+-- commodity side and spacing, digit group marks, decimal mark, number of decimal digits etc.+-- Every "Amount" has an AmountStyle.+-- After amounts are parsed from the input, for each "Commodity" a standard style is inferred+-- and then used when displaying amounts in that commodity.+-- Related to "AmountFormat" but higher level.+--+-- See also:+-- - hledger manual > Commodity styles+-- - hledger manual > Amounts+-- - hledger manual > Commodity display style data AmountStyle = AmountStyle {-      ascommodityside   :: Side,                 -- ^ does the symbol appear on the left or the right ?-      ascommodityspaced :: Bool,                 -- ^ space between symbol and quantity ?-      asprecision       :: !Int,                 -- ^ number of digits displayed after the decimal point-      asdecimalpoint    :: Maybe Char,           -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default"-      asdigitgroups     :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any-} deriving (Eq,Ord,Read,Typeable,Data,Generic)--instance NFData AmountStyle+  ascommodityside   :: !Side,                     -- ^ show the symbol on the left or the right ?+  ascommodityspaced :: !Bool,                     -- ^ show a space between symbol and quantity ?+  asdigitgroups     :: !(Maybe DigitGroupStyle),  -- ^ show the integer part with these digit group marks, or not+  asdecimalmark     :: !(Maybe Char),             -- ^ show this character (should be . or ,) as decimal mark, or use the default (.)+  asprecision       :: !AmountPrecision,          -- ^ "display precision" - show this number of digits after the decimal point+  asrounding        :: !Rounding                  -- ^ "rounding strategy" - kept here for convenience, for now:+                                                  --   when displaying an amount, it is ignored,+                                                  --   but when applying this style to another amount, it determines +                                                  --   how hard we should try to adjust that amount's display precision.+} deriving (Eq,Ord,Read,Generic)  instance Show AmountStyle where-  show AmountStyle{..} =-    printf "AmountStylePP \"%s %s %s %s %s..\""-    (show ascommodityside)-    (show ascommodityspaced)-    (show asprecision)-    (show asdecimalpoint)-    (show asdigitgroups)+  show AmountStyle{..} = unwords+    [ "AmountStylePP"+    , show ascommodityside+    , show ascommodityspaced+    , show asdigitgroups+    , show asdecimalmark+    , show asprecision+    , show asrounding+    ] +-- | The "display precision" for a hledger amount, by which we mean+-- the number of decimal digits to display to the right of the decimal mark.+data AmountPrecision =+    Precision !Word8    -- ^ show this many decimal digits (0..255)+  | NaturalPrecision    -- ^ show all significant decimal digits stored internally+  deriving (Eq,Ord,Read,Show,Generic)++-- | "Rounding strategy" - how to apply an AmountStyle's display precision+-- to a posting amount (and its cost, if any). +-- Mainly used to customise print's output, with --round=none|soft|hard|all.+data Rounding =+    NoRounding    -- ^ keep display precisions unchanged in amt and cost+  | SoftRounding  -- ^ do soft rounding of amt and cost amounts (show more or fewer decimal zeros to approximate the target precision, but don't hide significant digits)+  | HardRounding  -- ^ do hard rounding of amt (use the exact target precision, possibly hiding significant digits), and soft rounding of cost+  | AllRounding   -- ^ do hard rounding of amt and cost+  deriving (Eq,Ord,Read,Show,Generic)+ -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to -- separate groups (comma or period, whichever is not used as decimal -- point), and the size of each group, starting with the one nearest -- the decimal point. The last group size is assumed to repeat. Eg, -- comma between thousands is DigitGroups ',' [3].-data DigitGroupStyle = DigitGroups Char [Int]-  deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)--instance NFData DigitGroupStyle+data DigitGroupStyle = DigitGroups !Char ![Word8]+  deriving (Eq,Ord,Read,Show,Generic)  type CommoditySymbol = Text  data Commodity = Commodity {-  csymbol :: CommoditySymbol,-  cformat :: Maybe AmountStyle-  } deriving (Show,Eq,Data,Generic) --,Ord,Typeable,Data,Generic)+  csymbol  :: CommoditySymbol,+  cformat  :: Maybe AmountStyle,+  ccomment :: Text,              -- ^ any comment lines following the commodity directive+  ctags    :: [Tag]              -- ^ tags extracted from the comment, if any+  } deriving (Show,Eq,Generic) --,Ord) -instance NFData Commodity+-- | The cost basis of an individual lot - some quantity of an asset acquired at a given date and time.+-- This can represent a definite cost basis, which must have a cost and date; the label is optional.+-- Or it can represent a cost basis matcher for selecting lots.+-- Note: cost is always stored as a per-unit cost, even if the user specified total cost with {{}}.+data CostBasis = CostBasis {+  cbCost  :: !(Maybe Amount),    -- ^ nominal acquisition cost (per-unit)+  cbDate  :: !(Maybe Day),       -- ^ nominal acquisition date+  cbLabel :: !(Maybe Text)       -- ^ a short label to ensure uniqueness, correct intra-day order, or memorability, if needed+} deriving (Show,Eq,Generic,Ord)  data Amount = Amount {-      acommodity  :: CommoditySymbol,   -- commodity symbol, or special value "AUTO"-      aquantity   :: Quantity,          -- numeric quantity, or zero in case of "AUTO"-      aismultiplier :: Bool,            -- ^ kludge: a flag marking this amount and posting as a multiplier-                                        --   in a TMPostingRule. In a regular Posting, should always be false.-      astyle      :: AmountStyle,-      aprice      :: Price            -- ^ the (fixed, transaction-specific) price for this amount, if any-    } deriving (Eq,Ord,Typeable,Data,Generic,Show)+  acommodity  :: !CommoditySymbol,     -- commodity symbol, or special value "AUTO"+  aquantity   :: !Quantity,            -- numeric quantity, or zero in case of "AUTO"+  astyle      :: !AmountStyle,+  acost       :: !(Maybe AmountCost),    -- ^ transacted exchange rate - the unit or total cost, in another commodity, used for this amount within its transaction+  acostbasis  :: !(Maybe CostBasis)    -- ^ the cost basis of an investment lot represented by this amount. Or, a matcher to select such a lot from the available lots.+} deriving (Eq,Ord,Generic,Show) -instance NFData Amount+-- | Types with this class have one or more amounts,+-- which can have display styles applied to them.+class HasAmounts a where+  styleAmounts :: M.Map CommoditySymbol AmountStyle -> a -> a -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic,Show)+instance HasAmounts a =>+  HasAmounts [a]+  where styleAmounts styles = map (styleAmounts styles) -instance NFData MixedAmount+instance (HasAmounts a, HasAmounts b) =>+  HasAmounts (a,b)+  where styleAmounts styles (aa,bb) = (styleAmounts styles aa, styleAmounts styles bb) -data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting-                   deriving (Eq,Show,Typeable,Data,Generic)+instance HasAmounts a =>+  HasAmounts (Maybe a)+  where styleAmounts styles = fmap (styleAmounts styles) -instance NFData PostingType +newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Generic,Show)++instance Eq  MixedAmount where a == b  = maCompare a b == EQ+instance Ord MixedAmount where compare = maCompare++-- | Compare two MixedAmounts, substituting 0 for the quantity of any missing+-- commodities in either.+maCompare :: MixedAmount -> MixedAmount -> Ordering+maCompare (Mixed a) (Mixed b) = go (M.toList a) (M.toList b)+  where+    go xss@((kx,x):xs) yss@((ky,y):ys) = case compare kx ky of+                 EQ -> compareQuantities (Just x) (Just y) <> go xs ys+                 LT -> compareQuantities (Just x) Nothing  <> go xs yss+                 GT -> compareQuantities Nothing  (Just y) <> go xss ys+    go ((_,x):xs) [] = compareQuantities (Just x) Nothing  <> go xs []+    go [] ((_,y):ys) = compareQuantities Nothing  (Just y) <> go [] ys+    go []         [] = EQ+    compareQuantities = comparing (maybe 0 aquantity) <> comparing (maybe 0 totalcost)+    totalcost x = case acost x of+                        Just (TotalCost p) -> aquantity p+                        _                   -> 0++-- | Stores the CommoditySymbol of the Amount, along with the CommoditySymbol of+-- the cost, and its unit cost if being used.+data MixedAmountKey+  = MixedAmountKeyNoCost   !CommoditySymbol+  | MixedAmountKeyTotalCost !CommoditySymbol !CommoditySymbol+  | MixedAmountKeyUnitCost  !CommoditySymbol !CommoditySymbol !Quantity+  deriving (Eq,Generic,Show)++-- | We don't auto-derive the Ord instance because it would give an undesired ordering.+-- We want the keys to be sorted lexicographically:+-- (1) By the primary commodity of the amount.+-- (2) By the commodity of the cost, with no cost being first.+-- (3) By the unit cost, from most negative to most positive, with total costs+-- before unit costs.+-- For example, we would like the ordering to give+-- MixedAmountKeyNoCost "X" < MixedAmountKeyTotalCost "X" "Z" < MixedAmountKeyNoCost "Y"+instance Ord MixedAmountKey where+  compare = comparing commodity <> comparing pCommodity <> comparing pCost+    where+      commodity (MixedAmountKeyNoCost    c)     = c+      commodity (MixedAmountKeyTotalCost c _)   = c+      commodity (MixedAmountKeyUnitCost  c _ _) = c++      pCommodity (MixedAmountKeyNoCost    _)      = Nothing+      pCommodity (MixedAmountKeyTotalCost _ pc)   = Just pc+      pCommodity (MixedAmountKeyUnitCost  _ pc _) = Just pc++      pCost (MixedAmountKeyNoCost    _)     = Nothing+      pCost (MixedAmountKeyTotalCost _ _)   = Nothing+      pCost (MixedAmountKeyUnitCost  _ _ q) = Just q++data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting+                   deriving (Eq,Show,Generic)+ type TagName = Text type TagValue = Text type Tag = (TagName, TagValue)  -- ^ A tag name and (possibly empty) value.+type HiddenTag = Tag            -- ^ A tag whose name begins with _. type DateTag = (TagName, Day) +-- | Add the _ prefix to a normal visible tag's name, making it a hidden tag.+toHiddenTag :: Tag -> HiddenTag+toHiddenTag = first toHiddenTagName++-- | Drop the _ prefix from a hidden tag's name, making it a normal visible tag.+toVisibleTag :: HiddenTag -> Tag+toVisibleTag = first toVisibleTagName++-- | Does this tag name begin with the hidden tag prefix (_) ?+isHiddenTagName :: TagName -> Bool+isHiddenTagName t =+  case T.uncons t of+    Just ('_',_) -> True+    _ -> False++-- | Add the _ prefix to a normal visible tag's name, making it a hidden tag.+toHiddenTagName :: TagName -> TagName+toHiddenTagName = T.cons '_'++-- | Drop the _ prefix from a hidden tag's name, making it a normal visible tag.+toVisibleTagName :: TagName -> TagName+toVisibleTagName = T.drop 1+ -- | The status of a transaction or posting, recorded with a status mark -- (nothing, !, or *). What these mean is ultimately user defined. data Status = Unmarked | Pending | Cleared-  deriving (Eq,Ord,Bounded,Enum,Typeable,Data,Generic)--instance NFData Status+  deriving (Eq,Ord,Bounded,Enum,Generic)  instance Show Status where -- custom show.. bad idea.. don't do it..   show Unmarked = ""   show Pending   = "!"   show Cleared   = "*" +nullsourcepos :: SourcePos+nullsourcepos = SourcePos "" (mkPos 1) (mkPos 1)++nullsourcepospair :: (SourcePos, SourcePos)+nullsourcepospair = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+ -- | A balance assertion is a declaration about an account's expected balance -- at a certain point (posting date and parse order). They provide additional -- error checking and readability to a journal file. ----- The 'BalanceAssertion' type is also used to represent balance assignments,--- which instruct hledger what an account's balance should become at a certain--- point.------ Different kinds of balance assertions are discussed eg on #290.--- Variables include:------ - which postings are to be summed (real/virtual; unmarked/pending/cleared; this account/this account including subs)------ - which commodities within the balance are to be checked------ - whether to do a partial or a total check (disallowing other commodities)------ I suspect we want:------ 1. partial, subaccount-exclusive, Ledger-compatible assertions. Because---    they're what we've always had, and removing them would break some---    journals unnecessarily.  Implemented with = syntax.------ 2. total assertions. Because otherwise assertions are a bit leaky.---    Implemented with == syntax.------ 3. subaccount-inclusive assertions. Because that's something folks need.---    Not implemented.+-- A balance assignments is an instruction to hledger to adjust an+-- account's balance to a certain amount at a certain point. ----- 4. flexible assertions allowing custom criteria (perhaps arbitrary---    queries). Because power users have diverse needs and want to try out---    different schemes (assert cleared balances, assert balance from real or---    virtual postings, etc.). Not implemented.+-- The 'BalanceAssertion' type is used for representing both of these. ----- 5. multicommodity assertions, asserting the balance of multiple commodities---    at once. Not implemented, requires #934.+-- hledger supports multiple kinds of balance assertions/assignments,+-- which differ in whether they refer to a single commodity or all commodities,+-- and the (subaccount-)inclusive or exclusive account balance. -- data BalanceAssertion = BalanceAssertion {-      baamount    :: Amount,             -- ^ the expected balance in a particular commodity-      batotal     :: Bool,               -- ^ disallow additional non-asserted commodities ?-      bainclusive :: Bool,               -- ^ include subaccounts when calculating the actual balance ?-      baposition  :: GenericSourcePos    -- ^ the assertion's file position, for error reporting-    } deriving (Eq,Typeable,Data,Generic,Show)--instance NFData BalanceAssertion+      baamount    :: Amount,    -- ^ the expected balance in a particular commodity+      batotal     :: Bool,      -- ^ disallow additional non-asserted commodities ?+      bainclusive :: Bool,      -- ^ include subaccounts when calculating the actual balance ?+      baposition  :: SourcePos  -- ^ the assertion's file position, for error reporting+    } deriving (Eq,Generic,Show)  data Posting = Posting {       pdate             :: Maybe Day,         -- ^ this posting's date, if different from the transaction's@@ -292,18 +510,17 @@       pamount           :: MixedAmount,       pcomment          :: Text,              -- ^ this posting's comment lines, as a single non-indented multi-line string       ptype             :: PostingType,-      ptags             :: [Tag],                   -- ^ tag names and values, extracted from the comment+      ptags             :: [Tag],                   -- ^ tag names and values, extracted from the posting comment +                                                    --   and (after finalisation) the posting account's directive if any       pbalanceassertion :: Maybe BalanceAssertion,  -- ^ an expected balance in the account after this posting,                                                     --   in a single commodity, excluding subaccounts.       ptransaction      :: Maybe Transaction,       -- ^ this posting's parent transaction (co-recursive types).                                                     --   Tying this knot gets tedious, Maybe makes it easier/optional.       poriginal         :: Maybe Posting            -- ^ When this posting has been transformed in some way-                                                    --   (eg its amount or price was inferred, or the account name was-                                                    --   changed by a pivot or budget report), this references the original +                                                    --   (eg its amount or cost was inferred, or the account name was+                                                    --   changed by a pivot or budget report), this references the original                                                     --   untransformed posting (which will have Nothing in this field).-    } deriving (Typeable,Data,Generic)--instance NFData Posting+    } deriving (Generic)  -- The equality test for postings ignores the parent transaction's -- identity, to avoid recurring ad infinitum.@@ -327,22 +544,10 @@     ,"poriginal="         ++ show poriginal     ] ++ "}" --- TODO: needs renaming, or removal if no longer needed. See also TextPosition in Hledger.UI.Editor--- | The position of parse errors (eg), like parsec's SourcePos but generic.-data GenericSourcePos = GenericSourcePos FilePath Int Int    -- ^ file path, 1-based line number and 1-based column number.-                      | JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last).-  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)--instance NFData GenericSourcePos----{-# ANN Transaction "HLint: ignore" #-}---    Ambiguous type variable ‘p0’ arising from an annotation---    prevents the constraint ‘(Data p0)’ from being solved.---    Probable fix: use a type annotation to specify what ‘p0’ should be. data Transaction = Transaction {       tindex                   :: Integer,   -- ^ this transaction's 1-based position in the transaction stream, or 0 when not available       tprecedingcomment        :: Text,      -- ^ any comment lines immediately preceding this transaction-      tsourcepos               :: GenericSourcePos,  -- ^ the file position where the date starts+      tsourcepos               :: (SourcePos, SourcePos),  -- ^ the file position where the date starts, and where the last posting ends       tdate                    :: Day,       tdate2                   :: Maybe Day,       tstatus                  :: Status,@@ -351,21 +556,17 @@       tcomment                 :: Text,      -- ^ this transaction's comment lines, as a single non-indented multi-line string       ttags                    :: [Tag],     -- ^ tag names and values, extracted from the comment       tpostings                :: [Posting]  -- ^ this transaction's postings-    } deriving (Eq,Typeable,Data,Generic,Show)--instance NFData Transaction+    } deriving (Eq,Generic,Show)  -- | A transaction modifier rule. This has a query which matches postings--- in the journal, and a list of transformations to apply to those +-- in the journal, and a list of transformations to apply to those -- postings or their transactions. Currently there is one kind of transformation:--- the TMPostingRule, which adds a posting ("auto posting") to the transaction, --- optionally setting its amount to the matched posting's amount multiplied by a constant. +-- the TMPostingRule, which adds a posting ("auto posting") to the transaction,+-- optionally setting its amount to the matched posting's amount multiplied by a constant. data TransactionModifier = TransactionModifier {       tmquerytxt :: Text,       tmpostingrules :: [TMPostingRule]-    } deriving (Eq,Typeable,Data,Generic,Show)--instance NFData TransactionModifier+    } deriving (Eq,Generic,Show)  nulltransactionmodifier = TransactionModifier{   tmquerytxt = ""@@ -374,28 +575,33 @@  -- | A transaction modifier transformation, which adds an extra posting -- to the matched posting's transaction.--- Can be like a regular posting, or the amount can have the aismultiplier flag set,+-- Can be like a regular posting, or can have the tmprIsMultiplier flag set, -- indicating that it's a multiplier for the matched posting's amount.-type TMPostingRule = Posting+data TMPostingRule = TMPostingRule+  { tmprPosting :: Posting+  , tmprIsMultiplier :: Bool+  } deriving (Eq,Generic,Show)  -- | A periodic transaction rule, describing a transaction that recurs. data PeriodicTransaction = PeriodicTransaction {       ptperiodexpr   :: Text,     -- ^ the period expression as written-      ptinterval     :: Interval, -- ^ the interval at which this transaction recurs -      ptspan         :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals. +      ptinterval     :: Interval, -- ^ the interval at which this transaction recurs+      ptspan         :: DateSpan, -- ^ the (possibly unbounded) period during which this transaction recurs. Contains a whole number of intervals.       --+      ptsourcepos    :: (SourcePos, SourcePos),  -- ^ the file position where the period expression starts, and where the last posting ends       ptstatus       :: Status,   -- ^ some of Transaction's fields       ptcode         :: Text,       ptdescription  :: Text,       ptcomment      :: Text,       pttags         :: [Tag],       ptpostings     :: [Posting]-    } deriving (Eq,Typeable,Data,Generic) -- , Show in PeriodicTransaction.hs+    } deriving (Eq,Generic) -- , Show in PeriodicTransaction.hs  nullperiodictransaction = PeriodicTransaction{       ptperiodexpr   = ""      ,ptinterval     = def      ,ptspan         = def+     ,ptsourcepos    = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 1) (mkPos 1))      ,ptstatus       = Unmarked      ,ptcode         = ""      ,ptdescription  = ""@@ -404,79 +610,147 @@      ,ptpostings     = [] } -instance NFData PeriodicTransaction--data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)--instance NFData TimeclockCode+data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic)  data TimeclockEntry = TimeclockEntry {-      tlsourcepos   :: GenericSourcePos,+      tlsourcepos   :: SourcePos,       tlcode        :: TimeclockCode,       tldatetime    :: LocalTime,       tlaccount     :: AccountName,-      tldescription :: Text-    } deriving (Eq,Ord,Typeable,Data,Generic)+      tldescription :: Text,+      tlcomment     :: Text,+      tltags        :: [Tag]+    } deriving (Eq,Ord,Generic) -instance NFData TimeclockEntry+-- | A market price declaration made by the journal format's P directive.+-- It declares two things: a historical exchange rate between two commodities,+-- and an amount display style for the second commodity.+data PriceDirective = PriceDirective {+   pdsourcepos :: SourcePos+  ,pddate      :: Day+  ,pdcommodity :: CommoditySymbol+  ,pdamount    :: Amount+  } deriving (Eq,Ord,Generic,Show) +-- | A historical market price (exchange rate) from one commodity to another.+-- A more concise form of a PriceDirective, without the amount display info. data MarketPrice = MarketPrice {-      mpdate      :: Day,-      mpcommodity :: CommoditySymbol,-      mpamount    :: Amount-    } deriving (Eq,Ord,Typeable,Data,Generic) -- , Show in Amount.hs+   mpdate :: Day                -- ^ Date on which this price becomes effective.+  ,mpfrom :: CommoditySymbol    -- ^ The commodity being converted from.+  ,mpto   :: CommoditySymbol    -- ^ The commodity being converted to.+  ,mprate :: Quantity           -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity.+  } deriving (Eq,Ord,Generic, Show) -instance NFData MarketPrice+showMarketPrice MarketPrice{..} = unwords [show mpdate, T.unpack mpfrom <> ">" <> T.unpack mpto, show mprate]+showMarketPrices = intercalate "\n" . map ((' ':).showMarketPrice) . sortBy (comparing mpdate) --- | A Journal, containing transactions and various other things.--- The basic data model for hledger.+-- additional valuation-related types in Valuation.hs++-- | A journal, containing general ledger transactions; also directives and various other things.+-- This is hledger's main data model. ----- This is used during parsing (as the type alias ParsedJournal), and--- then finalised/validated for use as a Journal. Some extra--- parsing-related fields are included for convenience, at least for--- now. In a ParsedJournal these are updated as parsing proceeds, in a--- Journal they represent the final state at end of parsing (used eg--- by the add command).+-- During parsing, it is used as the type alias "ParsedJournal".+-- The jparse* fields are mainly used during parsing and included here for convenience.+-- The list fields described as "in parse order" are usually reversed for efficiency during parsing.+-- After parsing, "journalFinalise" converts ParsedJournal to a finalised "Journal",+-- which has all lists correctly ordered, and much data inference and validation applied. -- data Journal = Journal {-  -- parsing-related data-   jparsedefaultyear      :: Maybe Year                            -- ^ the current default year, specified by the most recent Y directive (or current date)-  ,jparsedefaultcommodity :: Maybe (CommoditySymbol,AmountStyle)   -- ^ the current default commodity and its format, specified by the most recent D directive-  ,jparseparentaccounts   :: [AccountName]                         -- ^ the current stack of parent account names, specified by apply account directives-  ,jparsealiases          :: [AccountAlias]                        -- ^ the current account name aliases in effect, specified by alias directives (& options ?)+  -- parsing-related state+   jparsedefaultyear        :: Maybe Year                             -- ^ the current default year, specified by the most recent Y directive (or current date)+  ,jparsedefaultcommodity   :: Maybe (CommoditySymbol,AmountStyle)    -- ^ the current default commodity and its format, specified by the most recent D directive+  ,jparsedecimalmark        :: Maybe DecimalMark                      -- ^ the character to always parse as decimal point, if set by CsvReader's decimal-mark (or a future journal directive)+  ,jparseparentaccounts     :: [AccountName]                          -- ^ the current stack of parent account names, specified by apply account directives+  ,jparsealiases            :: [AccountAlias]                         -- ^ the current account name aliases in effect, specified by alias directives (& options ?)   -- ,jparsetransactioncount :: Integer                               -- ^ the current count of transactions parsed so far (only journal format txns, currently)-  ,jparsetimeclockentries :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out-  ,jincludefilestack      :: [FilePath]-  -- principal data-  ,jdeclaredaccounts      :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) -  ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]        -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts) -  ,jcommodities           :: M.Map CommoditySymbol Commodity        -- ^ commodities and formats declared by commodity directives-  ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle      -- ^ commodities and formats inferred from journal amounts  TODO misnamed - jusedstyles-  ,jmarketprices          :: [MarketPrice]-  ,jtxnmodifiers          :: [TransactionModifier]-  ,jperiodictxns          :: [PeriodicTransaction]-  ,jtxns                  :: [Transaction]-  ,jfinalcommentlines     :: Text                                   -- ^ any final trailing comments in the (main) journal file-  ,jfiles                 :: [(FilePath, Text)]                     -- ^ the file path and raw text of the main and-                                                                    --   any included journal files. The main file is first,-                                                                    --   followed by any included files in the order encountered.-  ,jlastreadtime          :: ClockTime                              -- ^ when this journal was last read from its file(s)-  } deriving (Eq, Typeable, Data, Generic)--deriving instance Data ClockTime-deriving instance Typeable ClockTime-deriving instance Generic ClockTime-instance NFData ClockTime-instance NFData Journal+  ,jparsetimeclockentries   :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out+  ,jincludefilestack        :: [(FilePath, FilePath)]                 -- ^ (absolute path, canonical path) of included files, most recent first+-- principal data+  ,jdeclaredpayees          :: [(Payee,PayeeDeclarationInfo)]         -- ^ Payees declared by payee directives, in parse order.+  ,jdeclaredtags            :: [(TagName,TagDeclarationInfo)]         -- ^ Tags declared by tag directives, in parse order.+  ,jdeclaredaccounts        :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order.+  ,jdeclaredaccounttags     :: M.Map AccountName [Tag]                -- ^ Accounts which were declared with tags, and those tags.+  ,jdeclaredaccounttypes    :: M.Map AccountType [AccountName]        -- ^ Accounts which were declared with a type: tag, grouped by the type.+  ,jaccounttypes            :: M.Map AccountName AccountType          -- ^ All the account types known, from account declarations or account names or parent accounts.+  ,jdeclaredcommodities     :: M.Map CommoditySymbol Commodity        -- ^ Commodities (and their display styles) declared by commodity directives, in parse order.+  ,jdeclaredcommoditytags   :: M.Map CommoditySymbol [Tag]            -- ^ Commodities which were declared with tags, and those tags.+  ,jinferredcommoditystyles :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles inferred from amounts in the journal.+  ,jglobalcommoditystyles   :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles declared by command line options (sometimes augmented, see the import command).+  ,jpricedirectives         :: [PriceDirective]                       -- ^ P (market price) directives in the journal, in parse order.+  ,jinferredmarketprices    :: [MarketPrice]                          -- ^ Market prices inferred from transactions in the journal, in parse order.+  ,jtxnmodifiers            :: [TransactionModifier]                  -- ^ Auto posting rules declared in the journal.+  ,jperiodictxns            :: [PeriodicTransaction]                  -- ^ Periodic transaction rules declared in the journal.+  ,jtxns                    :: [Transaction]                          -- ^ Transactions recorded in the journal. The important bit.+  ,jfinalcommentlines       :: Text                                   -- ^ any final trailing comments in the (main) journal file+  ,jfiles                   :: [(FilePath, Text)]                     -- ^ the file path and raw text of the main and+                                                                      --   any included journal files. The main file is first,+                                                                      --   followed by any included files in the order encountered.+                                                                      --   TODO: FilePath is a sloppy type here, don't assume it's a+                                                                      --   real file; values like "" or "-" can be seen+  ,jlastreadtime            :: POSIXTime                              -- ^ when this journal was last read from its file(s)+  -- NOTE: after adding new fields, eg involving account names, consider updating+  -- the Anon instance in Hleger.Cli.Anon+  } deriving (Eq, Generic)  -- | A journal in the process of being parsed, not yet finalised. -- The data is partial, and list fields are in reverse order. type ParsedJournal = Journal +-- | One of the standard *-separated value file types known by hledger,+data SepFormat +  = Csv  -- comma-separated+  | Tsv  -- tab-separated+  | Ssv  -- semicolon-separated+  deriving (Eq, Ord)++-- XXX A little confusion, this is also used to name readers in splitReaderPrefix.+-- readers, input formats, and output formats overlap but are distinct concepts. -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output.-type StorageFormat = String+data StorageFormat +  = Rules +  | Journal' +  | Ledger' +  | Timeclock +  | Timedot +  | Sep SepFormat +  deriving (Eq, Ord) +instance Show SepFormat where+  show Csv = "csv"+  show Ssv = "ssv"+  show Tsv = "tsv"++instance Show StorageFormat where+  show Rules = "rules"+  show Journal' = "journal"+  show Ledger' = "ledger"+  show Timeclock = "timeclock"+  show Timedot = "timedot"+  show (Sep Csv) = "csv"+  show (Sep Ssv) = "ssv"+  show (Sep Tsv) = "tsv"++-- | Extra information found in a payee directive.+data PayeeDeclarationInfo = PayeeDeclarationInfo {+   pdicomment :: Text   -- ^ any comment lines following the payee directive+  ,pditags    :: [Tag]  -- ^ tags extracted from the comment, if any+} deriving (Eq,Show,Generic)++nullpayeedeclarationinfo = PayeeDeclarationInfo {+   pdicomment          = ""+  ,pditags             = []+}++-- | Extra information found in a tag directive.+newtype TagDeclarationInfo = TagDeclarationInfo {+   tdicomment :: Text   -- ^ any comment lines following the tag directive. No tags allowed here.+} deriving (Eq,Show,Generic)++nulltagdeclarationinfo = TagDeclarationInfo {+   tdicomment          = ""+}+ -- | Extra information about an account that can be derived from -- its account directive (and the other account directives). data AccountDeclarationInfo = AccountDeclarationInfo {@@ -484,44 +758,98 @@   ,aditags             :: [Tag]  -- ^ tags extracted from the account comment, if any   ,adideclarationorder :: Int    -- ^ the order in which this account was declared,                                  --   relative to other account declarations, during parsing (1..)-} deriving (Eq,Show,Data,Generic)--instance NFData AccountDeclarationInfo+  ,adisourcepos        :: SourcePos  -- ^ source file and position+} deriving (Eq,Show,Generic)  nullaccountdeclarationinfo = AccountDeclarationInfo {    adicomment          = ""   ,aditags             = []   ,adideclarationorder = 0+  ,adisourcepos        = SourcePos "" (mkPos 1) (mkPos 1) } --- | An account, with its balances, parent/subaccount relationships, etc.--- Only the name is required; the other fields are added when needed.-data Account = Account {-   aname                     :: AccountName    -- ^ this account's full name+-- | An account within a hierarchy, with references to its parent+-- and subaccounts if any, and with per-report-period data of type 'a'.+-- Only the name is required; the other fields may or may not be present.+data Account a = Account {+   aname                     :: AccountName        -- ^ full name   ,adeclarationinfo          :: Maybe AccountDeclarationInfo  -- ^ optional extra info from account directives   -- relationships in the tree-  ,asubs                     :: [Account]      -- ^ this account's sub-accounts-  ,aparent                   :: Maybe Account  -- ^ parent account-  ,aboring                   :: Bool           -- ^ used in the accounts report to label elidable parents-  -- balance information-  ,anumpostings              :: Int            -- ^ the number of postings to this account-  ,aebalance                 :: MixedAmount    -- ^ this account's balance, excluding subaccounts-  ,aibalance                 :: MixedAmount    -- ^ this account's balance, including subaccounts-  } deriving (Typeable, Data, Generic)+  ,asubs                     :: [Account a]        -- ^ subaccounts+  ,aparent                   :: Maybe (Account a)  -- ^ parent account+  ,aboring                   :: Bool               -- ^ used in some reports to indicate elidable accounts+  ,adata                     :: PeriodData a       -- ^ associated data per report period+  } deriving (Generic, Functor) --- | Whether an account's balance is normally a positive number (in --- accounting terms, a debit balance) or a negative number (credit balance). +-- | A general container for storing data values associated with zero or more+-- contiguous report (sub)periods, and with the (open ended) pre-report period.+-- The report periods are typically all the same length, but need not be.+--+-- Report periods are represented only by their start dates, used as the keys of a Map.+data PeriodData a = PeriodData {+   pdpre     :: a            -- ^ data for the period before the report+  ,pdperiods :: M.Map Day a  -- ^ data for each period within the report+  } deriving (Eq, Ord, Functor, Generic)++-- | Data that's useful in "balance" reports:+-- subaccount-exclusive and -inclusive amounts,+-- typically representing either a balance change or an end balance;+-- and a count of postings.+data BalanceData = BalanceData {+   bdexcludingsubs :: MixedAmount  -- ^ balance data excluding subaccounts+  ,bdincludingsubs :: MixedAmount  -- ^ balance data including subaccounts+  ,bdnumpostings :: Int            -- ^ the number of postings+  } deriving (Eq, Generic)++-- | Whether an account's balance is normally a positive number (in+-- accounting terms, a debit balance) or a negative number (credit balance). -- Assets and expenses are normally positive (debit), while liabilities, equity -- and income are normally negative (credit). -- https://en.wikipedia.org/wiki/Normal_balance-data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Data, Eq) +data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Eq)  -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and -- tree-wise, since each one knows its parent and subs; the first -- account is the root of the tree and always exists. data Ledger = Ledger {-  ljournal  :: Journal,-  laccounts :: [Account]-}+   ljournal  :: Journal+  ,laccounts :: [Account BalanceData]+  } deriving (Generic) +instance NFData AccountAlias+instance NFData AccountDeclarationInfo+instance NFData AccountType+instance NFData Amount+instance NFData AmountCost+instance NFData AmountPrecision+instance NFData AmountStyle+instance NFData BalanceAssertion+instance NFData Commodity+instance NFData CostBasis+instance NFData DateSpan+instance NFData DigitGroupStyle+instance NFData EFDay+instance NFData Interval+instance NFData Journal+instance NFData MarketPrice+instance NFData MixedAmount+instance NFData MixedAmountKey+instance NFData Rounding+instance NFData PayeeDeclarationInfo+instance NFData PeriodicTransaction+instance NFData PostingType+instance NFData PriceDirective+instance NFData Side+instance NFData Status+instance NFData TagDeclarationInfo+instance NFData TimeclockCode+instance NFData TimeclockEntry+instance NFData TMPostingRule+instance NFData Transaction+instance NFData TransactionModifier++instance NFData Posting where+  -- Do not call rnf on the parent transaction to avoid recursive loops+  rnf (Posting d d2 s n a c t ta b mt op) =+      rnf d `seq` rnf d2 `seq` rnf s `seq` rnf n `seq` rnf a `seq` rnf c `seq` rnf t `seq` rnf ta `seq` rnf b `seq` mt `seq` rnf op `seq` ()
+ Hledger/Data/Valuation.hs view
@@ -0,0 +1,608 @@+{-|++Convert amounts to some related value in various ways. This involves+looking up historical market prices (exchange rates) between commodities.++-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}++module Hledger.Data.Valuation (+   ConversionOp(..)+  ,ValuationType(..)+  ,PriceOracle+  ,journalPriceOracle+  ,mixedAmountToCost+  ,mixedAmountApplyValuation+  ,mixedAmountValueAtDate+  ,mixedAmountApplyGain+  ,mixedAmountGainAtDate+  ,marketPriceReverse+  ,priceDirectiveToMarketPrice+  ,amountPriceDirectiveFromCost+  ,valuationTypeValuationCommodity+  -- ,priceLookup+  ,tests_Valuation+)+where++import Control.Applicative ((<|>))+import Data.Function ((&))+import Data.List (partition, intercalate, sortBy)+import Data.Map qualified as M+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Time.Calendar (Day, fromGregorian)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.MemoUgly (memo)+import GHC.Generics (Generic)+import Safe (headMay, lastMay)++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.Amount+import Hledger.Data.Dates (nulldate)+import Text.Printf (printf)+import Data.Decimal (decimalPlaces, roundTo, Decimal)+import Data.Word (Word8)+++------------------------------------------------------------------------------+-- Types++-- | Which operation to perform on conversion transactions.+-- (There was also an "infer equity postings" operation, but that is now done +-- earlier, in journal finalisation.)+data ConversionOp = NoConversionOp | ToCost+  deriving (Show,Eq)++-- | What kind of value conversion should be done on amounts ?+-- CLI: --value=then|end|now|DATE[,COMM]+data ValuationType =+    AtThen     (Maybe CommoditySymbol)  -- ^ convert to default or given valuation commodity, using market prices at each posting's date+  | AtEnd      (Maybe CommoditySymbol)  -- ^ convert to default or given valuation commodity, using market prices at period end(s)+  | AtNow      (Maybe CommoditySymbol)  -- ^ convert to default or given valuation commodity, using current market prices+  | AtDate Day (Maybe CommoditySymbol)  -- ^ convert to default or given valuation commodity, using market prices on some date+  deriving (Show,Eq)++valuationTypeValuationCommodity :: ValuationType -> Maybe CommoditySymbol+valuationTypeValuationCommodity = \case+    AtThen   (Just c) -> Just c+    AtEnd    (Just c) -> Just c+    AtNow    (Just c) -> Just c+    AtDate _ (Just c) -> Just c+    _                 -> Nothing++-- | A price oracle is a magic memoising function that efficiently+-- looks up market prices (exchange rates) from one commodity to+-- another (or if unspecified, to a default valuation commodity) on a+-- given date.+type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity)++-- | An index of market prices for efficient lookup by commodity pair and date.+-- Maps each (from, to) commodity pair to a Map from date to the effective price,+-- where declared prices take precedence over inferred prices on the same day.+-- This allows O(log n) lookup per pair via M.lookupLE.+type PriceIndex = M.Map (CommoditySymbol, CommoditySymbol) (M.Map Day MarketPrice)++-- | Build a price index from declared and inferred market prices.+-- This is O(n log n) but done only once, enabling fast lookups later.+buildPriceIndex :: [MarketPrice] -> [MarketPrice] -> PriceIndex+buildPriceIndex declaredprices inferredprices =+  let+    -- Label each price with precedence (declared=True > inferred=False) and parse order+    declaredprices' = [(mpdate p, True, i, p) | (i, p) <- zip [1..] declaredprices]+    inferredprices' = [(mpdate p, False, i, p) | (i, p) <- zip [1..] inferredprices]+    allprices = declaredprices' ++ inferredprices'+    -- Group by commodity pair+    grouped = M.fromListWith (++)+      [((mpfrom p, mpto p), [(d, prec, order, p)]) | (d, prec, order, p) <- allprices]+    -- Build inner Map: sort ascending by (date, prec, order), then M.fromList+    -- keeps the last entry per date (highest precedence/parseorder wins)+    buildInnerMap prices =+      prices+      & sortBy compare+      & map (\(d, _, _, p) -> (d, p))+      & M.fromList+  in+    M.map buildInnerMap grouped++-- | Look up effective prices for all commodity pairs at a given date using the index.+-- Returns at most one price per commodity pair: the latest price on or before the date.+-- O(pairs × log n) where n is the number of prices per pair.+lookupEffectivePricesFromIndex :: Day -> PriceIndex -> [MarketPrice]+lookupEffectivePricesFromIndex d idx =+  mapMaybe (fmap snd . M.lookupLE d) (M.elems idx)++-- | Index for default valuation commodity lookup.+-- Maps source commodity to a map of (date -> destination), supporting O(log n) lookup+-- of the latest destination commodity on or before any given date.+type DefaultValuationIndex = M.Map CommoditySymbol (M.Map Day CommoditySymbol)++-- | Build an index for default valuation commodity lookup from a list of market prices.+buildDefaultValuationIndex :: [MarketPrice] -> DefaultValuationIndex+buildDefaultValuationIndex prices =+  let+    -- Label with parse order+    labeled = [(mpfrom p, mpdate p, i, mpto p) | (i, p) <- zip [1..] prices]+    -- Group by source commodity+    grouped = M.fromListWith (++) [(from, [(d, ord, to)]) | (from, d, ord, to) <- labeled]+    -- Build inner Map: sort by (date, parseorder), then M.fromList keeps last (highest parseorder per date)+    buildInnerMap entries = M.fromList [(d, to) | (d, _, to) <- sortBy compare entries]+  in+    M.map buildInnerMap grouped++-- | Combined indexes for efficient price lookup.+data PriceIndexes = PriceIndexes+  { piForward :: !PriceIndex                    -- ^ Index for forward prices (declared + inferred)+  , piDeclaredDefault :: !DefaultValuationIndex -- ^ Index for declared prices (for default valuation)+  , piInferredDefault :: !DefaultValuationIndex -- ^ Index for inferred prices (fallback for default valuation)+  }++-- | Build all price indexes from declared and inferred market prices.+-- This is O(n log n) but done only once.+buildPriceIndexes :: [MarketPrice] -> [MarketPrice] -> PriceIndexes+buildPriceIndexes declaredprices inferredprices = PriceIndexes+  { piForward = buildPriceIndex declaredprices inferredprices+  , piDeclaredDefault = buildDefaultValuationIndex declaredprices+  , piInferredDefault = buildDefaultValuationIndex inferredprices+  }++-- | Look up default valuation commodities for all source commodities at a given date.+-- Fallback logic: declared at date d, then declared at any date, then inferred at date d.+lookupDefaultValuations :: Day -> PriceIndexes -> M.Map CommoditySymbol CommoditySymbol+lookupDefaultValuations d PriceIndexes{..} =+    fromMaybe fallback (tryDeclaredAtDate <|> tryDeclaredLatest)+  where+    nonEmpty m = if M.null m then Nothing else Just m++    tryDeclaredAtDate = nonEmpty $ lookupDefaults (Just d) piDeclaredDefault+    tryDeclaredLatest = nonEmpty $ lookupDefaults Nothing  piDeclaredDefault+    fallback          = lookupDefaults (Just d) piInferredDefault++    lookupDefaults mdate = M.mapMaybe $ \innerMap ->+      case mdate of+        Nothing -> snd <$> M.lookupMax innerMap+        Just dt -> snd <$> M.lookupLE dt innerMap++-- | Generate a price oracle (memoising price lookup function) from a+-- journal's directive-declared and transaction-inferred market+-- prices. For best performance, generate this only once per journal,+-- reusing it across reports if there are more than one, as+-- compoundBalanceCommand does.+-- The boolean argument is whether to infer market prices from+-- transactions or not.+journalPriceOracle :: Bool -> Journal -> PriceOracle+journalPriceOracle infer Journal{jpricedirectives, jinferredmarketprices} =+  let+    declaredprices = map priceDirectiveToMarketPrice jpricedirectives+    inferredprices =+      (if infer then jinferredmarketprices else [])+      & dbg2Msg ("use prices inferred from costs? " <> if infer then "yes" else "no")+    -- Build indexes once for all lookups+    indexes = buildPriceIndexes declaredprices inferredprices+    makepricegraph = memo $ makePriceGraph indexes+  in+    memo $ uncurry3 $ priceLookup makepricegraph++priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice+priceDirectiveToMarketPrice PriceDirective{..} =+  MarketPrice{ mpdate = pddate+             , mpfrom = pdcommodity+             , mpto   = acommodity pdamount+             , mprate = aquantity pdamount+             }++-- | Infer a market price from the given amount and its cost (if any),+-- and make a corresponding price directive on the given date.+-- The price's display precision will be set to show all significant+-- decimal digits; or if they seem to be infinite, defaultPrecisionLimit.+amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective+amountPriceDirectiveFromCost d amt@Amount{acommodity=fromcomm, aquantity=n} = case acost amt of+    Just (UnitCost u)           -> Just $ pd{pdamount=u}+    Just (TotalCost t) | n /= 0 -> Just $ pd{pdamount=u}+      where u = amountSetFullPrecisionUpTo Nothing $ divideAmount n t+    _                            -> Nothing+  where+    pd = PriceDirective{pdsourcepos=nullsourcepos, pddate=d, pdcommodity=fromcomm, pdamount=nullamt}++------------------------------------------------------------------------------+-- Converting things to value++-- | Convert all component amounts to cost/selling price if requested, and style them.+mixedAmountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> MixedAmount -> MixedAmount+mixedAmountToCost styles cost = mapMixedAmount (amountToCost styles cost)++-- | Apply a specified valuation to this mixed amount, using the+-- provided price oracle, commodity styles, and reference dates.+-- See amountApplyValuation.+mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> MixedAmount -> MixedAmount+mixedAmountApplyValuation priceoracle styles periodlast today postingdate v =+  mapMixedAmount (amountApplyValuation priceoracle styles periodlast today postingdate v)++-- | Convert an Amount to its cost if requested, and style it appropriately.+amountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount+amountToCost styles ToCost         = styleAmounts styles . amountCost+amountToCost _      NoConversionOp = id++-- | Apply a specified valuation to this amount, using the provided+-- price oracle, and reference dates. Also fix up its display style+-- using the provided commodity styles.+--+-- When the valuation requires converting to another commodity, a+-- valuation (conversion) date is chosen based on the valuation type+-- and the provided reference dates. It will be one of:+--+-- - the date of the posting itself (--value=then)+--+-- - the provided "period end" date - this is typically the last day+--   of a subperiod (--value=end with a multi-period report), or of+--   the specified report period or the journal (--value=end with a+--   single-period report).+--+-- - the provided "today" date (--value=now).+--+-- - a fixed date specified by the ValuationType itself+--   (--value=DATE).+--+-- This is all a bit complicated. See the reference doc at+-- https://hledger.org/hledger.html#effect-of-valuation-on-reports+-- (hledger_options.m4.md "Effect of valuation on reports"), and #1083.+--+amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> Amount -> Amount+amountApplyValuation priceoracle styles periodlast today postingdate v a =+  case v of+    AtThen    mc      -> amountValueAtDate priceoracle styles mc postingdate a+    AtEnd     mc      -> amountValueAtDate priceoracle styles mc periodlast a+    AtNow     mc      -> amountValueAtDate priceoracle styles mc today a+    AtDate d  mc      -> amountValueAtDate priceoracle styles mc d a++-- | Find the market value of each component amount in the given+-- commodity, or its default valuation commodity, at the given+-- valuation date, using the given market price oracle.+-- When market prices available on that date are not sufficient to+-- calculate the value, amounts are left unchanged.+mixedAmountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount+mixedAmountValueAtDate priceoracle styles mc d = mapMixedAmount (amountValueAtDate priceoracle styles mc d)++-- | Find the market value of this amount in the given valuation+-- commodity if any, otherwise the default valuation commodity, at the+-- given valuation date. (The default valuation commodity is the+-- commodity of the latest applicable market price before the+-- valuation date.)+--+-- The returned amount will have its commodity's canonical style applied,+-- (with soft display rounding).+--+-- If the market prices available on that date are not sufficient to+-- calculate this value, the amount is left unchanged.+--+amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount+amountValueAtDate priceoracle styles mto d a =+  let lbl = lbl_ "amountValueAtDate" in+  case priceoracle (d, acommodity a, mto) of+    Nothing           -> a+    Just (comm, rate) ->+      nullamt{acommodity=comm, aquantity=rate * aquantity a}++      -- Manage style and precision of the new amount. Initially:+      --  rate is a Decimal with the internal precision of the original market price declaration.+      --  aquantity is a Decimal with a's internal precision.+      --  The calculated value's internal precision may be different from these.+      --  Its display precision will be that of nullamt (0).+      -- Now apply the standard display style for comm (if there is one)+      & styleAmounts styles+      -- set the display precision to match the internal precision (showing all digits),+      -- unnormalised (don't strip trailing zeros);+      -- but if it looks like an infinite decimal, limit the precision to 8.+      & amountSetFullPrecisionUpTo Nothing+      & dbg9With (lbl "calculated value".showAmount)++-- | Calculate the gain of each component amount, that is the difference+-- between the valued amount and the value of the cost basis (see+-- mixedAmountApplyValuation).+--+-- If the commodity we are valuing in is not the same as the commodity of the+-- cost, this will value the cost at the same date as the primary amount. This+-- may not be what you want; for example you may want the cost valued at the+-- posting date. If so, let us know and we can change this behaviour.+mixedAmountApplyGain :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> MixedAmount -> MixedAmount+mixedAmountApplyGain priceoracle styles periodlast today postingdate v ma =+  mixedAmountApplyValuation priceoracle styles periodlast today postingdate v $ ma `maMinus` mixedAmountCost ma++-- | Calculate the gain of each component amount, that is the+-- difference between the valued amount and the value of the cost basis.+--+-- If the commodity we are valuing in is not the same as the commodity of the+-- cost, this will value the cost at the same date as the primary amount. This+-- may not be what you want; for example you may want the cost valued at the+-- posting date. If so, let us know and we can change this behaviour.+mixedAmountGainAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount+mixedAmountGainAtDate priceoracle styles mto d ma =+  mixedAmountValueAtDate priceoracle styles mto d $ ma `maMinus` mixedAmountCost ma++------------------------------------------------------------------------------+-- Market price lookup++-- | Given a memoising price graph generator, a valuation date, a+-- source commodity and an optional valuation commodity, find the+-- value on that date of one unit of the source commodity in the+-- valuation commodity, or in a default valuation commodity. Returns+-- the valuation commodity that was specified or chosen, and the+-- quantity of it that one unit of the source commodity is worth. Or+-- if no applicable market price can be found or calculated, or if the+-- source commodity and the valuation commodity are the same, returns+-- Nothing.+--+-- See makePriceGraph for how prices are determined.+-- Note that both market prices and default valuation commodities can+-- vary with valuation date, since that determines which market prices+-- are visible.+--+priceLookup :: (Day -> PriceGraph) -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)+priceLookup makepricegraph d from mto =+  -- trace ("priceLookup ("++show d++", "++show from++", "++show mto++")") $+  let+    PriceGraph{pgEdges=forwardprices+              ,pgEdgesRev=allprices+              ,pgDefaultValuationCommodities=defaultdests+              } =+      dbg1Msg ("valuation date: "++show d) $ makepricegraph d+    mto' = mto <|> mdefaultto+      where+        mdefaultto = dbg1 ("default valuation commodity for "++T.unpack from) $+                     M.lookup from defaultdests+  in+    case mto' of+      Nothing            -> Nothing+      Just to | to==from -> Nothing+      Just to            ->+        -- We have a commodity to convert to. Find the most direct price available,+        -- according to the rules described in makePriceGraph.+        let+          msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to)+          prices =+            (dbg2Msg (msg++" using forward prices") $+             dbg2Msg ("forward prices:\n" <> showMarketPrices forwardprices) $+             pricesShortestPath from to forwardprices)+            <|>+            (dbg2Msg (msg++" using forward and reverse prices") $+             dbg2Msg ("forward and reverse prices:\n" <> showMarketPrices allprices) $+             pricesShortestPath from to $ dbg5 "all forward and reverse prices" allprices)+        in case prices of+          Nothing -> Nothing+          Just [] -> Nothing+          Just ps -> Just (mpto $ last ps, rate)+            where+              rates = map mprate ps+              rate =+                -- aggregate all the prices into one+                product rates+                -- product (Decimal's Num instance) normalises, stripping trailing zeros.+                -- But we want to preserve even those, since the number of decimal digits+                -- here will guide amountValueAtDate in setting the Amount display precision later.+                -- So we restore them. Or rather, we ensure as many decimal digits as the maximum seen among rates.+                -- (Some prices might end up more precise than they were, but that seems harmless here.)+                & setMinDecimalPlaces (maximum $ map decimalPlaces rates)++-- Ensure this Decimal has at least this many decimal places, adding trailing zeros if necessary.+setMinDecimalPlaces :: Word8 -> Decimal -> Decimal+setMinDecimalPlaces n d+  | decimalPlaces d < n = roundTo n d  -- too few, add some zeros+  | otherwise           = d            -- more than enough, keep as-is++tests_priceLookup =+  let+    p y m d from q to = MarketPrice{mpdate=fromGregorian y m d, mpfrom=from, mpto=to, mprate=q}+    ps1 = [+       p 2000 01 01 "A" 10 "B"+      ,p 2000 01 01 "B" 10 "C"+      ,p 2000 01 01 "C" 10 "D"+      ,p 2000 01 01 "E"  2 "D"+      ,p 2001 01 01 "A" 11 "B"+      ]+    makepricegraph = makePriceGraph (buildPriceIndexes ps1 [])+  in testCase "priceLookup" $ do+    priceLookup makepricegraph (fromGregorian 1999 01 01) "A" Nothing    @?= Nothing+    priceLookup makepricegraph (fromGregorian 2000 01 01) "A" Nothing    @?= Just ("B",10)+    priceLookup makepricegraph (fromGregorian 2000 01 01) "B" (Just "A") @?= Just ("A",0.1)+    priceLookup makepricegraph (fromGregorian 2000 01 01) "A" (Just "E") @?= Just ("E",500)++------------------------------------------------------------------------------+-- Market price graph+-- built directly with MarketPrices for now, probably space-inefficient++type Edge = MarketPrice+type Path = [Edge]++data PriceGraph = PriceGraph {+   pgDate :: Day+    -- ^ The date on which these prices are in effect.+  ,pgEdges :: [Edge]+    -- ^ "Forward" exchange rates between commodity pairs, either+    --   declared by P directives or (with --infer-market-prices) inferred from costs,+    --   forming the edges of a directed graph.  +  ,pgEdgesRev :: [Edge]+    -- ^ The same edges, plus any additional edges that can be+    --   inferred by reversing them and inverting the rates.+    --+    --   In both of these there will be at most one edge between each+    --   directed pair of commodities, eg there can be one USD->EUR and one EUR->USD.+    --+  ,pgDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol+    -- ^ The default valuation commodity for each source commodity.+    --   These are used when a valuation commodity is not specified+    --   (-V). They are the destination commodity of each source commodity's+    --   latest (declared or inferred, but not reverse) market price+    --   (on the date of this graph).+  }+  deriving (Show,Generic)++-- | Find the shortest path and corresponding conversion rate, if any, +-- from one commodity to another using the provided market prices which+-- form the edges of a directed graph. There should be at most one edge+-- between each directed pair of commodities, eg there can be one+-- USD->EUR price and one EUR->USD price.+pricesShortestPath :: CommoditySymbol -> CommoditySymbol -> [Edge] -> Maybe Path+pricesShortestPath start end edges =+  -- at --debug=2 +, print the pretty path and also the detailed prices+  let label = printf "shortest path from %s to %s: " (showCommoditySymbol start) (showCommoditySymbol end) in+  fmap (dbg2With (("price chain:\n"++).showMarketPrices)) $+  dbg2With ((label++).(maybe "none" (pshowpath ""))) $+  find [([],edges)]++  where+    -- Find the first and shortest complete path using a breadth-first search.+    find :: [(Path,[Edge])] -> Maybe Path+    find paths =+      case concatMap extend paths of+        [] -> Nothing +        _ | pathlength > maxpathlength -> +          -- Print a non-fatal warning to stderr, something we usually avoid.+          warn ("gave up searching for a price chain at length "++show maxpathlength++", please report a bug")+          Nothing+          where +            pathlength = 2 + maybe 0 (length . fst) (headMay paths)+            maxpathlength = 1000+        paths' -> +          case completepaths of+                p:_ -> Just p  -- the left-most complete path at this length+                []  -> find paths'+          where completepaths = [p | (p,_) <- paths', (mpto <$> lastMay p) == Just end]++    -- Use all applicable edges from those provided to extend this path by one step,+    -- returning zero or more new (path, remaining edges) pairs.+    extend :: (Path,[Edge]) -> [(Path,[Edge])]+    extend (path,unusededges) =+      let+        pathnodes = start : map mpto path+        pathend = maybe start mpto $ lastMay path+        (nextedges,remainingedges) = partition ((==pathend).mpfrom) unusededges+      in+        [ (path', remainingedges')+        | e <- nextedges+        , let path' = dbgpath "trying" $ path ++ [e]  -- PERF prepend ?+        , let pathnodes' = mpto e : pathnodes+        , let remainingedges' = [r | r <- remainingedges, mpto r `notElem` pathnodes' ]+        ]++-- debug helpers+dbgpath  label = dbg2With (pshowpath label)+-- dbgedges label = dbg2With (pshowedges label)+pshowpath label = \case+  []      -> prefix label ""+  p@(e:_) -> prefix label $ pshownode (mpfrom e) ++ ">" ++ intercalate ">" (map (pshownode . mpto) p)+-- pshowedges label = prefix label . intercalate ", " . map (pshowedge "")+-- pshowedge label MarketPrice{..} = pshowedge' label mpfrom mpto+-- pshowedge' label from to = prefix label $ pshownode from ++ ">" ++ pshownode to+pshownode = T.unpack . showCommoditySymbol+prefix l = if null l then (""++) else ((l++": ")++)++-- | A snapshot of the known exchange rates between commodity pairs at a given date.+-- This is a home-made version, more tailored to our needs.+-- | Build the graph of commodity conversion prices for a given day.+-- Converts a list of declared market prices in parse order, and a+-- list of transaction-inferred market prices in parse order, to:+--+-- 1. a graph of all known exchange rates declared or inferred from +-- one commodity to another in effect on that day+--+-- 2. a second graph which includes any additional exchange rates+-- that can be inferred by reversing known rates+--+-- 3. a map of each commodity's default valuation commodity, if any.+--+-- These allow price lookup and valuation to be performed as+-- described in hledger.m4.md -> Valuation:+--+-- "hledger looks for a market price (exchange rate) from commodity A+-- to commodity B in one or more of these ways, in this order of+-- preference:+--+-- 1. A *declared market price* or *inferred market price*:+--    A's latest market price in B on or before the valuation date+--    as declared by a P directive, or (with the `--infer-market-prices` flag)+--    inferred from transaction prices.+--   +-- 2. A *reverse market price*:+--    the inverse of a declared or inferred market price from B to A.+-- +-- 3. A *a forward chain of market prices*:+--    a synthetic price formed by combining the shortest chain of+--    "forward" (only 1 above) market prices, leading from A to B.+--+-- 4. A *any chain of market prices*:+--    a chain of any market prices, including both forward and+--    reverse prices (1 and 2 above), leading from A to B."+--+-- and: "For each commodity A, hledger picks a default valuation+-- commodity as follows, in this order of preference:+--+-- 1. The price commodity from the latest declared market price for A+--    on or before valuation date.+--+-- 2. The price commodity from the latest declared market price for A+--    on any date. (Allows conversion to proceed if there are inferred+--    prices before the valuation date.)+--+-- 3. If there are no P directives at all (any commodity or date), and+--    the `--infer-market-prices` flag is used, then the price commodity from+--    the latest transaction price for A on or before valuation date."+--+-- | Build the price graph using pre-built indexes for O(pairs × log n) lookup.+makePriceGraph :: PriceIndexes -> Day -> PriceGraph+makePriceGraph indexes d =+  dbg9 ("makePriceGraph "++show d) $+  PriceGraph{+     pgDate = d+    ,pgEdges=forwardprices+    ,pgEdgesRev=allprices+    ,pgDefaultValuationCommodities=defaultdests+    }+  where+    -- XXX logic duplicated in Hledger.Cli.Commands.Prices.prices, keep synced++    -- get the latest effective price for each commodity pair on or before date d+    forwardprices = dbg9 "effective forward prices" $+      lookupEffectivePricesFromIndex d (piForward indexes)++    -- infer any additional reverse prices not already declared or inferred+    reverseprices = dbg9 "additional reverse prices" $+      [p | p@MarketPrice{..} <- map marketPriceReverse forwardprices+         , not $ (mpfrom,mpto) `S.member` forwardpairs+      ]+      where+        forwardpairs = S.fromList [(mpfrom,mpto) | MarketPrice{..} <- forwardprices]+    allprices = forwardprices ++ reverseprices++    -- use indexed lookup for default valuation commodities+    defaultdests = dbg9 "default valuation commodities" $+      lookupDefaultValuations d indexes++marketPriceReverse :: MarketPrice -> MarketPrice+marketPriceReverse mp@MarketPrice{..} = +  mp{mpfrom=mpto, mpto=mpfrom, mprate=if mprate==0 then 0 else 1/mprate}  -- PARTIAL: /++nullmarketprice :: MarketPrice+nullmarketprice = MarketPrice {+   mpdate=nulldate+  ,mpfrom=""+  ,mpto=""+  ,mprate=0+  }++------------------------------------------------------------------------------++tests_Valuation = testGroup "Valuation" [+   tests_priceLookup+  ,testCase "marketPriceReverse" $ do+    marketPriceReverse nullmarketprice{mprate=2} @?= nullmarketprice{mprate=0.5}+    marketPriceReverse nullmarketprice @?= nullmarketprice  -- the reverse of a 0 price is a 0 price+++  ]
Hledger/Query.hs view
@@ -5,778 +5,1216 @@  -} -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}-{-# LANGUAGE CPP #-}--module Hledger.Query (-  -- * Query and QueryOpt-  Query(..),-  QueryOpt(..),-  -- * parsing-  parseQuery,-  simplifyQuery,-  filterQuery,-  -- * accessors-  queryIsNull,-  queryIsAcct,-  queryIsAmt,-  queryIsDepth,-  queryIsDate,-  queryIsDate2,-  queryIsDateOrDate2,-  queryIsStartDateOnly,-  queryIsSym,-  queryIsReal,-  queryIsStatus,-  queryIsEmpty,-  queryStartDate,-  queryEndDate,-  queryDateSpan,-  queryDateSpan',-  queryDepth,-  inAccount,-  inAccountQuery,-  -- * matching-  matchesTransaction,-  matchesPosting,-  matchesAccount,-  matchesMixedAmount,-  matchesAmount,-  matchesCommodity,-  matchesMarketPrice,-  words'',-  -- * tests-  tests_Query-)-where--import Data.Data-import Data.Either-import Data.List-import Data.Maybe-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import qualified Data.Text as T-import Data.Time.Calendar-import Safe (readDef, headDef)-import Text.Megaparsec-import Text.Megaparsec.Char--import Hledger.Utils hiding (words')-import Hledger.Data.Types-import Hledger.Data.AccountName-import Hledger.Data.Amount (nullamt, usd)-import Hledger.Data.Dates-import Hledger.Data.Posting-import Hledger.Data.Transaction----- | A query is a composition of search criteria, which can be used to--- match postings, transactions, accounts and more.-data Query = Any              -- ^ always match-           | None             -- ^ never match-           | Not Query        -- ^ negate this match-           | Or [Query]       -- ^ match if any of these match-           | And [Query]      -- ^ match if all of these match-           | Code Regexp      -- ^ match if code matches this regexp-           | Desc Regexp      -- ^ match if description matches this regexp-           | Acct Regexp      -- ^ match postings whose account matches this regexp-           | Date DateSpan    -- ^ match if primary date in this date span-           | Date2 DateSpan   -- ^ match if secondary date in this date span-           | StatusQ Status  -- ^ match txns/postings with this status-           | Real Bool        -- ^ match if "realness" (involves a real non-virtual account ?) has this value-           | Amt OrdPlus Quantity  -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value-           | Sym Regexp       -- ^ match if the entire commodity symbol is matched by this regexp-           | Empty Bool       -- ^ if true, show zero-amount postings/accounts which are usually not shown-                              --   more of a query option than a query criteria ?-           | Depth Int        -- ^ match if account depth is less than or equal to this value.-                              --   Depth is sometimes used like a query (for filtering report data)-                              --   and sometimes like a query option (for controlling display)-           | Tag Regexp (Maybe Regexp)  -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps-                                        -- matching the regexp if provided, exists-    deriving (Eq,Data,Typeable)---- custom Show implementation to show strings more accurately, eg for debugging regexps-instance Show Query where-  show Any           = "Any"-  show None          = "None"-  show (Not q)       = "Not ("   ++ show q  ++ ")"-  show (Or qs)       = "Or ("    ++ show qs ++ ")"-  show (And qs)      = "And ("   ++ show qs ++ ")"-  show (Code r)      = "Code "   ++ show r-  show (Desc r)      = "Desc "   ++ show r-  show (Acct r)      = "Acct "   ++ show r-  show (Date ds)     = "Date ("  ++ show ds ++ ")"-  show (Date2 ds)    = "Date2 (" ++ show ds ++ ")"-  show (StatusQ b)    = "StatusQ " ++ show b-  show (Real b)      = "Real "   ++ show b-  show (Amt ord qty) = "Amt "    ++ show ord ++ " " ++ show qty-  show (Sym r)       = "Sym "    ++ show r-  show (Empty b)     = "Empty "  ++ show b-  show (Depth n)     = "Depth "  ++ show n-  show (Tag s ms)    = "Tag "    ++ show s ++ " (" ++ show ms ++ ")"---- | A more expressive Ord, used for amt: queries. The Abs* variants--- compare with the absolute value of a number, ignoring sign.-data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq- deriving (Show,Eq,Data,Typeable)---- | A query option changes a query's/report's behaviour and output in some way.-data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account-              | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register-           -- | QueryOptCostBasis      -- ^ show amounts converted to cost where possible-           -- | QueryOptDate2  -- ^ show secondary dates instead of primary dates-    deriving (Show, Eq, Data, Typeable)---- parsing---- -- | A query restricting the account(s) to be shown in the sidebar, if any.--- -- Just looks at the first query option.--- showAccountMatcher :: [QueryOpt] -> Maybe Query--- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ Acct True $ accountNameToAccountRegex a--- showAccountMatcher _ = Nothing----- | Convert a query expression containing zero or more space-separated--- terms to a query and zero or more query options. A query term is either:------ 1. a search pattern, which matches on one or more fields, eg:------      acct:REGEXP     - match the account name with a regular expression---      desc:REGEXP     - match the transaction description---      date:PERIODEXP  - match the date with a period expression------    The prefix indicates the field to match, or if there is no prefix---    account name is assumed.------ 2. a query option, which modifies the reporting behaviour in some---    way. There is currently one of these, which may appear only once:------      inacct:FULLACCTNAME------ The usual shell quoting rules are assumed. When a pattern contains--- whitespace, it (or the whole term including prefix) should be enclosed--- in single or double quotes.------ Period expressions may contain relative dates, so a reference date is--- required to fully parse these.------ Multiple terms are combined as follows:--- 1. multiple account patterns are OR'd together--- 2. multiple description patterns are OR'd together--- 3. multiple status patterns are OR'd together--- 4. then all terms are AND'd together-parseQuery :: Day -> T.Text -> (Query,[QueryOpt])-parseQuery d s = (q, opts)-  where-    terms = words'' prefixes s-    (pats, opts) = partitionEithers $ map (parseQueryTerm d) terms-    (descpats, pats') = partition queryIsDesc pats-    (acctpats, pats'') = partition queryIsAcct pats'-    (statuspats, otherpats) = partition queryIsStatus pats''-    q = simplifyQuery $ And $ [Or acctpats, Or descpats, Or statuspats] ++ otherpats---- XXX--- | Quote-and-prefix-aware version of words - don't split on spaces which--- are inside quotes, including quotes which may have one of the specified--- prefixes in front, and maybe an additional not: prefix in front of that.-words'' :: [T.Text] -> T.Text -> [T.Text]-words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX-    where-      maybeprefixedquotedphrases :: SimpleTextParser [T.Text]-      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` skipSome spacenonewline-      prefixedQuotedPattern :: SimpleTextParser T.Text-      prefixedQuotedPattern = do-        not' <- fromMaybe "" `fmap` (optional $ string "not:")-        let allowednexts | T.null not' = prefixes-                         | otherwise   = prefixes ++ [""]-        next <- choice' $ map string allowednexts-        let prefix :: T.Text-            prefix = not' <> next-        p <- singleQuotedPattern <|> doubleQuotedPattern-        return $ prefix <> stripquotes p-      singleQuotedPattern :: SimpleTextParser T.Text-      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack-      doubleQuotedPattern :: SimpleTextParser T.Text-      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack-      pattern :: SimpleTextParser T.Text-      pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))---- XXX--- keep synced with patterns below, excluding "not"-prefixes :: [T.Text]-prefixes = map (<>":") [-     "inacctonly"-    ,"inacct"-    ,"amt"-    ,"code"-    ,"desc"-    ,"payee"-    ,"note"-    ,"acct"-    ,"date"-    ,"date2"-    ,"status"-    ,"cur"-    ,"real"-    ,"empty"-    ,"depth"-    ,"tag"-    ]--defaultprefix :: T.Text-defaultprefix = "acct"---- -- | Parse the query string as a boolean tree of match patterns.--- parseQueryTerm :: String -> Query--- parseQueryTerm s = either (const (Any)) id $ runParser query () "" $ lexmatcher s---- lexmatcher :: String -> [String]--- lexmatcher s = words' s---- query :: GenParser String () Query--- query = undefined---- | Parse a single query term as either a query or a query option,--- or raise an error if it has invalid syntax.-parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt-parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s-parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s-parseQueryTerm d (T.stripPrefix "not:" -> Just s) =-  case parseQueryTerm d s of-    Left m -> Left $ Not m-    Right _ -> Left Any -- not:somequeryoption will be ignored-parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s-parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s-parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left $ Tag "payee" $ Just $ T.unpack s-parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left $ Tag "note" $ Just $ T.unpack s-parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s-parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =-        case parsePeriodExpr d s of Left e         -> error' $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,span) -> Left $ Date2 span-parseQueryTerm d (T.stripPrefix "date:" -> Just s) =-        case parsePeriodExpr d s of Left e         -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,span) -> Left $ Date span-parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =-        case parseStatus s of Left e   -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e-                              Right st -> Left $ StatusQ st-parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s-parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s-parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s-parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)-  | n >= 0    = Left $ Depth n-  | otherwise = error' "depth: should have a positive number"-  where n = readDef 0 (T.unpack s)--parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s) -- support cur: as an alias-parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s-parseQueryTerm _ "" = Left $ Any-parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s---- | Parse what comes after amt: .-parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity)-parseAmountQueryTerm s' =-  case s' of-    -- feel free to do this a smarter way-    ""              -> err-    (T.stripPrefix "<+" -> Just s)  -> (Lt, readDef err (T.unpack s))-    (T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))-    (T.stripPrefix ">+" -> Just s)  -> (Gt, readDef err (T.unpack s))-    (T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))-    (T.stripPrefix "=+" -> Just s)  -> (Eq, readDef err (T.unpack s))-    (T.stripPrefix "+" -> Just s)   -> (Eq, readDef err (T.unpack s))-    (T.stripPrefix "<-" -> Just s)  -> (Lt, negate $ readDef err (T.unpack s))-    (T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))-    (T.stripPrefix ">-" -> Just s)  -> (Gt, negate $ readDef err (T.unpack s))-    (T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))-    (T.stripPrefix "=-" -> Just s)  -> (Eq, negate $ readDef err (T.unpack s))-    (T.stripPrefix "-" -> Just s)   -> (Eq, negate $ readDef err (T.unpack s))-    (T.stripPrefix "<=" -> Just s)  -> let n = readDef err (T.unpack s) in-                                         case n of-                                           0 -> (LtEq, 0)-                                           _ -> (AbsLtEq, n)-    (T.stripPrefix "<" -> Just s)   -> let n = readDef err (T.unpack s) in-                                         case n of 0 -> (Lt, 0)-                                                   _ -> (AbsLt, n)-    (T.stripPrefix ">=" -> Just s)  -> let n = readDef err (T.unpack s) in-                                         case n of 0 -> (GtEq, 0)-                                                   _ -> (AbsGtEq, n)-    (T.stripPrefix ">" -> Just s)   -> let n = readDef err (T.unpack s) in-                                         case n of 0 -> (Gt, 0)-                                                   _ -> (AbsGt, n)-    (T.stripPrefix "=" -> Just s)           -> (AbsEq, readDef err (T.unpack s))-    s               -> (AbsEq, readDef err (T.unpack s))-  where-    err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s'--parseTag :: T.Text -> (Regexp, Maybe Regexp)-parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)-           | otherwise    = (T.unpack s, Nothing)-           where (n,v) = T.break (=='=') s---- | Parse the value part of a "status:" query, or return an error.-parseStatus :: T.Text -> Either String Status-parseStatus s | s `elem` ["*","1"] = Right Cleared-              | s `elem` ["!"]     = Right Pending-              | s `elem` ["","0"]  = Right Unmarked-              | otherwise          = Left $ "could not parse "++show s++" as a status (should be *, ! or empty)"---- | Parse the boolean value part of a "status:" query. "1" means true,--- anything else will be parsed as false without error.-parseBool :: T.Text -> Bool-parseBool s = s `elem` truestrings--truestrings :: [T.Text]-truestrings = ["1"]--simplifyQuery :: Query -> Query-simplifyQuery q =-  let q' = simplify q-  in if q' == q then q else simplifyQuery q'-  where-    simplify (And []) = Any-    simplify (And [q]) = simplify q-    simplify (And qs) | same qs = simplify $ head qs-                      | any (==None) qs = None-                      | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs-                      | otherwise = And $ concat $ [map simplify dateqs, map simplify otherqs]-                      where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs-    simplify (Or []) = Any-    simplify (Or [q]) = simplifyQuery q-    simplify (Or qs) | same qs = simplify $ head qs-                     | any (==Any) qs = Any-                     -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs  ?-                     | otherwise = Or $ map simplify $ filter (/=None) qs-    simplify (Date (DateSpan Nothing Nothing)) = Any-    simplify (Date2 (DateSpan Nothing Nothing)) = Any-    simplify q = q--same [] = True-same (a:as) = all (a==) as---- | Remove query terms (or whole sub-expressions) not matching the given--- predicate from this query.  XXX Semantics not completely clear.-filterQuery :: (Query -> Bool) -> Query -> Query-filterQuery p = simplifyQuery . filterQuery' p--filterQuery' :: (Query -> Bool) -> Query -> Query-filterQuery' p (And qs) = And $ map (filterQuery p) qs-filterQuery' p (Or qs) = Or $ map (filterQuery p) qs--- filterQuery' p (Not q) = Not $ filterQuery p q-filterQuery' p q = if p q then q else Any---- * accessors---- | Does this query match everything ?-queryIsNull :: Query -> Bool-queryIsNull Any = True-queryIsNull (And []) = True-queryIsNull (Not (Or [])) = True-queryIsNull _ = False--queryIsDepth :: Query -> Bool-queryIsDepth (Depth _) = True-queryIsDepth _ = False--queryIsDate :: Query -> Bool-queryIsDate (Date _) = True-queryIsDate _ = False--queryIsDate2 :: Query -> Bool-queryIsDate2 (Date2 _) = True-queryIsDate2 _ = False--queryIsDateOrDate2 :: Query -> Bool-queryIsDateOrDate2 (Date _) = True-queryIsDateOrDate2 (Date2 _) = True-queryIsDateOrDate2 _ = False--queryIsDesc :: Query -> Bool-queryIsDesc (Desc _) = True-queryIsDesc _ = False--queryIsAcct :: Query -> Bool-queryIsAcct (Acct _) = True-queryIsAcct _ = False--queryIsAmt :: Query -> Bool-queryIsAmt (Amt _ _) = True-queryIsAmt _         = False--queryIsSym :: Query -> Bool-queryIsSym (Sym _) = True-queryIsSym _ = False--queryIsReal :: Query -> Bool-queryIsReal (Real _) = True-queryIsReal _ = False--queryIsStatus :: Query -> Bool-queryIsStatus (StatusQ _) = True-queryIsStatus _ = False--queryIsEmpty :: Query -> Bool-queryIsEmpty (Empty _) = True-queryIsEmpty _ = False---- | Does this query specify a start date and nothing else (that would--- filter postings prior to the date) ?--- When the flag is true, look for a starting secondary date instead.-queryIsStartDateOnly :: Bool -> Query -> Bool-queryIsStartDateOnly _ Any = False-queryIsStartDateOnly _ None = False-queryIsStartDateOnly secondary (Or ms) = and $ map (queryIsStartDateOnly secondary) ms-queryIsStartDateOnly secondary (And ms) = and $ map (queryIsStartDateOnly secondary) ms-queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True-queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True-queryIsStartDateOnly _ _ = False---- | What start date (or secondary date) does this query specify, if any ?--- For OR expressions, use the earliest of the dates. NOT is ignored.-queryStartDate :: Bool -> Query -> Maybe Day-queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms-queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms-queryStartDate False (Date (DateSpan (Just d) _)) = Just d-queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d-queryStartDate _ _ = Nothing---- | What end date (or secondary date) does this query specify, if any ?--- For OR expressions, use the latest of the dates. NOT is ignored.-queryEndDate :: Bool -> Query -> Maybe Day-queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms-queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms-queryEndDate False (Date (DateSpan _ (Just d))) = Just d-queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d-queryEndDate _ _ = Nothing--queryTermDateSpan (Date span) = Just span-queryTermDateSpan _ = Nothing---- | What date span (or with a true argument, what secondary date span) does this query specify ?--- OR clauses specifying multiple spans return their union (the span enclosing all of them).--- AND clauses specifying multiple spans return their intersection.--- NOT clauses are ignored.-queryDateSpan :: Bool -> Query -> DateSpan-queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs-queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs-queryDateSpan False (Date span)  = span-queryDateSpan True (Date2 span)  = span-queryDateSpan _ _                = nulldatespan---- | What date span does this query specify, treating primary and secondary dates as equivalent ?--- OR clauses specifying multiple spans return their union (the span enclosing all of them).--- AND clauses specifying multiple spans return their intersection.--- NOT clauses are ignored.-queryDateSpan' :: Query -> DateSpan-queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs-queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs-queryDateSpan' (Date span)  = span-queryDateSpan' (Date2 span) = span-queryDateSpan' _            = nulldatespan---- | What is the earliest of these dates, where Nothing is latest ?-earliestMaybeDate :: [Maybe Day] -> Maybe Day-earliestMaybeDate mds = head $ sortBy compareMaybeDates mds ++ [Nothing]---- | What is the latest of these dates, where Nothing is earliest ?-latestMaybeDate :: [Maybe Day] -> Maybe Day-latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)---- | What is the earliest of these dates, ignoring Nothings ?-earliestMaybeDate' :: [Maybe Day] -> Maybe Day-earliestMaybeDate' = headDef Nothing . sortBy compareMaybeDates . filter isJust---- | What is the latest of these dates, ignoring Nothings ?-latestMaybeDate' :: [Maybe Day] -> Maybe Day-latestMaybeDate' = headDef Nothing . sortBy (flip compareMaybeDates) . filter isJust---- | Compare two maybe dates, Nothing is earliest.-compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering-compareMaybeDates Nothing Nothing = EQ-compareMaybeDates Nothing (Just _) = LT-compareMaybeDates (Just _) Nothing = GT-compareMaybeDates (Just a) (Just b) = compare a b---- | The depth limit this query specifies, or a large number if none.-queryDepth :: Query -> Int-queryDepth q = case queryDepth' q of [] -> 99999-                                     ds -> minimum ds-  where-    queryDepth' (Depth d) = [d]-    queryDepth' (Or qs) = concatMap queryDepth' qs-    queryDepth' (And qs) = concatMap queryDepth' qs-    queryDepth' _ = []---- | The account we are currently focussed on, if any, and whether subaccounts are included.--- Just looks at the first query option.-inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)-inAccount [] = Nothing-inAccount (QueryOptInAcctOnly a:_) = Just (a,False)-inAccount (QueryOptInAcct a:_) = Just (a,True)---- | A query for the account(s) we are currently focussed on, if any.--- Just looks at the first query option.-inAccountQuery :: [QueryOpt] -> Maybe Query-inAccountQuery [] = Nothing-inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a-inAccountQuery (QueryOptInAcct a     : _) = Just $ Acct $ accountNameToAccountRegex a---- -- | Convert a query to its inverse.--- negateQuery :: Query -> Query--- negateQuery =  Not---- matching---- | Does the match expression match this account ?--- A matching in: clause is also considered a match.-matchesAccount :: Query -> AccountName -> Bool-matchesAccount (None) _ = False-matchesAccount (Not m) a = not $ matchesAccount m a-matchesAccount (Or ms) a = any (`matchesAccount` a) ms-matchesAccount (And ms) a = all (`matchesAccount` a) ms-matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a) -- XXX pack-matchesAccount (Depth d) a = accountNameLevel a <= d-matchesAccount (Tag _ _) _ = False-matchesAccount _ _ = True--matchesMixedAmount :: Query -> MixedAmount -> Bool-matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt-matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as--matchesCommodity :: Query -> CommoditySymbol -> Bool-matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s)-matchesCommodity _ _ = True---- | Does the match expression match this (simple) amount ?-matchesAmount :: Query -> Amount -> Bool-matchesAmount (Not q) a = not $ q `matchesAmount` a-matchesAmount (Any) _ = True-matchesAmount (None) _ = False-matchesAmount (Or qs) a = any (`matchesAmount` a) qs-matchesAmount (And qs) a = all (`matchesAmount` a) qs----matchesAmount (Amt ord n) a = compareAmount ord n a-matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a)----matchesAmount _ _ = True---- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ?--- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true.---- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ?-compareAmount :: OrdPlus -> Quantity -> Amount -> Bool-compareAmount ord q Amount{aquantity=aq} = case ord of Lt      -> aq <  q-                                                       LtEq    -> aq <= q-                                                       Gt      -> aq >  q-                                                       GtEq    -> aq >= q-                                                       Eq      -> aq == q-                                                       AbsLt   -> abs aq <  abs q-                                                       AbsLtEq -> abs aq <= abs q-                                                       AbsGt   -> abs aq >  abs q-                                                       AbsGtEq -> abs aq >= abs q-                                                       AbsEq   -> abs aq == abs q---- | Does the match expression match this posting ?------ Note that for account match we try both original and effective account-matchesPosting :: Query -> Posting -> Bool-matchesPosting (Not q) p = not $ q `matchesPosting` p-matchesPosting (Any) _ = True-matchesPosting (None) _ = False-matchesPosting (Or qs) p = any (`matchesPosting` p) qs-matchesPosting (And qs) p = all (`matchesPosting` p) qs-matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p-matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p-matchesPosting (Acct r) p = matchesPosting p || matchesPosting (originalPosting p)-    where matchesPosting p = regexMatchesCI r $ T.unpack $ paccount p -- XXX pack-matchesPosting (Date span) p = span `spanContainsDate` postingDate p-matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p-matchesPosting (StatusQ s) p = postingStatus p == s-matchesPosting (Real v) p = v == isReal p-matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a-matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt--- matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt--- matchesPosting (Empty v) Posting{pamount=a} = v == isZeroMixedAmount a--- matchesPosting (Empty False) Posting{pamount=a} = True--- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a-matchesPosting (Empty _) _ = True-matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as-matchesPosting (Tag n v) p = case (n, v) of-  ("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p-  ("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p-  (n, v) -> matchesTags n v $ postingAllTags p---- | Does the match expression match this transaction ?-matchesTransaction :: Query -> Transaction -> Bool-matchesTransaction (Not q) t = not $ q `matchesTransaction` t-matchesTransaction (Any) _ = True-matchesTransaction (None) _ = False-matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs-matchesTransaction (And qs) t = all (`matchesTransaction` t) qs-matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t-matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t-matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t-matchesTransaction (Date span) t = spanContainsDate span $ tdate t-matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t-matchesTransaction (StatusQ s) t = tstatus t == s-matchesTransaction (Real v) t = v == hasRealPostings t-matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t-matchesTransaction (Empty _) _ = True-matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t-matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t-matchesTransaction (Tag n v) t = case (n, v) of-  ("payee", Just v) -> regexMatchesCI v . T.unpack . transactionPayee $ t-  ("note", Just v) -> regexMatchesCI v . T.unpack . transactionNote $ t-  (n, v) -> matchesTags n v $ transactionAllTags t---- | Filter a list of tags by matching against their names and--- optionally also their values.-matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool-matchesTags namepat valuepat = not . null . filter (match namepat valuepat)-  where-    match npat Nothing     (n,_) = regexMatchesCI npat (T.unpack n) -- XXX-    match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v)---- | Does the query match this market price ?-matchesMarketPrice :: Query -> MarketPrice -> Bool-matchesMarketPrice (None) _      = False-matchesMarketPrice (Not q) p     = not $ matchesMarketPrice q p-matchesMarketPrice (Or qs) p     = any (`matchesMarketPrice` p) qs-matchesMarketPrice (And qs) p    = all (`matchesMarketPrice` p) qs-matchesMarketPrice q@(Amt _ _) p = matchesAmount q (mpamount p)-matchesMarketPrice q@(Sym _) p   = matchesCommodity q (mpcommodity p)-matchesMarketPrice (Date span) p = spanContainsDate span (mpdate p)-matchesMarketPrice _ _           = True----- tests--tests_Query = tests "Query" [-   tests "simplifyQuery" [-    -     (simplifyQuery $ Or [Acct "a"])      `is` (Acct "a")-    ,(simplifyQuery $ Or [Any,None])      `is` (Any)-    ,(simplifyQuery $ And [Any,None])     `is` (None)-    ,(simplifyQuery $ And [Any,Any])      `is` (Any)-    ,(simplifyQuery $ And [Acct "b",Any]) `is` (Acct "b")-    ,(simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) `is` (Any)-    ,(simplifyQuery $ And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)])-      `is` (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))-    ,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b")-   ]-  -  ,tests "parseQuery" [-     (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])-    ,parseQuery nulldate "inacct:a desc:\"b b\""                     `is` (Desc "b b", [QueryOptInAcct "a"])-    ,parseQuery nulldate "inacct:a inacct:b"                         `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])-    ,parseQuery nulldate "desc:'x x'"                                `is` (Desc "x x", [])-    ,parseQuery nulldate "'a a' 'b"                                  `is` (Or [Acct "a a",Acct "'b"], [])-    ,parseQuery nulldate "\""                                        `is` (Acct "\"", [])-   ]-  -  ,tests "words''" [-      (words'' [] "a b")                   `is` ["a","b"]        -    , (words'' [] "'a b'")                 `is` ["a b"]          -    , (words'' [] "not:a b")               `is` ["not:a","b"]    -    , (words'' [] "not:'a b'")             `is` ["not:a b"]      -    , (words'' [] "'not:a b'")             `is` ["not:a b"]      -    , (words'' ["desc:"] "not:desc:'a b'") `is` ["not:desc:a b"] -    , (words'' prefixes "\"acct:expenses:autres d\233penses\"") `is` ["acct:expenses:autres d\233penses"]-    , (words'' prefixes "\"")              `is` ["\""]-    ]-  -  ,tests "filterQuery" [-     filterQuery queryIsDepth Any       `is` Any-    ,filterQuery queryIsDepth (Depth 1) `is` Depth 1-    ,filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) `is` StatusQ Cleared-    ,filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) `is` Any   -- XXX unclear-   ]--  ,tests "parseQueryTerm" [-     parseQueryTerm nulldate "a"                                `is` (Left $ Acct "a")-    ,parseQueryTerm nulldate "acct:expenses:autres d\233penses" `is` (Left $ Acct "expenses:autres d\233penses")-    ,parseQueryTerm nulldate "not:desc:a b"                     `is` (Left $ Not $ Desc "a b")-    ,parseQueryTerm nulldate "status:1"                         `is` (Left $ StatusQ Cleared)-    ,parseQueryTerm nulldate "status:*"                         `is` (Left $ StatusQ Cleared)-    ,parseQueryTerm nulldate "status:!"                         `is` (Left $ StatusQ Pending)-    ,parseQueryTerm nulldate "status:0"                         `is` (Left $ StatusQ Unmarked)-    ,parseQueryTerm nulldate "status:"                          `is` (Left $ StatusQ Unmarked)-    ,parseQueryTerm nulldate "payee:x"                          `is` (Left $ Tag "payee" (Just "x"))-    ,parseQueryTerm nulldate "note:x"                           `is` (Left $ Tag "note" (Just "x"))-    ,parseQueryTerm nulldate "real:1"                           `is` (Left $ Real True)-    ,parseQueryTerm nulldate "date:2008"                        `is` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))-    ,parseQueryTerm nulldate "date:from 2012/5/17"              `is` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)-    ,parseQueryTerm nulldate "date:20180101-201804"             `is` (Left $ Date $ DateSpan (Just $ parsedate "2018/01/01") (Just $ parsedate "2018/04/01"))-    ,parseQueryTerm nulldate "inacct:a"                         `is` (Right $ QueryOptInAcct "a")-    ,parseQueryTerm nulldate "tag:a"                            `is` (Left $ Tag "a" Nothing)-    ,parseQueryTerm nulldate "tag:a=some value"                 `is` (Left $ Tag "a" (Just "some value"))-    ,parseQueryTerm nulldate "amt:<0"                           `is` (Left $ Amt Lt 0)-    ,parseQueryTerm nulldate "amt:>10000.10"                    `is` (Left $ Amt AbsGt 10000.1)-   ]-  -  ,tests "parseAmountQueryTerm" [-     parseAmountQueryTerm "<0"        `is` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false-    ,parseAmountQueryTerm ">0"        `is` (Gt,0) -- special case for convenience and consistency with above-    ,parseAmountQueryTerm ">10000.10" `is` (AbsGt,10000.1)-    ,parseAmountQueryTerm "=0.23"     `is` (AbsEq,0.23)-    ,parseAmountQueryTerm "0.23"      `is` (AbsEq,0.23)-    ,parseAmountQueryTerm "<=+0.23"   `is` (LtEq,0.23)-    ,parseAmountQueryTerm "-0.23"     `is` (Eq,(-0.23))-    ,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23)  -- XXX-    ]-  -  ,tests "matchesAccount" [-     expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d"-    ,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"-    ,expect $ Depth 2 `matchesAccount` "a"-    ,expect $ Depth 2 `matchesAccount` "a:b"-    ,expect $ not $ Depth 2 `matchesAccount` "a:b:c"-    ,expect $ Date nulldatespan `matchesAccount` "a"-    ,expect $ Date2 nulldatespan `matchesAccount` "a"-    ,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a"-  ]-  -  ,tests "matchesPosting" [-     test "positive match on cleared posting status"  $-      expect $ (StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}-    ,test "negative match on cleared posting status"  $-      expect $ not $ (Not $ StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}-    ,test "positive match on unmarked posting status" $-      expect $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}-    ,test "negative match on unmarked posting status" $-      expect $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}-    ,test "positive match on true posting status acquired from transaction" $-      expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}}-    ,test "real:1 on real posting" $ expect $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}-    ,test "real:1 on virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}-    ,test "real:1 on balanced virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}-    ,test "a" $ expect $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}-    ,test "b" $ expect $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting-    ,test "c" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}-    ,test "d" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}-    ,test "e" $ expect $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    ,test "f" $ expect $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    ,test "g" $ expect $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    ,test "h" $ expect $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}-     -- a tag match on a posting also sees inherited tags-    ,test "i" $ expect $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}-    ,test "j" $ expect $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol-    ,test "k" $ expect $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr-    ,test "l" $ expect $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}-    ,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}-  ]-  -  ,tests "matchesTransaction" [-     expect $ Any `matchesTransaction` nulltransaction-    ,expect $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}-    ,expect $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}-     -- see posting for more tag tests-    ,expect $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}-    ,expect $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}-    ,expect $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}-     -- a tag match on a transaction also matches posting tags-    ,expect $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}-  ]-+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE ViewPatterns       #-}+{-# LANGUAGE TupleSections      #-}++module Hledger.Query (+  -- * Query and QueryOpt+  Query(..),+  QueryOpt(..),+  OrdPlus(..),+  payeeTag,+  noteTag,+  generatedTransactionTag,+  -- * parsing+  parseQuery,+  parseQueryList,+  parseQueryTerm,+  parseAccountType,+  parseDepthSpec,+  -- * modifying+  simplifyQuery,+  filterQuery,+  filterQueryOrNotQuery,+  matchesQuery,+  -- * predicates+  queryIsNull,+  queryIsDate,+  queryIsDate2,+  queryIsDateOrDate2,+  queryIsStatus,+  queryIsCode,+  queryIsDesc,+  queryIsTag,+  queryIsAcct,+  queryIsType,+  queryIsDepth,+  queryIsReal,+  queryIsAmt,+  queryIsSym,+  queryIsAmtOrSym,+  queryIsStartDateOnly,+  queryIsTransactionRelated,+  -- * accessors+  queryStartDate,+  queryEndDate,+  queryDateSpan,+  queryDateSpan',+  queryDepth,+  inAccount,+  inAccountQuery,+  -- * matching things with queries+  matchesTransaction,+  matchesTransactionExtra,+  matchesDescription,+  matchesPayeeWIP,+  matchesPosting,+  matchesPostingExtra,+  matchesAccount,+  matchesAccountExtra,+  matchesMixedAmount,+  matchesAmount,+  matchesCommodity,+  matchesTag,+  -- patternsMatchTags,+  matchesPriceDirective,+  words'',+  queryprefixes,+  -- * tests+  tests_Query+)+where++import Control.Applicative+import Data.Default (Default(..))+import Data.Either (partitionEithers)+import Data.List (partition, intercalate)+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Calendar (Day, fromGregorian )+import Safe (headErr, readMay, maximumByMay, maximumMay, minimumMay)+import Text.Megaparsec (between, noneOf, sepBy, try, (<?>), notFollowedBy)+import Text.Megaparsec.Char (char, string, string')+++import Hledger.Utils hiding (words')+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Amount (amountsRaw, mixedAmount, nullamt, usd)+import Hledger.Data.Dates+import Hledger.Data.Posting+import Hledger.Data.Transaction+import Data.Bifunctor+++-- | A query is a composition of search criteria, which can be used to+-- match postings, transactions, accounts and more.+data Query = +  -- no-op queries+    Any                       -- ^ always match+  | None                      -- ^ never match+  -- data queries (in "standard" order, roughly as they appear in a transaction)+  | Date DateSpan             -- ^ match primary dates in this date span+  | Date2 DateSpan            -- ^ match secondary dates in this date span+  | StatusQ Status            -- ^ match this txn/posting status+  | Code Regexp               -- ^ match txn codes infix-matched by this regexp+  | Desc Regexp               -- ^ match txn descriptions infix-matched by this regexp+  | Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is infix-matched by the respective regexps+  | Acct Regexp               -- ^ match account names infix-matched by this regexp+  | Type [AccountType]        -- ^ match accounts whose type is one of these (or with no types, any account)+  | Depth Int                 -- ^ match if account depth is less than or equal to this value (or, sometimes used as a display option)+  | DepthAcct Regexp Int      -- ^ match if the account matches and account depth is less than or equal to this value (usually used as a display option)+  | Real Bool                 -- ^ match postings with this "realness" value+  | Amt OrdPlus Quantity      -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value+  | Sym Regexp                -- ^ match if the commodity symbol is fully-matched by this regexp+  -- compound queries (expr:)+  | Not Query                 -- ^ negate this match+  | And [Query]               -- ^ match if all of these match+  | Or  [Query]               -- ^ match if any of these match+  -- compound queries for transactions (any:, all:)+  -- If used in a non transaction-matching context, these are equivalent to And.+  | AnyPosting  [Query]       -- ^ match if any one posting is matched by all of these+  | AllPostings [Query]       -- ^ match if all of one or more postings are matched by all of these+  deriving (Eq,Show)++instance Default Query where def = Any++-- | Construct a query for the payee: tag+payeeTag :: Maybe Text -> Either RegexError Query+payeeTag = fmap (Tag (toRegexCI' "payee")) . maybe (pure Nothing) (fmap Just . toRegexCI)++-- | Construct a query for the note: tag+noteTag :: Maybe Text -> Either RegexError Query+noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI)++-- | Construct a query for the generated-transaction: tag+generatedTransactionTag :: Query+generatedTransactionTag = Tag (toRegexCI' "generated-transaction") Nothing++-- | A more expressive Ord, used for amt: queries. The Abs* variants+-- compare with the absolute value of a number, ignoring sign.+data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq+ deriving (Show,Eq)++-- | A query option changes a query's/report's behaviour and output in some way.+data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account+              | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register+              | QueryOptInterval Interval       -- ^ report interval extracted from a date: query+           -- | QueryOptCostBasis      -- ^ show amounts converted to cost where possible+           -- | QueryOptDate2  -- ^ show secondary dates instead of primary dates+    deriving (Show, Eq)++-- parsing++-- -- | A query restricting the account(s) to be shown in the sidebar, if any.+-- -- Just looks at the first query option.+-- showAccountMatcher :: [QueryOpt] -> Maybe Query+-- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ Acct True $ accountNameToAccountRegex a+-- showAccountMatcher _ = Nothing+++-- | A version of parseQueryList which acts on a single Text of+-- space-separated terms.+--+-- The usual shell quoting rules are assumed. When a pattern contains+-- whitespace, it (or the whole term including prefix) should be enclosed+-- in single or double quotes.+--+-- A query term is either:+--+-- 1. a search pattern, which matches on one or more fields, eg:+--+--      acct:REGEXP     - match the account name with a regular expression+--      desc:REGEXP     - match the transaction description+--      date:PERIODEXP  - match the date with a period expression+--+--    The prefix indicates the field to match, or if there is no prefix+--    account name is assumed.+--+-- 2. a query option, which modifies the reporting behaviour in some+--    way. There is currently one of these, which may appear only once:+--+--      inacct:FULLACCTNAME+--+-- Period expressions may contain relative dates, so a reference date is+-- required to fully parse these.+--+-- >>> parseQuery nulldate "expenses:dining out"+-- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])+--+-- >>> parseQuery nulldate "\"expenses:dining out\""+-- Right (Acct (RegexpCI "expenses:dining out"),[])+parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])+parseQuery d t = parseQueryList d $ words'' queryprefixes t++-- | Convert a list of space-separated queries to a single query+--+-- Multiple terms are combined as follows:+-- 1. multiple account patterns are OR'd together+-- 2. multiple description patterns are OR'd together+-- 3. multiple status patterns are OR'd together+-- 4. then all terms are AND'd together+parseQueryList :: Day -> [T.Text] -> Either String (Query, [QueryOpt])+parseQueryList d termstrs = do+  eterms <- mapM (parseQueryTerm d) termstrs+  let (pats, optss) = unzip eterms+      q = combineQueriesByType pats+  Right (q, concat optss)++combineQueriesByType :: [Query] -> Query+combineQueriesByType pats = q+  where+    (descpats, pats') = partition queryIsDesc pats+    (acctpats, pats'') = partition queryIsAcct pats'+    (statuspats, otherpats) = partition queryIsStatus pats''+    q = simplifyQuery $ And $ [Or acctpats, Or descpats, Or statuspats] ++ otherpats+  +-- XXX+-- | Quote-and-prefix-aware version of words - don't split on spaces which+-- are inside quotes, including quotes which may have one of the specified+-- prefixes in front, and maybe an additional not: prefix in front of that.+words'' :: [T.Text] -> T.Text -> [T.Text]+words'' prefixes = fromparse . parsewith maybePrefixedQuotedPhrases -- XXX+   where+      maybePrefixedQuotedPhrases :: SimpleTextParser [T.Text]+      maybePrefixedQuotedPhrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, patterns] `sepBy`+          (notFollowedBy (skipNonNewlineSpaces >> char ')') >> skipNonNewlineSpaces1)+      prefixedQuotedPattern :: SimpleTextParser T.Text+      prefixedQuotedPattern = do+        not' <- fromMaybe "" `fmap` (optional $ string "not:")+        let allowednexts | T.null not' = prefixes+                         | otherwise   = prefixes ++ [""]+        next <- choice' $ map string allowednexts+        let prefix :: T.Text+            prefix = not' <> next+        p <- singleQuotedPattern <|> doubleQuotedPattern+        return $ prefix <> stripquotes p+      singleQuotedPattern :: SimpleTextParser T.Text+      singleQuotedPattern = stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char]))+      doubleQuotedPattern :: SimpleTextParser T.Text+      doubleQuotedPattern = stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char]))+      patterns :: SimpleTextParser T.Text+      patterns = T.pack <$> many (noneOf (" \n\r" :: [Char]))++-- XXX+-- keep synced with patterns below, excluding "not"+queryprefixes :: [T.Text]+queryprefixes = map (<>":") [+     "inacctonly"+    ,"inacct"+    ,"amt"+    ,"code"+    ,"desc"+    ,"payee"+    ,"note"+    ,"acct"+    ,"date"+    ,"date2"+    ,"status"+    ,"cur"+    ,"real"+    ,"empty"+    ,"depth"+    ,"tag"+    ,"type"+    ,"expr"+    ,"any"+    ,"all"+    ]++defaultprefix :: T.Text+defaultprefix = "acct"++-- -- | Parse the query string as a boolean tree of match patterns.+-- parseQueryTerm :: String -> Query+-- parseQueryTerm s = either (const (Any)) id $ runParser query () "" $ lexmatcher s++-- lexmatcher :: String -> [String]+-- lexmatcher s = words' s++-- query :: GenParser String () Query+-- query = undefined++-- | Parse a single query term as either a query or a query option,+-- or return an error message if parsing fails.+parseQueryTerm :: Day -> T.Text -> Either String (Query, [QueryOpt])+parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right (Any, [QueryOptInAcctOnly s])+parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right (Any, [QueryOptInAcct s])+parseQueryTerm d (T.stripPrefix "not:" -> Just s) =+  case parseQueryTerm d s of+    Right (q, qopts) -> Right (Not q, qopts)+    Left err         -> Left err+parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = (,[]) . Code <$> toRegexCI s+parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = (,[]) . Desc <$> toRegexCI s+parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = (,[]) <$> payeeTag (Just s)+parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = (,[]) <$> noteTag (Just s)+parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = (,[]) . Acct <$> toRegexCI s+parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =+        case parsePeriodExpr d s of Left e                   -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e+                                    Right (_         , spn)  -> Right (Date2 spn, [])+parseQueryTerm d (T.stripPrefix "date:" -> Just s) =+        case parsePeriodExpr d s of Left e                   -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e+                                    Right (NoInterval, spn)  -> Right (Date spn, [])+                                    Right (interval  , spn)  -> Right (Date spn, [QueryOptInterval interval])+parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =+        case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e+                              Right st -> Right (StatusQ st, [])+parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Right (Real $ parseBool s || T.null s, [])+parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = case parseAmountQueryTerm s of+  Right (ord, q) -> Right (Amt ord q, [])+  Left err       -> Left err+parseQueryTerm _ (T.stripPrefix "depth:" -> Just s) = (,[]) <$> parseDepthSpecQuery s+parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = (,[]) . Sym <$> toRegexCI ("^" <> s <> "$") -- support cur: as an alias+parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = (,[]) <$> parseTag s+parseQueryTerm _ (T.stripPrefix "type:" -> Just s) = (,[]) <$> parseTypeCodes s+parseQueryTerm d (T.stripPrefix "expr:" -> Just s) = parseBooleanQuery d s+parseQueryTerm d (T.stripPrefix "any:" -> Just s) = first (AnyPosting  . (:[])) <$> parseBooleanQuery d s+parseQueryTerm d (T.stripPrefix "all:" -> Just s) = first (AllPostings . (:[])) <$> parseBooleanQuery d s+parseQueryTerm _ "" = Right (Any, [])+parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s++-- | Parses a boolean query expression.+--+-- Boolean queries combine smaller queries into larger ones. The boolean operators+-- made available through this function are "NOT e", "e AND e", "e OR e", and "e e".+-- Query options defined in multiple sub-queries are simply combined by concatenating+-- all options into one list.+--+-- Boolean operators in queries take precedence over one another. For instance, the+-- prefix-operator "NOT e" is always parsed before "e AND e", "e AND e" before "e OR e",+-- and "e OR e" before "e e".+--+-- The "space" operator still works as it did before the introduction of boolean operators:+-- it combines terms according to their types, using parseQueryList.+-- Whereas the new NOT, OR, and AND operators work uniformly for all term types.+-- There is an exception: queries being OR'd may not specify a date period,+-- because that can produce multiple, possibly disjoint, report periods and result sets,+-- and we don't have report semantics worked out for it yet. (#2178)+--+-- The result of this function is either an error encountered during parsing of the+-- expression or the combined query and query options.+--+-- >>> parseBooleanQuery nulldate "expenses:dining AND out"+-- Right (And [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])+--+-- >>> parseBooleanQuery nulldate "expenses:dining AND desc:a OR desc:b"+-- Right (Or [And [Acct (RegexpCI "expenses:dining"),Desc (RegexpCI "a")],Desc (RegexpCI "b")],[])+--+parseBooleanQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])+parseBooleanQuery d t =+  either (Left . ("failed to parse query:" <>) . customErrorBundlePretty) Right $+    parsewith spacedExprsP t++  where+    -- Our "boolean queries" are compound query expressions built with a hierarchy of combinators.+    -- At the top level we have one or more query expressions separated by space.+    -- These are combined in the default way according to their types (see combineQueriesByType).+    spacedExprsP :: SimpleTextParser (Query, [QueryOpt])+    spacedExprsP = combineWith combineQueriesByType <$> orExprsP `sepBy` skipNonNewlineSpaces1++      where+        combineWith :: ([Query] -> Query) -> [(Query, [QueryOpt])] -> (Query, [QueryOpt])+        combineWith f res =+          let (qs, qoptss) = unzip res+              qoptss'      = concat qoptss+          in case qs of+              []     -> (Any,                  qoptss')+              (q:[]) -> (simplifyQuery q,      qoptss')+              _      -> (simplifyQuery $ f qs, qoptss')++        -- Containing query expressions separated by "or".+        -- If there's more than one, make sure none contains a "date:".+        orExprsP :: SimpleTextParser (Query, [QueryOpt])+        orExprsP = do+          exprs <- andExprsP `sepBy` (try $ skipNonNewlineSpaces >> string' "or" >> skipNonNewlineSpaces1)+          if ( length exprs > 1+            && (any (/=Any) $ map (filterQuery queryIsDateOrDate2 . fst) exprs))+          then fail "sorry, using date: in OR expressions is not supported."+          else return $ combineWith Or exprs++          where+            -- Containing query expressions separated by "and".+            andExprsP :: SimpleTextParser (Query, [QueryOpt])+            andExprsP = combineWith And <$> maybeNotExprP `sepBy` (try $ skipNonNewlineSpaces >> string' "and" >> skipNonNewlineSpaces1)++              where+                -- Containing query expressions optionally preceded by "not".+                maybeNotExprP :: SimpleTextParser (Query, [QueryOpt])+                maybeNotExprP = (maybe id (\_ (q, qopts) -> (Not q, qopts)) <$>+                  optional (try $ string' "not" >> notFollowedBy (char ':') >> skipNonNewlineSpaces1)) <*> termOrParenthesisedExprP++                  where+                    -- Each of which is a parenthesised query expression or a single query term.+                    termOrParenthesisedExprP :: SimpleTextParser (Query, [QueryOpt])+                    termOrParenthesisedExprP = +                      between (char '(' >> skipNonNewlineSpaces) (try $ skipNonNewlineSpaces >> char ')') spacedExprsP+                      <|> queryTermP++                      where+                        -- A simple query term: foo, acct:foo, desc:foo, payee:foo etc.+                        queryTermP :: SimpleTextParser (Query, [QueryOpt])+                        queryTermP = do+                          prefix <- optional queryPrefixP+                          arg <- queryArgP+                          case parseQueryTerm d (fromMaybe "" prefix <> arg) of+                            Right q  -> return q+                            Left err -> error' err++                          where+                            -- One of the query prefixes: acct:, desc:, payee: etc (plus zero or more not: prefixes).+                            queryPrefixP :: SimpleTextParser T.Text+                            queryPrefixP =+                              (string "not:" <> (fromMaybe "" <$> optional queryPrefixP))+                              <|> choice' (string <$> queryprefixes)+                              <?> "query prefix"++                            -- A query term's argument, the part after the prefix:+                            -- any text enclosed in single quotes or double quotes,+                            -- or any text up to the next space, closing parenthesis, or end of line,+                            -- if it is not one of the keywords "not", "and", "or".+                            queryArgP :: SimpleTextParser T.Text+                            queryArgP = choice'+                              [ stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])),+                                stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])),+                                T.pack <$> (notFollowedBy keywordP >> (many $ noneOf (") \n\r" :: [Char]))) ]++                              where+                                -- Any of the combinator keywords used above (not/and/or), terminated by a space.+                                keywordP :: SimpleTextParser T.Text+                                keywordP = choice' (string' <$> ["not ", "and ", "or "])++-- | Parse the argument of an amt query term ([OP][SIGN]NUM), to an+-- OrdPlus and a Quantity, or if parsing fails, an error message. OP+-- can be <=, <, >=, >, or = . NUM can be a simple integer or decimal.+-- If a decimal, the decimal mark must be period, and it must have+-- digits preceding it. Digit group marks are not allowed.+parseAmountQueryTerm :: T.Text -> Either String (OrdPlus, Quantity)+parseAmountQueryTerm amtarg =+  case amtarg of+    -- number has a + sign, do a signed comparison+    (parse "<=+" -> Just q) -> Right (LtEq    ,q)+    (parse "<+"  -> Just q) -> Right (Lt      ,q)+    (parse ">=+" -> Just q) -> Right (GtEq    ,q)+    (parse ">+"  -> Just q) -> Right (Gt      ,q)+    (parse "=+"  -> Just q) -> Right (Eq      ,q)+    (parse "+"   -> Just q) -> Right (Eq      ,q)+    -- number has a - sign, do a signed comparison+    (parse "<-"  -> Just q) -> Right (Lt      ,-q)+    (parse "<=-" -> Just q) -> Right (LtEq    ,-q)+    (parse ">-"  -> Just q) -> Right (Gt      ,-q)+    (parse ">=-" -> Just q) -> Right (GtEq    ,-q)+    (parse "=-"  -> Just q) -> Right (Eq      ,-q)+    (parse "-"   -> Just q) -> Right (Eq      ,-q)+    -- number is unsigned and zero, do a signed comparison (more useful)+    (parse "<="  -> Just 0) -> Right (LtEq    ,0)+    (parse "<"   -> Just 0) -> Right (Lt      ,0)+    (parse ">="  -> Just 0) -> Right (GtEq    ,0)+    (parse ">"   -> Just 0) -> Right (Gt      ,0)+    -- number is unsigned and non-zero, do an absolute magnitude comparison+    (parse "<="  -> Just q) -> Right (AbsLtEq ,q)+    (parse "<"   -> Just q) -> Right (AbsLt   ,q)+    (parse ">="  -> Just q) -> Right (AbsGtEq ,q)+    (parse ">"   -> Just q) -> Right (AbsGt   ,q)+    (parse "="   -> Just q) -> Right (AbsEq   ,q)+    (parse ""    -> Just q) -> Right (AbsEq   ,q)+    _ -> Left . T.unpack $+         "could not parse as a comparison operator followed by an optionally-signed number: " <> amtarg+  where+    -- Strip outer whitespace from the text, require and remove the+    -- specified prefix, remove all whitespace from the remainder, and+    -- read it as a simple integer or decimal if possible.+    parse :: T.Text -> T.Text -> Maybe Quantity+    parse p s = (T.stripPrefix p . T.strip) s >>= readMay . T.unpack . T.filter (/=' ')++parseTag :: T.Text -> Either RegexError Query+parseTag s = do+    tag <- toRegexCI $ if T.null v then s else n+    body <- if T.null v then pure Nothing else Just <$> toRegexCI (T.tail v)+    return $ Tag tag body+  where (n,v) = T.break (=='=') s++parseDepthSpec :: T.Text -> Either RegexError DepthSpec+parseDepthSpec s = do+    let depthString = T.unpack $ if T.null b then a else T.tail b+    depth <- case readMay depthString of+        Just d | d >= 0 -> Right d+        _ -> Left $ "depth: should be a positive number, but received " ++ depthString+    regexp <- mapM toRegexCI $ if T.null b then Nothing else Just a+    return $ case regexp of+      Nothing -> DepthSpec (Just depth) []+      Just r  -> DepthSpec Nothing [(r, depth)]+  where+    (a,b) = T.break (=='=') s++parseDepthSpecQuery :: T.Text -> Either RegexError Query+parseDepthSpecQuery s = do+    DepthSpec flat rs <- parseDepthSpec s+    let regexps = map (uncurry DepthAcct) rs+    return . And $ maybe id (\d -> (Depth d :)) flat regexps++-- | Parse one or more account type code letters to a query matching any of those types.+parseTypeCodes :: T.Text -> Either String Query+parseTypeCodes s =+  case partitionEithers $ map (parseAccountType False . T.singleton) $ T.unpack s of+    ((e:_),_) -> Left $ "could not parse " <> show e <> " as an account type code.\n" <> help+    ([],[])   -> Left help+    ([],ts)   -> Right $ Type ts+  where+    help = "type:'s argument should be one or more of " ++ accountTypeChoices False++accountTypeChoices :: Bool -> String+accountTypeChoices allowlongform =+  intercalate ", "+    -- keep synced with parseAccountType+    $ ["A","L","E","R","X","C","V","G","U"]+    ++ if allowlongform then ["Asset","Liability","Equity","Revenue","Expense","Cash","Conversion","Gain","UnrealisedGain"] else []++-- | Case-insensitively parse one single-letter code, or one long-form word if permitted, to an account type.+-- On failure, returns the unparseable text.+parseAccountType :: Bool -> Text -> Either String AccountType+parseAccountType allowlongform s =+  case T.toLower s of+    -- keep synced with accountTypeChoices+    "a"                               -> Right Asset+    "l"                               -> Right Liability+    "e"                               -> Right Equity+    "r"                               -> Right Revenue+    "x"                               -> Right Expense+    "c"                               -> Right Cash+    "v"                               -> Right Conversion+    "g"                               -> Right Gain+    "u"                               -> Right UnrealisedGain+    "asset"          | allowlongform  -> Right Asset+    "liability"      | allowlongform  -> Right Liability+    "equity"         | allowlongform  -> Right Equity+    "revenue"        | allowlongform  -> Right Revenue+    "expense"        | allowlongform  -> Right Expense+    "cash"           | allowlongform  -> Right Cash+    "conversion"     | allowlongform  -> Right Conversion+    "gain"           | allowlongform  -> Right Gain+    "unrealisedgain" | allowlongform  -> Right UnrealisedGain+    "unrealizedgain" | allowlongform  -> Right UnrealisedGain+    _                                 -> Left $ T.unpack s++-- | Parse the value part of a "status:" query, or return an error.+parseStatus :: T.Text -> Either String Status+parseStatus s | s `elem` ["*","1"] = Right Cleared+              | s `elem` ["","0"]  = Right Unmarked+              | s == "!"           = Right Pending+              | otherwise          = Left $ "could not parse "++show s++" as a status (should be *, ! or empty)"++-- | Parse the boolean value part of a "status:" query. "1" means true,+-- anything else will be parsed as false without error.+parseBool :: T.Text -> Bool+parseBool s = s `elem` truestrings++truestrings :: [T.Text]+truestrings = ["1"]++-- * modifying++simplifyQuery :: Query -> Query+simplifyQuery q0 =+  let q1 = simplify q0+  in if q1 == q0 then q0 else simplifyQuery q1+  where+    simplify (And []) = Any+    simplify (And [q]) = simplify q+    simplify (And qs) | same qs = simplify $ headErr qs  -- PARTIAL headErr succeeds because pattern ensures non-null qs+                      | None `elem` qs = None+                      | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs+                      | otherwise = And $ map simplify dateqs ++ map simplify otherqs+                      where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs+    simplify (Or []) = Any+    simplify (Or [q]) = simplifyQuery q+    simplify (Or qs) | same qs = simplify $ headErr qs  -- PARTIAL headErr succeeds because pattern ensures non-null qs+                     | Any `elem` qs = Any+                     -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs  ?+                     | otherwise = Or $ map simplify $ filter (/=None) qs+    simplify (Date (DateSpan Nothing Nothing)) = Any+    simplify (Date2 (DateSpan Nothing Nothing)) = Any+    simplify q = q++same [] = True+same (a:as) = all (a==) as++-- | Remove query terms (or whole sub-expressions) from this query+-- which do not match the given predicate. XXX Semantics not completely clear.+-- Also calls simplifyQuery on the result.+filterQuery :: (Query -> Bool) -> Query -> Query+filterQuery p = simplifyQuery . filterQuery' p++-- | Like filterQuery, but returns the filtered query as is, without simplifying.+-- Note this is problematic for complex boolean queries, which if split apart +-- by filterQuery and then re-composed, may be altered. See eg #2371.+filterQuery' :: (Query -> Bool) -> Query -> Query+filterQuery' p (And qs) = And $ map (filterQuery' p) qs+filterQuery' p (Or qs) = Or $ map (filterQuery' p) qs+-- filterQuery' p (Or qs) = Or $ filter (not.(==Any)) $ map (filterQuery' p) qs  -- better for some, worse for others+filterQuery' p q = if p q then q else Any++-- | Remove query terms (or whole sub-expressions) from this query+-- which match neither the given predicate nor that predicate negated +-- (eg, if predicate is queryIsAcct, this will keep both "acct:" and "not:acct:" terms).+-- Also calls simplifyQuery on the result.+-- (Since 1.24.1, might be merged into filterQuery in future.)+-- XXX Semantics not completely clear.+filterQueryOrNotQuery :: (Query -> Bool) -> Query -> Query+filterQueryOrNotQuery p0 = simplifyQuery . filterQueryOrNotQuery' p0+  where+    filterQueryOrNotQuery' :: (Query -> Bool) -> Query -> Query+    filterQueryOrNotQuery' p (And qs)      = And $ map (filterQueryOrNotQuery p) qs+    filterQueryOrNotQuery' p (Or qs)       = Or  $ map (filterQueryOrNotQuery p) qs+    filterQueryOrNotQuery' p (Not q) | p q = Not $ filterQueryOrNotQuery p q+    filterQueryOrNotQuery' p q = if p q then q else Any++-- * predicates++-- | Does this simple query predicate match any part of this possibly compound query ?+matchesQuery :: (Query -> Bool) -> Query -> Bool+matchesQuery p (And qs) = any (matchesQuery p) qs+matchesQuery p (Or qs)  = any (matchesQuery p) qs+matchesQuery p (Not q)  = p q+matchesQuery p q        = p q++-- | Does this query match everything ?+queryIsNull :: Query -> Bool+queryIsNull Any = True+queryIsNull (And []) = True+queryIsNull (Not (Or [])) = True+queryIsNull _ = False++-- | Is this a simple query of this type (date:) ? +-- Does not match a compound query involving and/or/not.+-- Likewise for the following functions.+queryIsDate :: Query -> Bool+queryIsDate (Date _) = True+queryIsDate _ = False++queryIsDate2 :: Query -> Bool+queryIsDate2 (Date2 _) = True+queryIsDate2 _ = False++queryIsDateOrDate2 :: Query -> Bool+queryIsDateOrDate2 (Date _) = True+queryIsDateOrDate2 (Date2 _) = True+queryIsDateOrDate2 _ = False++queryIsStatus :: Query -> Bool+queryIsStatus (StatusQ _) = True+queryIsStatus _ = False++queryIsCode :: Query -> Bool+queryIsCode (Code _) = True+queryIsCode _ = False++queryIsDesc :: Query -> Bool+queryIsDesc (Desc _) = True+queryIsDesc _ = False++queryIsTag :: Query -> Bool+queryIsTag (Tag _ _) = True+queryIsTag _ = False++queryIsAcct :: Query -> Bool+queryIsAcct (Acct _) = True+queryIsAcct _ = False++queryIsType :: Query -> Bool+queryIsType (Type _) = True+queryIsType _ = False++queryIsDepth :: Query -> Bool+queryIsDepth (Depth _) = True+queryIsDepth (DepthAcct _ _) = True+queryIsDepth _ = False++queryIsReal :: Query -> Bool+queryIsReal (Real _) = True+queryIsReal _ = False++queryIsAmt :: Query -> Bool+queryIsAmt (Amt _ _) = True+queryIsAmt _         = False++queryIsSym :: Query -> Bool+queryIsSym (Sym _) = True+queryIsSym _ = False++queryIsAmtOrSym :: Query -> Bool+queryIsAmtOrSym = liftA2 (||) queryIsAmt queryIsSym++-- | Does this query specify a start date and nothing else (that would+-- filter postings prior to the date) ?+-- When the flag is true, look for a starting secondary date instead.+queryIsStartDateOnly :: Bool -> Query -> Bool+queryIsStartDateOnly _ Any = False+queryIsStartDateOnly _ None = False+queryIsStartDateOnly secondary (Or ms) = all (queryIsStartDateOnly secondary) ms+queryIsStartDateOnly secondary (And ms) = all (queryIsStartDateOnly secondary) ms+queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True+queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True+queryIsStartDateOnly _ _ = False++-- | Does this query involve a property of transactions (or their postings),+-- making it inapplicable to account declarations ?+queryIsTransactionRelated :: Query -> Bool+queryIsTransactionRelated = matchesQuery (+      queryIsDate+  ||| queryIsDate2+  ||| queryIsStatus+  ||| queryIsCode+  ||| queryIsDesc+  ||| queryIsReal+  ||| queryIsAmt+  ||| queryIsSym+  )++(|||) :: (a->Bool) -> (a->Bool) -> (a->Bool)+p ||| q = \v -> p v || q v++-- * accessors++-- | What start date (or secondary date) does this query specify, if any ?+-- For OR expressions, use the earliest of the dates. NOT is ignored.+queryStartDate :: Bool -> Query -> Maybe Day+queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms+queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms+queryStartDate False (Date (DateSpan (Just d) _)) = Just $ fromEFDay d+queryStartDate True (Date2 (DateSpan (Just d) _)) = Just $ fromEFDay d+queryStartDate _ _ = Nothing++-- | What end date (or secondary date) does this query specify, if any ?+-- For OR expressions, use the latest of the dates. NOT is ignored.+queryEndDate :: Bool -> Query -> Maybe Day+queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms+queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms+queryEndDate False (Date (DateSpan _ (Just d))) = Just $ fromEFDay d+queryEndDate True (Date2 (DateSpan _ (Just d))) = Just $ fromEFDay d+queryEndDate _ _ = Nothing++queryTermDateSpan (Date spn) = Just spn+queryTermDateSpan _ = Nothing++-- | What date span (or with a true argument, what secondary date span) does this query specify ?+-- OR clauses specifying multiple spans return their union (the span enclosing all of them).+-- AND clauses specifying multiple spans return their intersection.+-- NOT clauses are ignored.+queryDateSpan :: Bool -> Query -> DateSpan+queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs+queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs+queryDateSpan _     (Date spn)  = spn+queryDateSpan True (Date2 spn)  = spn+queryDateSpan _ _                = nulldatespan++-- | What date span does this query specify, treating primary and secondary dates as equivalent ?+-- OR clauses specifying multiple spans return their union (the span enclosing all of them).+-- AND clauses specifying multiple spans return their intersection.+-- NOT clauses are ignored.+queryDateSpan' :: Query -> DateSpan+queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs+queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs+queryDateSpan' (Date spn)  = spn+queryDateSpan' (Date2 spn) = spn+queryDateSpan' _            = nulldatespan++-- | What is the earliest of these dates, where Nothing is earliest ?+earliestMaybeDate :: [Maybe Day] -> Maybe Day+earliestMaybeDate = fromMaybe Nothing . minimumMay++-- | What is the latest of these dates, where Nothing is earliest ?+latestMaybeDate :: [Maybe Day] -> Maybe Day+latestMaybeDate = fromMaybe Nothing . maximumMay++-- | What is the earliest of these dates, where Nothing is the latest ?+earliestMaybeDate' :: [Maybe Day] -> Maybe Day+earliestMaybeDate' = fromMaybe Nothing . minimumMay . filter isJust++-- | What is the latest of these dates, where Nothing is the latest ?+latestMaybeDate' :: [Maybe Day] -> Maybe Day+latestMaybeDate' = fromMaybe Nothing . maximumByMay compareNothingMax+  where+    compareNothingMax Nothing  Nothing  = EQ+    compareNothingMax (Just _) Nothing  = LT+    compareNothingMax Nothing  (Just _) = GT+    compareNothingMax (Just a) (Just b) = compare a b++-- | The depth limit this query specifies, if it has one+queryDepth :: Query -> DepthSpec+queryDepth (Or qs)         = foldMap queryDepth qs+queryDepth (And qs)        = foldMap queryDepth qs+queryDepth (Depth d)       = DepthSpec (Just d) []+queryDepth (DepthAcct r d) = DepthSpec Nothing [(r,d)]+queryDepth _               = mempty++-- | The account we are currently focussed on, if any, and whether subaccounts are included.+-- Just looks at the first query option.+inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)+inAccount [] = Nothing+inAccount (QueryOptInAcctOnly a:_) = Just (a,False)+inAccount (QueryOptInAcct a:_) = Just (a,True)+inAccount (QueryOptInterval _:rest) = inAccount rest++-- | A query for the account(s) we are currently focussed on, if any.+-- Just looks at the first query option.+inAccountQuery :: [QueryOpt] -> Maybe Query+inAccountQuery [] = Nothing+inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a+inAccountQuery (QueryOptInAcct a     : _) = Just . Acct $ accountNameToAccountRegex a+inAccountQuery (QueryOptInterval _   : rest) = inAccountQuery rest++-- -- | Convert a query to its inverse.+-- negateQuery :: Query -> Query+-- negateQuery =  Not++-- matching things with queries++matchesCommodity :: Query -> CommoditySymbol -> Bool+matchesCommodity (Sym r)          s = regexMatchText r s+matchesCommodity (Any)            _ = True+matchesCommodity (None)           _ = False+matchesCommodity (Or qs)          s = any (`matchesCommodity` s) qs+matchesCommodity (And qs)         s = all (`matchesCommodity` s) qs+matchesCommodity (AnyPosting qs)  s = all (`matchesCommodity` s) qs+matchesCommodity (AllPostings qs) s = all1 (`matchesCommodity` s) qs+matchesCommodity _                _ = False++-- | Does the match expression match this (simple) amount ?+matchesAmount :: Query -> Amount -> Bool+matchesAmount (Not q) a = not $ q `matchesAmount` a+matchesAmount (Any) _ = True+matchesAmount (None) _ = False+matchesAmount (Or qs) a = any (`matchesAmount` a) qs+matchesAmount (And qs) a = all (`matchesAmount` a) qs+matchesAmount (AnyPosting  qs) a = all (`matchesAmount` a) qs+matchesAmount (AllPostings qs) a = all1 (`matchesAmount` a) qs+matchesAmount (Amt ord n) a = compareAmount ord n a+matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a)+matchesAmount _ _ = True++-- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ?+compareAmount :: OrdPlus -> Quantity -> Amount -> Bool+compareAmount ord q Amount{aquantity=aq} = case ord of Lt      -> aq <  q+                                                       LtEq    -> aq <= q+                                                       Gt      -> aq >  q+                                                       GtEq    -> aq >= q+                                                       Eq      -> aq == q+                                                       AbsLt   -> abs aq <  abs q+                                                       AbsLtEq -> abs aq <= abs q+                                                       AbsGt   -> abs aq >  abs q+                                                       AbsGtEq -> abs aq >= abs q+                                                       AbsEq   -> abs aq == abs q++matchesMixedAmount :: Query -> MixedAmount -> Bool+matchesMixedAmount q ma = case amountsRaw ma of+    [] -> q `matchesAmount` nullamt+    as -> any (q `matchesAmount`) as++-- | Does the query match this account name ?+-- A matching in: clause is also considered a match.+matchesAccount :: Query -> AccountName -> Bool+matchesAccount (None) _ = False+matchesAccount (Not m) a = not $ matchesAccount m a+matchesAccount (Or ms) a = any (`matchesAccount` a) ms+matchesAccount (And ms) a = all (`matchesAccount` a) ms+matchesAccount (AnyPosting  qs) a = all (`matchesAccount` a) qs+matchesAccount (AllPostings qs) a = all1 (`matchesAccount` a) qs+matchesAccount (Acct r) a = regexMatchText r a+matchesAccount (Depth d) a = accountNameLevel a <= d+matchesAccount (DepthAcct r d) a = accountNameLevel a <= d || not (regexMatchText r a)+matchesAccount (Tag _ _) _ = False+matchesAccount _ _ = True++-- | Like matchesAccount, but with optional extra matching features:+--+-- - If the account's type is provided, any type: terms in the query+--   must match it (and any negated type: terms must not match it).+--+-- - If the account's tags are provided, any tag: terms must match+--   at least one of them (and any negated tag: terms must match none).+--+matchesAccountExtra :: (AccountName -> Maybe AccountType) -> (AccountName -> [Tag]) -> Query -> AccountName -> Bool+matchesAccountExtra atypes atags (Not q  ) a = not $ matchesAccountExtra atypes atags q a+matchesAccountExtra atypes atags (Or  qs ) a = any (\q -> matchesAccountExtra atypes atags q a) qs+matchesAccountExtra atypes atags (And qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs+matchesAccountExtra atypes atags (AnyPosting  qs ) a = all (\q -> matchesAccountExtra atypes atags q a) qs+matchesAccountExtra atypes atags (AllPostings qs ) a = all1 (\q -> matchesAccountExtra atypes atags q a) qs+matchesAccountExtra atypes _     (Type ts) a = maybe False (\t -> any (t `isAccountSubtypeOf`) ts) $ atypes a+matchesAccountExtra _      atags (Tag npat vpat) a = patternsMatchTags npat vpat $ atags a+matchesAccountExtra _      _     q         a = matchesAccount q a++-- | Does the match expression match this posting ?+-- When matching account name, and the posting has been transformed+-- in some way, we will match either the original or transformed name.+matchesPosting :: Query -> Posting -> Bool+matchesPosting (Not q) p = not $ q `matchesPosting` p+matchesPosting (Any) _ = True+matchesPosting (None) _ = False+matchesPosting (Or qs) p = any (`matchesPosting` p) qs+matchesPosting (And qs) p = all (`matchesPosting` p) qs+matchesPosting (AnyPosting  qs) p = all (`matchesPosting` p) qs+matchesPosting (AllPostings qs) p = all1 (`matchesPosting` p) qs+matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p+matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p+matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) where matches = regexMatchText r . paccount+matchesPosting (Date spn) p = spn `spanContainsDate` postingDate p+matchesPosting (Date2 spn) p = spn `spanContainsDate` postingDate2 p+matchesPosting (StatusQ s) p = postingStatus p == s+matchesPosting (Real v) p = v == isReal p+matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a+matchesPosting q@(DepthAcct _ _) Posting{paccount=a} = q `matchesAccount` a+matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as+matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . acommodity) $ amountsRaw as+matchesPosting (Tag n v) p = case (reString n, v) of+  ("payee", Just v') -> maybe False (regexMatchText v' . transactionPayee) $ ptransaction p+  ("note", Just v') -> maybe False (regexMatchText v' . transactionNote) $ ptransaction p+  (_, mv) -> patternsMatchTags n mv $ postingAllTags p+matchesPosting (Type _) _ = False++-- | Like matchesPosting, but if the posting's account's type is provided,+-- any type: terms in the query must match it (and any negated type: terms+-- must not match it).+matchesPostingExtra :: (AccountName -> Maybe AccountType) -> Query -> Posting -> Bool+matchesPostingExtra atype (Not q )  p = not $ matchesPostingExtra atype q p+matchesPostingExtra atype (Or  qs)  p = any (\q -> matchesPostingExtra atype q p) qs+matchesPostingExtra atype (And qs)  p = all (\q -> matchesPostingExtra atype q p) qs+matchesPostingExtra atype (AnyPosting  qs)  p = all (\q -> matchesPostingExtra atype q p) qs+matchesPostingExtra atype (AllPostings qs)  p = all1 (\q -> matchesPostingExtra atype q p) qs+matchesPostingExtra atype (Type ts) p =+  -- does posting's account's type, if we can detect it, match any of the given types ?+  (maybe False (\t -> any (t `isAccountSubtypeOf`) ts) . atype $ paccount p)+  -- or, try the same test with the original (pre-aliasing/pivoting) posting's account+  || (fromMaybe False $ do+      porig <- poriginal p+      let a = paccount porig+      t <- atype a+      Just $ any (t `isAccountSubtypeOf`) ts+  )+matchesPostingExtra _ q p             = matchesPosting q p++-- | Does the match expression match this transaction ?+matchesTransaction :: Query -> Transaction -> Bool+matchesTransaction (Not q) t = not $ q `matchesTransaction` t+matchesTransaction (Any) _ = True+matchesTransaction (None) _ = False+matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs+matchesTransaction (And qs) t = all (`matchesTransaction` t) qs+matchesTransaction (AnyPosting  qs) t = any (\p -> all (`matchesPosting` p) qs) $ tpostings t+matchesTransaction (AllPostings qs) t = all1 (\p -> all (`matchesPosting` p) qs) $ tpostings t+matchesTransaction (Code r) t = regexMatchText r $ tcode t+matchesTransaction (Desc r) t = regexMatchText r $ tdescription t+matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction (Date spn) t = spanContainsDate spn $ tdate t+matchesTransaction (Date2 spn) t = spanContainsDate spn $ transactionDate2 t+matchesTransaction (StatusQ s) t = tstatus t == s+matchesTransaction (Real v) t = v == hasRealPostings t+matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction q@(Depth _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction q@(DepthAcct _ _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction (Tag n v) t = case (reString n, v) of+  ("payee", Just v') -> regexMatchText v' $ transactionPayee t+  ("note", Just v') -> regexMatchText v' $ transactionNote t+  (_, v') -> patternsMatchTags n v' $ transactionAllTags t+matchesTransaction (Type _) _ = False++-- | Like matchesTransaction, but if the journal's account types are provided,+-- any type: terms in the query must match at least one posting's account type+-- (and any negated type: terms must match none).+matchesTransactionExtra :: (AccountName -> Maybe AccountType) -> Query -> Transaction -> Bool+matchesTransactionExtra atype (Not  q) t = not $ matchesTransactionExtra atype q t+matchesTransactionExtra atype (Or  qs) t = any (\q -> matchesTransactionExtra atype q t) qs+matchesTransactionExtra atype (And qs) t = all (\q -> matchesTransactionExtra atype q t) qs+matchesTransactionExtra atype (AnyPosting  qs) t = any (\p -> all (\q -> matchesPostingExtra atype q p) qs) $ tpostings t+matchesTransactionExtra atype (AllPostings qs) t = all1 (\p -> all (\q -> matchesPostingExtra atype q p) qs) $ tpostings t+matchesTransactionExtra atype q@(Type _) t = any (matchesPostingExtra atype q) $ tpostings t+matchesTransactionExtra _ q t = matchesTransaction q t++-- | Does the query match this transaction description ?+-- Non-desc: query terms are ignored (this might disrupt some boolean queries).+matchesDescription :: Query -> Text -> Bool+matchesDescription (Not q) d          = not $ q `matchesDescription` d+matchesDescription (Any) _            = True+matchesDescription (None) _           = False+matchesDescription (Or qs) d          = any (`matchesDescription` d) $ filter queryIsDesc qs+matchesDescription (And qs) d         = all (`matchesDescription` d) $ filter queryIsDesc qs+matchesDescription (AnyPosting  qs) d = all (`matchesDescription` d) $ filter queryIsDesc qs+matchesDescription (AllPostings qs) d = all1 (`matchesDescription` d) $ filter queryIsDesc qs+matchesDescription (Code _) _         = False+matchesDescription (Desc r) d         = regexMatchText r d+matchesDescription _ _                = False++-- | Does the query match this transaction payee ?+-- Tests desc: (and payee: ?) terms, any other terms are ignored.+-- XXX Currently an alias for matchDescription. I'm not sure if more is needed,+-- There's some shenanigan with payee: and "payeeTag" to figure out.+matchesPayeeWIP :: Query -> Payee -> Bool+matchesPayeeWIP = matchesDescription++-- | Do this name regex and optional value regex match the name and value of any of these tags ?+patternsMatchTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool+patternsMatchTags namepat valuepat = any (matches namepat valuepat)+  where+    matches npat vpat (n,v) = regexMatchText npat n && maybe (const True) regexMatchText vpat v++-- | Does the query match the name and optionally the value of this tag ?+-- Non-tag: query terms are ignored (this might disrupt some boolean queries).+matchesTag :: Query -> Tag -> Bool+matchesTag (Not q)          t = not $ q `matchesTag` t+matchesTag (Any)            _ = True+matchesTag (None)           _ = False+matchesTag (Or qs)          t = any (`matchesTag` t) $ filter queryIsTag qs+matchesTag (And qs)         t = all (`matchesTag` t) $ filter queryIsTag qs+matchesTag (AnyPosting qs)  t = all (`matchesTag` t) $ filter queryIsTag qs+matchesTag (AllPostings qs) t = all1 (`matchesTag` t) $ filter queryIsTag qs+matchesTag (Tag npat mvpat) t = patternsMatchTags npat mvpat [t]+matchesTag _                _ = False++-- | Does the query match this market price ?+matchesPriceDirective :: Query -> PriceDirective -> Bool+matchesPriceDirective (None) _           = False+matchesPriceDirective (Not q) p          = not $ matchesPriceDirective q p+matchesPriceDirective (Or qs) p          = any (`matchesPriceDirective` p) qs+matchesPriceDirective (And qs) p         = all (`matchesPriceDirective` p) qs+matchesPriceDirective (AnyPosting  qs) p = all (`matchesPriceDirective` p) qs+matchesPriceDirective (AllPostings qs) p = all1 (`matchesPriceDirective` p) qs+matchesPriceDirective q@(Amt _ _) p      = matchesAmount q (pdamount p)+matchesPriceDirective q@(Sym _) p        = matchesCommodity q (pdcommodity p)+matchesPriceDirective (Date spn) p       = spanContainsDate spn (pddate p)+matchesPriceDirective _ _                = True+++-- tests++tests_Query = testGroup "Query" [+   testCase "simplifyQuery" $ do+     (simplifyQuery $ Or [Acct $ toRegex' "a"])      @?= (Acct $ toRegex' "a")+     (simplifyQuery $ Or [Any,None])      @?= (Any)+     (simplifyQuery $ And [Any,None])     @?= (None)+     (simplifyQuery $ And [Any,Any])      @?= (Any)+     (simplifyQuery $ And [Acct $ toRegex' "b",Any]) @?= (Acct $ toRegex' "b")+     (simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any)+     (simplifyQuery $ And [Date (DateSpan Nothing (Just $ Exact $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ Exact $ fromGregorian 2012 01 01) Nothing)])+       @?= (Date (DateSpan (Just $ Exact $ fromGregorian 2012 01 01) (Just $ Exact $ fromGregorian 2013 01 01)))+     (simplifyQuery $ And [Or [],Or [Desc $ toRegex' "b b"]]) @?= (Desc $ toRegex' "b b")++  ,testCase "parseQuery" $ do+     (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct $ toRegexCI' "expenses:autres d\233penses", Desc $ toRegexCI' "b"], [])+     parseQuery nulldate "inacct:a desc:\"b b\""                       @?= Right (Desc $ toRegexCI' "b b", [QueryOptInAcct "a"])+     parseQuery nulldate "inacct:a inacct:b"                           @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])+     parseQuery nulldate "desc:'x x'"                                  @?= Right (Desc $ toRegexCI' "x x", [])+     parseQuery nulldate "'a a' 'b"                                    @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], [])+     parseQuery nulldate "\""                                          @?= Right (Acct $ toRegexCI' "\"", [])++  ,testCase "parseBooleanQuery" $ do+     parseBooleanQuery nulldate "(tag:'atag=a')"     @?= Right (Tag (toRegexCI' "atag") (Just $ toRegexCI' "a"), [])+     parseBooleanQuery nulldate "(  tag:\"atag=a\"  )"     @?= Right (Tag (toRegexCI' "atag") (Just $ toRegexCI' "a"), [])+     parseBooleanQuery nulldate "(acct:'expenses:food')"     @?= Right (Acct $ toRegexCI' "expenses:food", [])+     parseBooleanQuery nulldate "(((acct:'expenses:food')))" @?= Right (Acct $ toRegexCI' "expenses:food", [])+     parseBooleanQuery nulldate "acct:'expenses:food' AND desc:'b'" @?= Right (And [Acct $ toRegexCI' "expenses:food", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "((desc:'a') AND (desc:'b') OR (desc:'c'))" @?= Right (Or [And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], Desc $ toRegexCI' "c"], [])+     parseBooleanQuery nulldate "((desc:'a') OR (desc:'b') AND (desc:'c'))" @?= Right (Or [Desc $ toRegexCI' "a", And [Desc $ toRegexCI' "b", Desc $ toRegexCI' "c"]], [])+     parseBooleanQuery nulldate "((desc:'a') AND desc:'b' AND (desc:'c'))" @?= Right (And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b", Desc $ toRegexCI' "c"], [])+     parseBooleanQuery nulldate "(NOT (desc:'a') AND (desc:'b'))" @?= Right (And [Not $ Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "((desc:'a') AND (NOT desc:'b'))" @?= Right (And [Desc $ toRegexCI' "a", Not $ Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "(desc:'a' AND desc:'b')" @?= Right (And [Desc $ toRegexCI' "a", Desc $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "(acct:'a' acct:'b')" @?= Right (Or [Acct $ toRegexCI' "a", Acct $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate " acct:'a' acct:'b'" @?= Right (Or [Acct $ toRegexCI' "a", Acct $ toRegexCI' "b"], [])+     parseBooleanQuery nulldate "not:a" @?= Right (Not $ Acct $ toRegexCI' "a", [])+     parseBooleanQuery nulldate "expenses:food OR (tag:A expenses:drink)" @?= Right (Or [Acct $ toRegexCI' "expenses:food", And [Acct $ toRegexCI' "expenses:drink", Tag (toRegexCI' "A") Nothing]], [])+     parseBooleanQuery nulldate "not a" @?= Right (Not $ Acct $ toRegexCI' "a", [])+     parseBooleanQuery nulldate "nota" @?= Right (Acct $ toRegexCI' "nota", [])+     parseBooleanQuery nulldate "not (acct:a)" @?= Right (Not $ Acct $ toRegexCI' "a", [])++  ,testCase "words''" $ do+      (words'' [] "a b")                   @?= ["a","b"]+      (words'' [] "'a b'")                 @?= ["a b"]+      (words'' [] "not:a b")               @?= ["not:a","b"]+      (words'' [] "not:'a b'")             @?= ["not:a b"]+      (words'' [] "'not:a b'")             @?= ["not:a b"]+      (words'' ["desc:"] "not:desc:'a b'") @?= ["not:desc:a b"]+      (words'' queryprefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"]+      (words'' queryprefixes "\"")              @?= ["\""]++  ,testCase "filterQuery" $ do+     filterQuery queryIsDepth Any       @?= Any+     filterQuery queryIsDepth (Depth 1) @?= Depth 1+     filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) @?= StatusQ Cleared+     filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any   -- XXX unclear++  ,testCase "parseQueryTerm" $ do+     parseQueryTerm nulldate "a"                                @?= Right (Acct $ toRegexCI' "a", [])+     parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Acct $ toRegexCI' "expenses:autres d\233penses", [])+     parseQueryTerm nulldate "not:desc:a b"                     @?= Right (Not $ Desc $ toRegexCI' "a b", [])+     parseQueryTerm nulldate "status:1"                         @?= Right (StatusQ Cleared, [])+     parseQueryTerm nulldate "status:*"                         @?= Right (StatusQ Cleared, [])+     parseQueryTerm nulldate "status:!"                         @?= Right (StatusQ Pending, [])+     parseQueryTerm nulldate "status:0"                         @?= Right (StatusQ Unmarked, [])+     parseQueryTerm nulldate "status:"                          @?= Right (StatusQ Unmarked, [])+     parseQueryTerm nulldate "payee:x"                          @?= (,[]) <$> payeeTag (Just "x")+     parseQueryTerm nulldate "note:x"                           @?= (,[]) <$> noteTag (Just "x")+     parseQueryTerm nulldate "real:1"                           @?= Right (Real True, [])+     parseQueryTerm nulldate "date:2008"                        @?= Right (Date $ DateSpan (Just $ Flex $ fromGregorian 2008 01 01) (Just $ Flex $ fromGregorian 2009 01 01), [])+     parseQueryTerm nulldate "date:from 2012/5/17"              @?= Right (Date $ DateSpan (Just $ Exact $ fromGregorian 2012 05 17) Nothing, [])+     parseQueryTerm nulldate "date:20180101-201804"             @?= Right (Date $ DateSpan (Just $ Exact $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 04 01), [])+     parseQueryTerm nulldate "inacct:a"                         @?= Right (Any, [QueryOptInAcct "a"])+     parseQueryTerm nulldate "tag:a"                            @?= Right (Tag (toRegexCI' "a") Nothing, [])+     parseQueryTerm nulldate "tag:a=some value"                 @?= Right (Tag (toRegexCI' "a") (Just $ toRegexCI' "some value"), [])+     parseQueryTerm nulldate "amt:<0"                           @?= Right (Amt Lt 0, [])+     parseQueryTerm nulldate "amt:>10000.10"                    @?= Right (Amt AbsGt 10000.1, [])++  ,testCase "parseAmountQueryTerm" $ do+     parseAmountQueryTerm "<0"        @?= Right (Lt,0) -- special case for convenience, since AbsLt 0 would be always false+     parseAmountQueryTerm ">0"        @?= Right (Gt,0) -- special case for convenience and consistency with above+     parseAmountQueryTerm " > - 0 "   @?= Right (Gt,0) -- accept whitespace around the argument parts+     parseAmountQueryTerm ">10000.10" @?= Right (AbsGt,10000.1)+     parseAmountQueryTerm "=0.23"     @?= Right (AbsEq,0.23)+     parseAmountQueryTerm "0.23"      @?= Right (AbsEq,0.23)+     parseAmountQueryTerm "<=+0.23"   @?= Right (LtEq,0.23)+     parseAmountQueryTerm "-0.23"     @?= Right (Eq,(-0.23))+     assertLeft $ parseAmountQueryTerm "-0,23"+     assertLeft $ parseAmountQueryTerm "=.23"++  ,testCase "queryStartDate" $ do+     let small = Just $ fromGregorian 2000 01 01+         big   = Just $ fromGregorian 2000 01 02+     queryStartDate False (And [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan (Exact <$> big) Nothing]) @?= big+     queryStartDate False (And [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan Nothing Nothing])         @?= small+     queryStartDate False (Or  [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan (Exact <$> big) Nothing]) @?= small+     queryStartDate False (Or  [Date $ DateSpan (Exact <$> small) Nothing, Date $ DateSpan Nothing Nothing])         @?= Nothing++  ,testCase "queryEndDate" $ do+     let small = Just $ fromGregorian 2000 01 01+         big   = Just $ fromGregorian 2000 01 02+     queryEndDate False (And [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing (Exact <$> big)]) @?= small+     queryEndDate False (And [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing Nothing])         @?= small+     queryEndDate False (Or  [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing (Exact <$> big)]) @?= big+     queryEndDate False (Or  [Date $ DateSpan Nothing (Exact <$> small), Date $ DateSpan Nothing Nothing])         @?= Nothing++  ,testCase "matchesAccount" $ do+     assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d"+     assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b"+     assertBool "" $ Depth 2 `matchesAccount` "a"+     assertBool "" $ Depth 2 `matchesAccount` "a:b"+     assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"+     assertBool "" $ Date nulldatespan `matchesAccount` "a"+     assertBool "" $ Date2 nulldatespan `matchesAccount` "a"+     assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a"++  ,testCase "matchesAccountExtra" $ do+     let tagq = Tag (toRegexCI' "type") Nothing+     assertBool "" $ not $ matchesAccountExtra (const Nothing) (const []) tagq "a"+     assertBool "" $       matchesAccountExtra (const Nothing) (const [("type","")]) tagq "a"++  ,testGroup "matchesPosting" [+     testCase "positive match on cleared posting status"  $+      assertBool "" $ (StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}+    ,testCase "negative match on cleared posting status"  $+      assertBool "" $ not $ (Not $ StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}+    ,testCase "positive match on unmarked posting status" $+      assertBool "" $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}+    ,testCase "negative match on unmarked posting status" $+      assertBool "" $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}+    ,testCase "positive match on true posting status acquired from transaction" $+      assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}}+    ,testCase "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}+    ,testCase "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}+    ,testCase "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}+    ,testCase "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"}+    ,testCase "tag:" $ do+      assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting+      assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}+      assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}+      assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+      assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+      assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+      assertBool "" $ not $ (Tag (toRegex' "foo foo") (Just $ toRegex' " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}+    ,testCase "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}+    ,testCase "cur:" $ do+      let toSym = fst . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)+      assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- becomes "^$$", ie testing for null symbol+      assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=mixedAmount $ usd 1} -- have to quote $ for regexpr+      assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}}+      assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=mixedAmount nullamt{acommodity="shekels"}}+  ]++  ,testCase "matchesTransaction" $ do+     assertBool "" $ Any `matchesTransaction` nulltransaction+     assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"}+     assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"}+     -- see posting for more tag tests+     assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}+     assertBool "" $ (Tag (toRegex' "payee") (Just $ toRegex' "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}+     assertBool "" $ (Tag (toRegex' "note") (Just $ toRegex' "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}+     -- a tag match on a transaction also matches posting tags+     assertBool "" $ (Tag (toRegex' "postingtag") Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}++     -- hledger print expr:'cash and amt:>0' means "show transactions with (at least one posting involving a cash account) and (at least one posting with a positive amount)"+     let exprq = And [Acct $ toRegex' "cash", Amt Gt 0]+     assertBool "" $ exprq `matchesTransaction` nulltransaction{tpostings=[nullposting{paccount="cash", pamount=1}]}+     assertBool "" $ exprq `matchesTransaction` nulltransaction{tpostings = [nullposting{paccount="cash"}, nullposting{paccount="food", pamount=1}]}++     -- hledger print any:'cash and amt:>0' means "show transactions where at least one posting posts a positive amount to a cash account".+     let anyq = AnyPosting [Acct $ toRegex' "cash", Amt Gt 0]+     assertBool "" $ anyq `matchesTransaction` nulltransaction{tpostings=[nullposting{paccount="cash", pamount=1}]}+     assertBool "" $ not $ anyq `matchesTransaction` nulltransaction{tpostings = [nullposting{paccount="cash"}, nullposting{paccount="food", pamount=1}]}++     -- hledger print all:'cash and amt:0' means "show transactions where all postings involve a cash account and have a zero amount".+     assertBool "" $ AllPostings [Amt Eq 0] `matchesTransaction`+      nulltransaction{tpostings = [nullposting{paccount = "cash"}, nullposting{paccount = "food"}]}+     assertBool "" $ not $ AllPostings [Acct $ toRegex' "cash", Amt Eq 0] `matchesTransaction`+      nulltransaction{tpostings = [nullposting{paccount = "cash"}, nullposting{paccount = "food"}]}  ]
Hledger/Read.hs view
@@ -1,240 +1,515 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections. {-|  This is the entry point to hledger's reading system, which can read Journals from various data formats. Use this module if you want to parse journal data or read journal files. Generally it should not be necessary to import modules below this one.++== Journal reading++Reading an input file (in journal, csv, timedot, or timeclock format..)+involves these steps:++- select an appropriate file format "reader"+  based on filename extension/file path prefix/function parameter.+  A reader contains a parser and a finaliser (usually @journalFinalise@).++- run the parser to get a ParsedJournal+  (this may run additional sub-parsers to parse included files)++- run the finaliser to get a complete Journal, which passes standard checks++- if reading multiple files: merge the per-file Journals into one+  overall Journal++- if using -s/--strict: run additional strict checks++- if running print --new: save .latest files for each input file.+  (import also does this, as its final step.)++== Journal merging++Journal implements the Semigroup class, so two Journals can be merged+into one Journal with @j1 <> j2@. This is implemented by the+@journalConcat@ function, whose documentation explains what merging+Journals means exactly.++== Journal finalising++This is post-processing done after parsing an input file, such as+inferring missing information, normalising amount styles,+checking for errors and so on - a delicate and influential stage+of data processing. +In hledger it is done by @journalFinalise@, which converts a+preliminary ParsedJournal to a validated, ready-to-use Journal.+This is called immediately after the parsing of each input file.+It is not called when Journals are merged.++== Journal reading API++There are three main Journal-reading functions:++- readJournal to read from a Text value.+  Selects a reader and calls its parser and finaliser,+  then does strict checking if needed.++- readJournalFile to read one file, or stdin if the file path is @-@.+  Uses the file path/file name to help select the reader,+  calls readJournal,+  then writes .latest files if needed.++- readJournalFiles to read multiple files.+  Calls readJournalFile for each file (without strict checking or .latest file writing)+  then merges the Journals into one,+  then does strict checking and .latest file writing at the end if needed.++Each of these also has an easier variant with ' suffix,+which uses default options and has a simpler type signature.++One more variant, @readJournalFilesAndLatestDates@, is like+readJournalFiles but exposing the latest transaction date+(and how many on the same day) seen for each file.+This is used by the import command.+ -} -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}+--- ** language+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +--- ** exports module Hledger.Read (    -- * Journal files-  PrefixedFilePath,   defaultJournal,+  defaultJournalSafely,+  defaultJournalWith,+  defaultJournalWithSafely,   defaultJournalPath,-  readJournalFiles,-  readJournalFile,+  defaultJournalPathSafely,+  defaultExistingJournalPath,+  defaultExistingJournalPathSafely,   requireJournalFileExists,   ensureJournalFileExists,-  splitReaderPrefix,+  journalEnvVar,+  -- journalEnvVar2,+  journalDefaultFilename,    -- * Journal parsing+  runExceptT,   readJournal,+  readJournalFile,+  readPossibleJournalFile,+  readPossibleJournalFiles,+  readJournalFiles,+  readJournalFilesAndLatestDates,++  -- * Easy journal parsing   readJournal',+  readJournal'',+  readJournalFile',+  readJournalFiles',+  orDieTrying, +  -- * Misc+  saveLatestDates,+  saveLatestDatesForFiles,+  isWindowsUnsafeDotPath,+   -- * Re-exported-  JournalReader.postingp,+  JournalReader.tmpostingrulep,+  findReader,+  splitReaderPrefix,+  runJournalParser,   module Hledger.Read.Common,+  module Hledger.Read.InputOptions,    -- * Tests   tests_Read,  ) where -import Control.Arrow (right)-import qualified Control.Exception as C-import Control.Monad.Except-import Data.Default-import Data.List-import Data.Maybe-import Data.Ord+--- ** imports+import Control.Exception qualified as C+import Control.Monad (unless, when, forM, (>=>))+import "mtl" Control.Monad.Except (ExceptT(..), runExceptT, liftEither)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Default (def)+import Data.Foldable (asum)+import Data.List (group, sort, sortBy)+import Data.List.NonEmpty (nonEmpty, NonEmpty((:|)))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Ord (comparing)+import Data.Semigroup (sconcat) import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T+import Data.Text.IO qualified as T import Data.Time (Day)-import Safe-import System.Directory (doesFileExist, getHomeDirectory)+import Safe (headDef)+import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Environment (getEnv)-import System.Exit (exitFailure)-import System.FilePath-import System.IO-import Text.Printf+import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeDirectory, takeFileName)+import System.Info (os)+import System.IO (Handle, hPutStrLn, stderr)+import Text.Printf (printf)  import Hledger.Data.Dates (getCurrentDay, parsedate, showDate)+import Hledger.Data.Journal (journalNumberTransactions, nulljournal)+import Hledger.Data.JournalChecks (journalStrictChecks) import Hledger.Data.Types import Hledger.Read.Common-import Hledger.Read.JournalReader   as JournalReader--- import qualified Hledger.Read.LedgerReader    as LedgerReader-import qualified Hledger.Read.TimedotReader   as TimedotReader-import qualified Hledger.Read.TimeclockReader as TimeclockReader-import Hledger.Read.CsvReader as CsvReader+import Hledger.Read.InputOptions+import Hledger.Read.JournalReader as JournalReader+import Hledger.Read.CsvReader (tests_CsvReader)+import Hledger.Read.RulesReader (tests_RulesReader) import Hledger.Utils-import Prelude hiding (getContents, writeFile) +--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings +--- ** journal reading+ journalEnvVar           = "LEDGER_FILE"-journalEnvVar2          = "LEDGER" journalDefaultFilename  = ".hledger.journal" --- The available journal readers, each one handling a particular data format.-readers :: [Reader]-readers = [-  JournalReader.reader- ,TimeclockReader.reader- ,TimedotReader.reader- ,CsvReader.reader---  ,LedgerReader.reader- ]+-- | Read the default journal file specified by the environment, +-- with default input options, or raise an error.+defaultJournal :: IO Journal+defaultJournal = defaultJournalSafely >>= either error' return -- PARTIAL: -readerNames :: [String]-readerNames = map rFormat readers+-- | Like defaultJournal, but return an error message instead of raising an error.+defaultJournalSafely :: IO (Either String Journal)+defaultJournalSafely = defaultJournalWithSafely definputopts --- | A file path optionally prefixed by a reader name and colon--- (journal:, csv:, timedot:, etc.).-type PrefixedFilePath = FilePath+-- | Like defaultJournal, but use the given input options.+defaultJournalWith :: InputOpts -> IO Journal+defaultJournalWith iopts = defaultJournalWithSafely iopts >>= either error' return -- PARTIAL: --- | Read the default journal file specified by the environment, or raise an error.-defaultJournal :: IO Journal-defaultJournal = defaultJournalPath >>= readJournalFile def >>= either error' return+-- | Like defaultJournalWith, but return an error message instead of raising an error.+defaultJournalWithSafely :: InputOpts -> IO (Either String Journal)+defaultJournalWithSafely iopts = (do+  f <- defaultJournalPath+  runExceptT $ readJournalFile iopts f+  )+  `C.catches` [  -- XXX+     C.Handler (\(e :: C.ErrorCall)   -> return $ Left $ show e)+    ,C.Handler (\(e :: C.IOException) -> return $ Left $ show e)+    ] --- | Get the default journal file path specified by the environment.--- Like ledger, we look first for the LEDGER_FILE environment--- variable, and if that does not exist, for the legacy LEDGER--- environment variable. If neither is set, or the value is blank,--- return the hard-coded default, which is @.hledger.journal@ in the--- users's home directory (or in the current directory, if we cannot--- determine a home directory).+-- | Get the default journal file path - either $LEDGER_FILE or $HOME/.hledger.journal file.+--+-- This looks for the LEDGER_FILE environment variable, like Ledger.+-- The value should be a file path, possibly with ~ at the start meaning the current user's home directory.+-- Or the value can be a glob pattern (containing *, ?, [ or {) ), in which case the first matching file path is used.+-- When it's a glob pattern that matches no existing files, an error is raised.+--+-- If LEDGER_FILE is unset or set to the empty string, this returns a default file path:+-- @.hledger.journal@ in the user's home directory,+-- or if we can't find the user's home directory, in the current directory.+--+-- The referenced file can be nonexistent.+-- defaultJournalPath :: IO String defaultJournalPath = do-  s <- envJournalPath-  if null s then defaultJournalPath else return s-    where-      envJournalPath =-        getEnv journalEnvVar-         `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2-                                            `C.catch` (\(_::C.IOException) -> return ""))-      defaultJournalPath = do-                  home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")-                  return $ home </> journalDefaultFilename---- | If a filepath is prefixed by one of the reader names and a colon,--- split that off. Eg "csv:-" -> (Just "csv", "-").-splitReaderPrefix :: PrefixedFilePath -> (Maybe String, FilePath)-splitReaderPrefix f =-  headDef (Nothing, f)-  [(Just r, drop (length r + 1) f) | r <- readerNames, (r++":") `isPrefixOf` f]---- | If the specified journal file does not exist (and is not "-"),--- give a helpful error and quit.-requireJournalFileExists :: FilePath -> IO ()-requireJournalFileExists "-" = return ()-requireJournalFileExists f = do-  exists <- doesFileExist f-  when (not exists) $ do  -- XXX might not be a journal file-    hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f-    hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"-    hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"-    exitFailure+  p <- getEnv journalEnvVar `C.catch` (\(_::C.IOException) -> return "")+  if null p+  then do+    homedir <- fromMaybe "" <$> getHomeSafe+    let defaultfile = homedir </> journalDefaultFilename+    return defaultfile+  else+    expandPathOrGlob "." p --- | Ensure there is a journal file at the given path, creating an empty one if needed.-ensureJournalFileExists :: FilePath -> IO ()-ensureJournalFileExists f = do-  exists <- doesFileExist f-  when (not exists) $ do-    hPrintf stderr "Creating hledger journal file %s.\n" f-    -- note Hledger.Utils.UTF8.* do no line ending conversion on windows,-    -- we currently require unix line endings on all platforms.-    newJournalContent >>= writeFile f+-- | Like defaultJournalPath, but return an error message instead of raising an error.+defaultJournalPathSafely :: IO (Either String String)+defaultJournalPathSafely = (do+  f <- defaultJournalPath+  return $ Right f+  )+  `C.catches` [+     C.Handler (\(e :: C.ErrorCall)   -> return $ Left $ show e)+    ,C.Handler (\(e :: C.IOException) -> return $ Left $ show e)+    ] --- | Give the content for a new auto-created journal file.-newJournalContent :: IO String-newJournalContent = do-  d <- getCurrentDay-  return $ printf "; journal created %s by hledger\n" (show d)+-- | Like defaultJournalPath, but also checks that the file exists, and raises an error if it doesn't.+defaultExistingJournalPath :: IO String+defaultExistingJournalPath = do+  f <- defaultJournalPath+  requireJournalFileExists f+  return f --- | Read a Journal from the given text trying all readers in turn, or throw an error.-readJournal' :: Text -> IO Journal-readJournal' t = readJournal def Nothing t >>= either error' return+-- | Like defaultExistingJournalPath, but returns an error message instead of raising an error.+defaultExistingJournalPathSafely :: IO (Either String String)+defaultExistingJournalPathSafely = (do+  f <- defaultExistingJournalPath+  return $ Right f+  )+  `C.catches` [+     C.Handler (\(e :: C.ErrorCall)   -> return $ Left $ show e)+    ,C.Handler (\(e :: C.IOException) -> return $ Left $ show e)+    ] --- | @findReader mformat mpath@+-- | @readJournal iopts mfile txt@ ----- Find the reader named by @mformat@, if provided.--- Or, if a file path is provided, find the first reader that handles--- its file extension, if any.-findReader :: Maybe StorageFormat -> Maybe FilePath -> Maybe Reader-findReader Nothing Nothing     = Nothing-findReader (Just fmt) _        = headMay [r | r <- readers, rFormat r == fmt]-findReader Nothing (Just path) =-  case prefix of-    Just fmt -> headMay [r | r <- readers, rFormat r == fmt]-    Nothing  -> headMay [r | r <- readers, ext `elem` rExtensions r]-  where-    (prefix,path') = splitReaderPrefix path-    ext            = drop 1 $ takeExtension path'---- | Read a Journal from each specified file path and combine them into one.--- Or, return the first error message.+-- Read a Journal from some handle, with strict checks if enabled,+-- or return an error message. ----- Combining Journals means concatenating them, basically.--- The parse state resets at the start of each file, which means that--- directives & aliases do not affect subsequent sibling or parent files.--- They do affect included child files though. --- Also the final parse state saved in the Journal does span all files.-readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal)-readJournalFiles iopts =-  (right mconcat1 . sequence <$>) . mapM (readJournalFile iopts)-  where-    mconcat1 :: Monoid t => [t] -> t-    mconcat1 [] = mempty-    mconcat1 x  = foldr1 mappend x+-- The reader (data format) is chosen based on, in this order:+--+-- - a reader name provided in @iopts@+--+-- - a reader prefix in the @mfile@ path+--+-- - a file extension in @mfile@+--+-- If none of these is available, or if the reader name is unrecognised,+-- the journal reader is used.+--+-- If a file path is not provided, "-" is assumed (and may appear in error messages,+-- `files` output etc, where it will be a slight lie: it will mean "not from a file",+-- not necessarily "from standard input".+--+readJournal :: InputOpts -> Maybe FilePath -> Handle -> ExceptT String IO Journal+readJournal iopts@InputOpts{strict_, _defer} mpath hdl = do+  let r :: Reader IO = fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath+  dbg6IO "readJournal: trying reader" (rFormat r)+  j <- rReadFn r iopts (fromMaybe "-" mpath) hdl+  when (strict_ && not _defer) $ liftEither $ journalStrictChecks j+  return j  -- | Read a Journal from this file, or from stdin if the file path is -,--- or return an error message. The file path can have a READER: prefix.+-- with strict checks if enabled, or return an error message.+-- XXX or, calls error if the file does not exist. --+-- (Note strict checks are disabled temporarily here when this is called by readJournalFiles).+-- The file path can have a READER: prefix.+-- -- The reader (data format) to use is determined from (in priority order): -- the @mformat_@ specified in the input options, if any; -- the file path's READER: prefix, if any; -- a recognised file name extension.--- if none of these identify a known reader, all built-in readers are tried in turn.+-- if none of these identify a known reader, the journal reader is used. -- -- The input options can also configure balance assertion checking, automated posting -- generation, a rules file for converting CSV data, etc.-readJournalFile :: InputOpts -> PrefixedFilePath -> IO (Either String Journal)-readJournalFile iopts prefixedfile = do-  let +--+-- If using --new, and if latest-file writing is enabled in input options,+-- and not deferred by readJournalFiles, and after passing strict checks if enabled,+-- a .latest.FILE file will be created/updated (for the main file only, not for included files),+-- to remember the latest transaction date processed.+--+readJournalFile :: InputOpts -> PrefixedFilePath -> ExceptT String IO Journal+readJournalFile iopts@InputOpts{new_, new_save_, _defer} prefixedfile = do+  (j, mlatestdates) <- readJournalFileAndLatestDates iopts prefixedfile+  when (new_ && new_save_ && not _defer) $ liftIO $+    case mlatestdates of+      Nothing                        -> return ()+      Just (LatestDatesForFile f ds) -> saveLatestDates ds f+  return j++-- The implementation of readJournalFile.+-- With --new, it also returns the latest transaction date(s) read from each file.+-- readJournalFiles uses this to update .latest files only after a successful read of all.+readJournalFileAndLatestDates :: InputOpts -> PrefixedFilePath -> ExceptT String IO (Journal, Maybe LatestDatesForFile)+readJournalFileAndLatestDates iopts prefixedfile = do+  let     (mfmt, f) = splitReaderPrefix prefixedfile-    iopts' = iopts{mformat_=firstJust [mfmt, mformat_ iopts]}-  requireJournalFileExists f-  t <- readFileOrStdinPortably f-  ej <- readJournal iopts' (Just f) t-  case ej of-    Left e  -> return $ Left e-    Right j | new_ iopts -> do-      ds <- previousLatestDates f+    iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}+  liftIO $ requireJournalFileExists f+  h <-+    dbg6Msg ("readJournalFile: "++takeFileName f) $+    liftIO $ openFileOrStdin f+    -- <- T.readFile f  -- or without line ending translation, for testing+  j <- readJournal iopts' (Just f) h+  if new_ iopts+    then do+      ds <- liftIO $ previousLatestDates f       let (newj, newds) = journalFilterSinceLatestDates ds j-      when (new_save_ iopts && not (null newds)) $ saveLatestDates newds f-      return $ Right newj-    Right j -> return $ Right j+      return (newj, Just $ LatestDatesForFile f newds)+    else+      return (j, Nothing) +-- | Like readJournalFile, but if the file does not exist, returns an empty journal+-- with the file path set. This is useful for commands like add and import that+-- need to work with a potentially non-existent journal file.+readPossibleJournalFile :: InputOpts -> PrefixedFilePath -> ExceptT String IO Journal+readPossibleJournalFile iopts prefixedfile = do+  let (_, f) = splitReaderPrefix prefixedfile+  if f == "-"+    then readJournalFile iopts prefixedfile+    else do+      exists <- liftIO $ doesFileExist f+      if exists+        then readJournalFile iopts prefixedfile+        else return $ nulljournal{jfiles = [(f, "")]}++-- | Like readJournalFiles, but if the first file does not exist, provides an empty+-- journal with that file path set. Other files must exist as normal.+-- This is useful for commands like add and import that write to the first file,+-- which might not exist yet, while also reading other files for completions etc.+readPossibleJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal+readPossibleJournalFiles iopts pfs = case pfs of+  []     -> return nulljournal+  (f:fs) -> do+    let iopts' = iopts{_defer=True}+    j1 <- readPossibleJournalFile iopts' f+    js <- mapM (readJournalFile iopts') fs+    let combined = journalNumberTransactions $ sconcat (j1 :| js)+    when (strict_ iopts) $ liftEither $ journalStrictChecks combined+    return combined++-- | Read a Journal from each specified file path (using @readJournalFile@)+-- and combine them into one; or return the first error message.+--+-- Combining Journals means concatenating them, basically.+-- The parse state resets at the start of each file, which means that+-- directives & aliases do not affect subsequent sibling or parent files.+-- They do affect included child files though.+-- Also the final parse state saved in the Journal does span all files.+--+-- Strict checks, if enabled, are temporarily deferred until all files are read,+-- to ensure they see the whole journal, and/or to avoid redundant work.+-- (Some checks, like assertions and ordereddates, might still be doing redundant work ?)+--+-- Writing .latest files, if enabled, is also deferred till the end,+-- and is done only if strict checks pass.+--+readJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal+readJournalFiles iopts@InputOpts{strict_, new_, new_save_} prefixedfiles = do+  let iopts' = iopts{_defer=True}+  (j, latestdatesforfiles) <-+    dbg6Msg ("readJournalFiles: "++show prefixedfiles) $+    readJournalFilesAndLatestDates iopts' prefixedfiles+  when strict_ $ liftEither $ journalStrictChecks j+  when (new_ && new_save_) $ liftIO $ saveLatestDatesForFiles latestdatesforfiles+  return j++-- The implementation of readJournalFiles.+-- With --new, it also returns the latest transaction date(s) read in each file+-- (used by the import command).+-- This also renumbers the transactions, ensuring their tindex values are unique;+-- that's also done elsewhere, but some code (accountTransactionsReport) needs it done sooner.+readJournalFilesAndLatestDates :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO (Journal, [LatestDatesForFile])+readJournalFilesAndLatestDates iopts pfs = do+  (js, lastdates) <- unzip <$> mapM (readJournalFileAndLatestDates iopts) pfs+  return (journalNumberTransactions $ maybe def sconcat $ nonEmpty js, catMaybes lastdates)++-- | An easy version of 'readJournal' which assumes default options, and fails in the IO monad.+readJournal' :: Handle -> IO Journal+readJournal' = orDieTrying . readJournal definputopts Nothing++-- | An even easier version of readJournal' which takes a 'Text' instead of a 'Handle'.+readJournal'' :: Text -> IO Journal+readJournal'' = textToHandle >=> readJournal'++-- | An easy version of 'readJournalFile' which assumes default options, and fails+-- in the IO monad.+readJournalFile' :: PrefixedFilePath -> IO Journal+readJournalFile' = orDieTrying . readJournalFile definputopts++-- | An easy version of 'readJournalFiles'' which assumes default options, and fails+-- in the IO monad.+readJournalFiles' :: [PrefixedFilePath] -> IO Journal+readJournalFiles' = orDieTrying . readJournalFiles definputopts++--- ** utilities++-- | Extract ExceptT to the IO monad, failing with an error message if necessary.+orDieTrying :: MonadIO m => ExceptT String m a -> m a+orDieTrying a = either (liftIO . fail) return =<< runExceptT a++-- | If the specified journal file does not exist (and is not "-"), call error with an informative message.+-- (Using "journal file" generically here; it could be in any of hledger's supported formats.)+requireJournalFileExists :: FilePath -> IO ()+requireJournalFileExists "-" = return ()+requireJournalFileExists f = do+  exists <- doesFileExist f+  unless exists $ error' $ unlines+    [ "data file \"" <> f <> "\" was not found."+    ,"Please create it first, eg with \"hledger add\" or a text editor."+    ,"Or, specify an existing data file with -f or $LEDGER_FILE."+    ]++-- | Ensure there is a journal file at the given path, creating an empty one if needed.+-- On Windows, also ensure that the path contains no trailing dots+-- which could cause data loss (see 'isWindowsUnsafeDotPath').+ensureJournalFileExists :: FilePath -> IO ()+ensureJournalFileExists f = do+  when (os=="mingw32" && isWindowsUnsafeDotPath f) $+    error' $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n"+  exists <- doesFileExist f+  unless exists $ do+    hPutStrLn stderr $ "Creating hledger journal file " <> show f+    -- Create parent directories if they don't exist+    let dir = takeDirectory f+    unless (null dir || dir == ".") $+      createDirectoryIfMissing True dir+    -- note Hledger.Utils.UTF8.* do no line ending conversion on windows,+    -- we currently require unix line endings on all platforms.+    newJournalContent >>= T.writeFile f++-- | Does any part of this path contain non-. characters and end with a . ?+-- Such paths are not safe to use on Windows (cf #1056).+isWindowsUnsafeDotPath :: FilePath -> Bool+isWindowsUnsafeDotPath = any (\x -> last x == '.' && any (/='.') x) . splitDirectories++-- | Give the content for a new auto-created journal file.+newJournalContent :: IO Text+newJournalContent = do+  d <- getCurrentDay+  return $ "; journal created " <> T.pack (show d) <> " by hledger\n"+ -- A "LatestDates" is zero or more copies of the same date, -- representing the latest transaction date read from a file, -- and how many transactions there were on that date. type LatestDates = [Day] +-- The path of an input file, and its current "LatestDates".+data LatestDatesForFile = LatestDatesForFile FilePath LatestDates+  deriving Show+ -- | Get all instances of the latest date in an unsorted list of dates. -- Ie, if the latest date appears once, return it in a one-element list, -- if it appears three times (anywhere), return three of it. latestDates :: [Day] -> LatestDates-latestDates = headDef [] . take 1 . group . reverse . sort+latestDates = {-# HLINT ignore "Avoid reverse" #-}+  headDef [] . take 1 . group . reverse . sort --- | Remember that these transaction dates were the latest seen when--- reading this journal file.-saveLatestDates :: LatestDates -> FilePath -> IO () -saveLatestDates dates f = writeFile (latestDatesFileFor f) $ unlines $ map showDate dates+-- | Save the given latest date(s) seen in the given data FILE,+-- in a hidden file named .latest.FILE, creating it if needed.+-- Unless no latest dates are provided, in which case do nothing.+saveLatestDates :: LatestDates -> FilePath -> IO ()+saveLatestDates dates f = when (not $ null dates) $+  T.writeFile (latestDatesFileFor f) $ T.unlines $ map showDate dates --- | What were the latest transaction dates seen the last time this +-- | Save each file's latest dates.+saveLatestDatesForFiles :: [LatestDatesForFile] -> IO ()+saveLatestDatesForFiles = mapM_ (\(LatestDatesForFile f ds) -> saveLatestDates ds f)++-- | What were the latest transaction dates seen the last time this -- journal file was read ? If there were multiple transactions on the -- latest date, that number of dates is returned, otherwise just one.--- Or none if no transactions were read, or if latest dates info is not +-- Or none if no transactions were read, or if latest dates info is not -- available for this file. previousLatestDates :: FilePath -> IO LatestDates previousLatestDates f = do   let latestfile = latestDatesFileFor f   exists <- doesFileExist latestfile-  if exists-  then map (parsedate . strip) . lines . strip . T.unpack <$> readFileStrictly latestfile-  else return []+  t <- if exists then readFileStrictly latestfile else return T.empty+  let nls = zip [1::Int ..] $ T.lines t+  fmap catMaybes $ forM nls $ \(n,l) -> do+    let s = T.unpack $ T.strip l+    case (s, parsedate s) of+      ("", _)       -> return Nothing+      (_,  Nothing) -> error' (printf "%s:%d: invalid date: \"%s\"" latestfile n s)+      (_,  Just d)  -> return $ Just d  -- | Where to save latest transaction dates for the given file path. -- (.latest.FILE)@@ -243,9 +518,6 @@   where     (dir, fname) = splitFileName f -readFileStrictly :: FilePath -> IO Text-readFileStrictly f = readFilePortably f >>= \t -> C.evaluate (T.length t) >> return t- -- | Given zero or more latest dates (all the same, representing the -- latest previously seen transaction date, and how many transactions -- were seen on that date), remove transactions with earlier dates@@ -262,82 +534,11 @@     j'                    = j{jtxns=newsamedatets++laterts}     ds'                   = latestDates $ map tdate $ samedatets++laterts --- | @readJournal iopts mfile txt@------ Read a Journal from some text, or return an error message.------ The reader (data format) is chosen based on a recognised file name extension in @mfile@ (if provided).--- If it does not identify a known reader, all built-in readers are tried in turn--- (returning the first one's error message if none of them succeed).------ Input ioptions (@iopts@) specify CSV conversion rules file to help convert CSV data,--- enable or disable balance assertion checking and automated posting generation.----readJournal :: InputOpts -> Maybe FilePath -> Text -> IO (Either String Journal)-readJournal iopts mfile txt =-  tryReaders iopts mfile specifiedorallreaders txt-  where-    specifiedorallreaders = maybe stablereaders (:[]) $ findReader (mformat_ iopts) mfile-    stablereaders = filter (not.rExperimental) readers---- | @tryReaders iopts readers path t@------ Try to parse the given text to a Journal using each reader in turn,--- returning the first success, or if all of them fail, the first error message.---    --- Input ioptions (@iopts@) specify CSV conversion rules file to help convert CSV data,--- enable or disable balance assertion checking and automated posting generation.----tryReaders :: InputOpts -> Maybe FilePath -> [Reader] -> Text -> IO (Either String Journal)-tryReaders iopts mpath readers txt = firstSuccessOrFirstError [] readers-  where-    firstSuccessOrFirstError :: [String] -> [Reader] -> IO (Either String Journal)-    firstSuccessOrFirstError [] []        = return $ Left "no readers found"-    firstSuccessOrFirstError errs (r:rs) = do-      dbg1IO "trying reader" (rFormat r)-      result <- (runExceptT . (rParser r) iopts path) txt-      dbg1IO "reader result" $ either id show result-      case result of Right j -> return $ Right j                        -- success!-                     Left e  -> firstSuccessOrFirstError (errs++[e]) rs -- keep trying-    firstSuccessOrFirstError (e:_) []    = return $ Left e              -- none left, return first error-    path = fromMaybe "(string)" mpath---------- tests+--- ** tests -tests_Read = tests "Read" [+tests_Read = testGroup "Read" [    tests_Common   ,tests_CsvReader   ,tests_JournalReader+  ,tests_RulesReader   ]----samplejournal = readJournal' $ T.unlines--- ["2008/01/01 income"--- ,"    assets:bank:checking  $1"--- ,"    income:salary"--- ,""--- ,"comment"--- ,"multi line comment here"--- ,"for testing purposes"--- ,"end comment"--- ,""--- ,"2008/06/01 gift"--- ,"    assets:bank:checking  $1"--- ,"    income:gifts"--- ,""--- ,"2008/06/02 save"--- ,"    assets:bank:saving  $1"--- ,"    assets:bank:checking"--- ,""--- ,"2008/06/03 * eat & shop"--- ,"    expenses:food      $1"--- ,"    expenses:supplies  $1"--- ,"    assets:cash"--- ,""--- ,"2008/12/31 * pay off"--- ,"    liabilities:debts  $1"--- ,"    assets:bank:checking"--- ]-
Hledger/Read/Common.hs view
@@ -1,1366 +1,1759 @@---- * doc--- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,--- (add-hook 'haskell-mode-hook---   (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))---   'orgstruct-mode)--- and press TAB on nodes to expand/collapse.--{-|--Some common parsers and helpers used by several readers.-Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.---}----- * module-{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections, OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PackageImports #-}--module Hledger.Read.Common (-  Reader (..),-  InputOpts (..),-  definputopts,-  rawOptsToInputOpts,--  -- * parsing utilities-  runTextParser,-  rtp,-  runJournalParser,-  rjp,-  runErroringJournalParser,-  rejp,-  genericSourcePos,-  journalSourcePos,-  parseAndFinaliseJournal,-  parseAndFinaliseJournal',-  setYear,-  getYear,-  setDefaultCommodityAndStyle,-  getDefaultCommodityAndStyle,-  getDefaultAmountStyle,-  getAmountStyle,-  addDeclaredAccountType,-  pushParentAccount,-  popParentAccount,-  getParentAccount,-  addAccountAlias,-  getAccountAliases,-  clearAccountAliases,-  journalAddFile,--  -- * parsers-  -- ** transaction bits-  statusp,-  codep,-  descriptionp,--  -- ** dates-  datep,-  datetimep,-  secondarydatep,--  -- ** account names-  modifiedaccountnamep,-  accountnamep,--  -- ** amounts-  spaceandamountormissingp,-  amountp,-  amountp',-  mamountp',-  commoditysymbolp,-  priceamountp,-  balanceassertionp,-  fixedlotpricep,-  numberp,-  fromRawNumber,-  rawnumberp,--  -- ** comments-  multilinecommentp,-  emptyorcommentlinep,--  followingcommentp,-  transactioncommentp,-  postingcommentp,--  -- ** bracketed dates-  bracketeddatetagsp,--  -- ** misc-  singlespacedtextp,-  singlespacedtextsatisfyingp,-  singlespacep,--  -- * tests-  tests_Common,-)-where---- * imports-import Prelude ()-import "base-compat-batteries" Prelude.Compat hiding (readFile)-import "base-compat-batteries" Control.Monad.Compat-import Control.Monad.Except (ExceptT(..), runExceptT, throwError)-import Control.Monad.State.Strict-import Data.Bifunctor (bimap, second)-import Data.Char-import Data.Data-import Data.Decimal (DecimalRaw (Decimal), Decimal)-import Data.Default-import Data.Functor.Identity-import "base-compat-batteries" Data.List.Compat-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe-import qualified Data.Map as M-import qualified Data.Semigroup as Sem-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar-import Data.Time.LocalTime-import System.Time (getClockTime)-import Text.Megaparsec-import Text.Megaparsec.Char-import Text.Megaparsec.Char.Lexer (decimal)-import Text.Megaparsec.Custom--import Hledger.Data-import Hledger.Utils---- $setup--- >>> :set -XOverloadedStrings---- | A hledger journal reader is a triple of storage format name, a--- detector of that format, and a parser from that format to Journal.-data Reader = Reader {--     -- The canonical name of the format handled by this reader-     rFormat   :: StorageFormat--     -- The file extensions recognised as containing this format-    ,rExtensions :: [String]--     -- A text parser for this format, accepting input options, file-     -- path for error messages and file contents, producing an exception-raising IO-     -- action that returns a journal or error message.-    ,rParser   :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal--     -- Experimental readers are never tried automatically.-    ,rExperimental :: Bool-    }--instance Show Reader where show r = rFormat r ++ " reader"---- $setup---- | Various options to use when reading journal files.--- Similar to CliOptions.inputflags, simplifies the journal-reading functions.-data InputOpts = InputOpts {-     -- files_             :: [FilePath]-     mformat_           :: Maybe StorageFormat  -- ^ a file/storage format to try, unless overridden-                                                --   by a filename prefix. Nothing means try all.-    ,mrules_file_       :: Maybe FilePath       -- ^ a conversion rules file to use (when reading CSV)-    ,separator_         :: Char                 -- ^ the separator to use (when reading CSV)-    ,aliases_           :: [String]             -- ^ account name aliases to apply-    ,anon_              :: Bool                 -- ^ do light anonymisation/obfuscation of the data -    ,ignore_assertions_ :: Bool                 -- ^ don't check balance assertions-    ,new_               :: Bool                 -- ^ read only new transactions since this file was last read-    ,new_save_          :: Bool                 -- ^ save latest new transactions state for next time-    ,pivot_             :: String               -- ^ use the given field's value as the account name -    ,auto_              :: Bool                 -- ^ generate automatic postings when journal is parsed     - } deriving (Show, Data) --, Typeable)--instance Default InputOpts where def = definputopts--definputopts :: InputOpts-definputopts = InputOpts def def ',' def def def def True def def--rawOptsToInputOpts :: RawOpts -> InputOpts-rawOptsToInputOpts rawopts = InputOpts{-   -- files_             = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts-   mformat_           = Nothing-  ,mrules_file_       = maybestringopt "rules-file" rawopts-  ,separator_         = fromMaybe ',' (maybecharopt "separator" rawopts)-  ,aliases_           = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts-  ,anon_              = boolopt "anon" rawopts-  ,ignore_assertions_ = boolopt "ignore-assertions" rawopts-  ,new_               = boolopt "new" rawopts-  ,new_save_          = True-  ,pivot_             = stringopt "pivot" rawopts-  ,auto_              = boolopt "auto" rawopts                        -  }----- * parsing utilities---- | Run a text parser in the identity monad. See also: parseWithState.-runTextParser, rtp-  :: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a-runTextParser p t =  runParser p "" t-rtp = runTextParser---- | Run a journal parser in some monad. See also: parseWithState.-runJournalParser, rjp-  :: Monad m-  => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a)-runJournalParser p t = runParserT (evalStateT p mempty) "" t-rjp = runJournalParser---- | Run an erroring journal parser in some monad. See also: parseWithState.-runErroringJournalParser, rejp-  :: Monad m-  => ErroringJournalParser m a-  -> Text-  -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a))-runErroringJournalParser p t =-  runExceptT $ runParserT (evalStateT p mempty) "" t-rejp = runErroringJournalParser--genericSourcePos :: SourcePos -> GenericSourcePos-genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)---- | Construct a generic start & end line parse position from start and end megaparsec SourcePos's. -journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos-journalSourcePos p p' = JournalSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p, fromIntegral $ line')-    where line'-            | (unPos $ sourceColumn p') == 1 = unPos (sourceLine p') - 1-            | otherwise = unPos $ sourceLine p' -- might be at end of file withat last new-line----- | Given a megaparsec ParsedJournal parser, input options, file--- path and file content: parse and post-process a Journal, or give an error.-parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts-                           -> FilePath -> Text -> ExceptT String IO Journal-parseAndFinaliseJournal parser iopts f txt = do-  t <- liftIO getClockTime-  y <- liftIO getCurrentYear-  let initJournal = nulljournal-        { jparsedefaultyear = Just y-        , jincludefilestack = [f] }-  eep <- liftIO $ runExceptT $-    runParserT (evalStateT parser initJournal) f txt-  case eep of-    Left finalParseError ->-      throwError $ finalErrorBundlePretty $ attachSource f txt finalParseError--    Right ep -> case ep of-      Left e -> throwError $ customErrorBundlePretty e--      Right pj ->-        -- If we are using automated transactions, we finalize twice:-        -- once before and once after. However, if we are running it-        -- twice, we don't check assertions the first time (they might-        -- be false pending modifiers) and we don't reorder the second-        -- time. If we are only running once, we reorder and follow-        -- the options for checking assertions.-        let fj = if auto_ iopts && (not . null . jtxnmodifiers) pj--                 -- transaction modifiers are active-                 then-                   -- first pass, doing most of the work-                     (-                      (journalModifyTransactions <$>) $  -- add auto postings after balancing ? #893b fails-                      journalBalanceTransactions False $-                      -- journalModifyTransactions <$>   -- add auto postings before balancing ? probably #893a, #928, #938 fail-                      journalReverse $-                      journalAddFile (f, txt) $-                      journalApplyCommodityStyles pj)-                   -- second pass, checking balance assertions-                   >>= (\j ->-                      journalBalanceTransactions (not $ ignore_assertions_ iopts) $-                      journalSetLastReadTime t $-                      j)--                 -- transaction modifiers are not active-                 else journalBalanceTransactions (not $ ignore_assertions_ iopts) $-                      journalReverse $-                      journalAddFile (f, txt) $-                      journalApplyCommodityStyles $-                      journalSetLastReadTime t $-                      pj-        in-          case fj of-            Right j -> return j-            Left e  -> throwError e---- Like parseAndFinaliseJournal but takes a (non-Erroring) JournalParser.--- Used for timeclock/timedot. XXX let them use parseAndFinaliseJournal instead-parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts-                           -> FilePath -> Text -> ExceptT String IO Journal-parseAndFinaliseJournal' parser iopts f txt = do-  t <- liftIO getClockTime-  y <- liftIO getCurrentYear-  let initJournal = nulljournal-        { jparsedefaultyear = Just y-        , jincludefilestack = [f] }-  ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt-  case ep of-    Left e   -> throwError $ customErrorBundlePretty e--    Right pj ->-      -- If we are using automated transactions, we finalize twice:-      -- once before and once after. However, if we are running it-      -- twice, we don't check assertions the first time (they might-      -- be false pending modifiers) and we don't reorder the second-      -- time. If we are only running once, we reorder and follow the-      -- options for checking assertions.-      let fj = if auto_ iopts && (not . null . jtxnmodifiers) pj-               then journalModifyTransactions <$>-                    (journalBalanceTransactions False $-                     journalReverse $-                     journalApplyCommodityStyles pj) >>=-                    (\j -> journalBalanceTransactions (not $ ignore_assertions_ iopts) $-                           journalAddFile (f, txt) $-                           journalSetLastReadTime t $-                           j)-               else journalBalanceTransactions (not $ ignore_assertions_ iopts) $-                    journalReverse $-                    journalAddFile (f, txt) $-                    journalApplyCommodityStyles $-                    journalSetLastReadTime t $-                    pj-      in-        case fj of-          Right j -> return j-          Left e  -> throwError e--setYear :: Year -> JournalParser m ()-setYear y = modify' (\j -> j{jparsedefaultyear=Just y})--getYear :: JournalParser m (Maybe Year)-getYear = fmap jparsedefaultyear get--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---- | Lookup currency-specific amount style.------ Returns 'AmountStyle' used in commodity directive within current journal--- prior to current position or in its parents files.-getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle)-getAmountStyle commodity = do-    specificStyle <-  maybe Nothing cformat . M.lookup commodity . jcommodities <$> get-    defaultStyle <- fmap snd <$> getDefaultCommodityAndStyle-    let effectiveStyle = listToMaybe $ catMaybes [specificStyle, defaultStyle]-    return effectiveStyle--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@Journal{..}) -> 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----- * parsers----- ** transaction bits--statusp :: TextParser m Status-statusp =-  choice'-    [ skipMany spacenonewline >> char '*' >> return Cleared-    , skipMany spacenonewline >> char '!' >> return Pending-    , return Unmarked-    ]--codep :: TextParser m Text-codep = option "" $ do-  try $ do-    skipSome spacenonewline-    char '('-  code <- takeWhileP Nothing $ \c -> c /= ')' && c /= '\n'-  char ')' <?> "closing bracket ')' for transaction code"-  pure code--descriptionp :: TextParser m Text-descriptionp = takeWhileP Nothing (not . semicolonOrNewline)-  where semicolonOrNewline c = c == ';' || c == '\n'----- ** dates---- | Parse a date in YYYY/MM/DD format.--- Hyphen (-) 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 <- decimal <?> "year or month"-  sep <- satisfy isDateSepChar <?> "date separator"-  d2 <- decimal <?> "month or day"-  fullDate startOffset d1 sep d2 <|> partialDate startOffset mYear d1 sep d2-  <?> "full or partial date"--  where--  fullDate :: Int -> Integer -> Char -> Int -> 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 $-      "invalid date (mixing date separators is not allowed): " ++ dateStr--    case fromGregorianValid year month day of-      Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-                   "well-formed but invalid date: " ++ dateStr-      Just date -> pure $! date--  partialDate-    :: Int -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day-  partialDate startOffset mYear month sep day = do-    endOffset <- getOffset-    case mYear of-      Just year ->-        case fromGregorianValid year (fromIntegral month) day of-          Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-                      "well-formed but invalid date: " ++ dateStr-          Just date -> pure $! date-        where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day--      Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $-        "partial date "++dateStr++" found, but the current year is unknown"-        where dateStr = show month ++ [sep] ++ show day--{-# INLINABLE datep' #-}---- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.--- Hyphen (-) 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-  skipSome spacenonewline-  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----- ** 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).-modifiedaccountnamep :: JournalParser m AccountName-modifiedaccountnamep = do-  parent <- getParentAccount-  aliases <- getAccountAliases-  a <- lift accountnamep-  return $!-    accountNameApplyAliases aliases $-     -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference-    joinAccountNames parent-    a---- | 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 = singlespacedtextp----- | Parse any text beginning with a non-whitespace character, until a--- double space or the end of input.-singlespacedtextp :: TextParser m T.Text-singlespacedtextp = singlespacedtextsatisfyingp (const True)---- | Similar to 'singlespacedtextp', except that the text must only contain--- characters satisfying the given predicate.-singlespacedtextsatisfyingp :: (Char -> Bool) -> TextParser m T.Text-singlespacedtextsatisfyingp pred = do-  firstPart <- partp-  otherParts <- many $ try $ singlespacep *> partp-  pure $! T.unwords $ firstPart : otherParts-  where-    partp = takeWhile1P Nothing (\c -> pred c && not (isSpace c))---- | Parse one non-newline whitespace character that is not followed by another one.-singlespacep :: TextParser m ()-singlespacep = void spacenonewline *> notFollowedBy spacenonewline----- ** amounts---- | Parse whitespace then an amount, with an optional left or right--- currency symbol and optional price, or return the special--- "missing" marker amount.-spaceandamountormissingp :: JournalParser m MixedAmount-spaceandamountormissingp =-  option missingmixedamt $ try $ do-    lift $ skipSome spacenonewline-    Mixed . (:[]) <$> amountp---- | Parse a single-commodity amount, with optional symbol on the left or--- right, optional unit or total price, and optional (ignored)--- ledger-style balance assertion or fixed lot price declaration.-amountp :: JournalParser m Amount-amountp = label "amount" $ do-  amount <- amountwithoutpricep-  lift $ skipMany spacenonewline-  price <- priceamountp-  pure $ amount { aprice = price }--amountwithoutpricep :: JournalParser m Amount-amountwithoutpricep = do-  (mult, sign) <- lift $ (,) <$> multiplierp <*> signp-  leftsymbolamountp mult sign <|> rightornosymbolamountp mult sign--  where--  leftsymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount-  leftsymbolamountp mult sign = label "amount" $ do-    c <- lift commoditysymbolp-    suggestedStyle <- getAmountStyle c-    commodityspaced <- lift $ skipMany' spacenonewline-    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), aismultiplier=mult, astyle=s, aprice=NoPrice}--  rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount-  rightornosymbolamountp mult sign = label "amount" $ do-    offBeforeNum <- getOffset-    ambiguousRawNum <- lift rawnumberp-    mExponent <- lift $ optional $ try exponentp-    offAfterNum <- getOffset-    let numRegion = (offBeforeNum, offAfterNum)-    mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp-    case mSpaceAndCommodity of-      -- right symbol amount-      Just (commodityspaced, c) -> do-        suggestedStyle <- getAmountStyle c-        (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent-        let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}-        return $ nullamt{acommodity=c, aquantity=sign q, aismultiplier=mult, astyle=s, aprice=NoPrice}-      -- no symbol amount-      Nothing -> do-        suggestedStyle <- getDefaultAmountStyle-        (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle 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, aismultiplier=mult, astyle=s, aprice=NoPrice}--  -- 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 Int-    -> TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)-  interpretNumber posRegion suggestedStyle ambiguousNum mExp =-    let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum-    in  case fromRawNumber rawNum mExp of-          Left errMsg -> customFailure $-                           uncurry parseErrorAtRegion posRegion errMsg-          Right res -> pure res---- | Parse an amount from a string, or get an error.-amountp' :: String -> Amount-amountp' s =-  case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of-    Right amt -> amt-    Left err  -> error' $ show err -- XXX should throwError---- | Parse a mixed amount from a string, or get an error.-mamountp' :: String -> MixedAmount-mamountp' = Mixed . (:[]) . amountp'--signp :: Num a => TextParser m (a -> a)-signp = char '-' *> pure negate <|> char '+' *> pure id <|> pure id--multiplierp :: TextParser m Bool-multiplierp = option False $ char '*' *> pure True---- | This is like skipMany but it returns True if at least one element--- was skipped. This is helpful if you’re just using many to check if--- the resulting list is empty or not.-skipMany' :: MonadPlus m => m a -> m Bool-skipMany' p = go False-  where-    go !isNull = do-      more <- option False (True <$ p)-      if more-        then go True-        else pure isNull--commoditysymbolp :: TextParser m CommoditySymbol-commoditysymbolp =-  quotedcommoditysymbolp <|> simplecommoditysymbolp <?> "commodity symbol"--quotedcommoditysymbolp :: TextParser m CommoditySymbol-quotedcommoditysymbolp =-  between (char '"') (char '"') $ takeWhile1P Nothing f-  where f c = c /= ';' && c /= '\n' && c /= '\"'--simplecommoditysymbolp :: TextParser m CommoditySymbol-simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)--priceamountp :: JournalParser m Price-priceamountp = option NoPrice $ do-  char '@'-  priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice--  lift (skipMany spacenonewline)-  priceAmount <- amountwithoutpricep <?> "unpriced amount (specifying a price)"--  pure $ priceConstructor priceAmount--balanceassertionp :: JournalParser m BalanceAssertion-balanceassertionp = do-  sourcepos <- genericSourcePos <$> lift getSourcePos-  char '='-  istotal <- fmap isJust $ optional $ try $ char '='-  isinclusive <- fmap isJust $ optional $ try $ char '*'-  lift (skipMany spacenonewline)-  -- this amount can have a price; balance assertions ignore it,-  -- but balance assignments will use it-  a <- amountp <?> "amount (for a balance assertion or assignment)"-  return BalanceAssertion-    { baamount    = a-    , batotal     = istotal-    , bainclusive = isinclusive-    , baposition  = sourcepos-    }---- Parse a Ledger-style fixed lot price: {=PRICE}--- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .--- Currently we ignore these (hledger's @ PRICE is equivalent),--- and we don't parse a Ledger-style {PRICE} (equivalent to Ledger's @ PRICE).-fixedlotpricep :: JournalParser m (Maybe Amount)-fixedlotpricep = optional $ do-  try $ do-    lift (skipMany spacenonewline)-    char '{'-  lift (skipMany spacenonewline)-  char '='-  lift (skipMany spacenonewline)-  a <- amountwithoutpricep <?> "unpriced amount (for an ignored ledger-style fixed lot price)"-  lift (skipMany spacenonewline)-  char '}'-  return a---- | 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 point, 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 point), the decimal point character used if any,--- and the digit group style if any.----numberp :: Maybe AmountStyle -> TextParser m (Quantity, Int, 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-    dbg8 "numberp suggestedStyle" suggestedStyle `seq` return ()-    case dbg8 "numberp quantity,precision,mdecimalpoint,mgrps"-           $ fromRawNumber rawNum mExp of-      Left errMsg -> fail errMsg-      Right (q, p, d, g) -> pure (sign q, p, d, g)--exponentp :: TextParser m Int-exponentp = char' 'e' *> signp <*> decimal <?> "exponent"---- | Interpret a raw number as a decimal number.------ Returns:--- - the decimal number--- - the precision (number of digits after the decimal point)  --- - the decimal point character, if any--- - the digit group style, if any (digit group character and sizes of digit groups)-fromRawNumber-  :: RawNumber-  -> Maybe Int-  -> Either String-            (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)-fromRawNumber raw mExp = case raw of--  NoSeparators digitGrp mDecimals ->-    let mDecPt = fmap fst mDecimals-        decimalGrp = maybe mempty snd mDecimals--        (quantity, precision) =-          maybe id applyExp mExp $ toQuantity digitGrp decimalGrp--    in  Right (quantity, precision, mDecPt, Nothing)--  WithSeparators digitSep digitGrps mDecimals -> case mExp of-    Nothing -> -      let mDecPt = fmap fst mDecimals-          decimalGrp = maybe mempty snd mDecimals-          digitGroupStyle = DigitGroups digitSep (groupSizes digitGrps)--          (quantity, precision) = toQuantity (mconcat digitGrps) decimalGrp--      in  Right (quantity, precision, mDecPt, Just digitGroupStyle)-    Just _ -> Left-      "invalid number: mixing digit separators with exponents is not allowed"--  where-    -- Outputs digit group sizes from least significant to most significant-    groupSizes :: [DigitGrp] -> [Int]-    groupSizes digitGrps = reverse $ case map digitGroupLength digitGrps of-      (a:b:cs) | a < b -> b:cs-      gs               -> gs--    toQuantity :: DigitGrp -> DigitGrp -> (Quantity, Int)-    toQuantity preDecimalGrp postDecimalGrp = (quantity, precision)-      where-        quantity = Decimal (fromIntegral precision)-                           (digitGroupNumber $ preDecimalGrp <> postDecimalGrp)-        precision = digitGroupLength postDecimalGrp--    applyExp :: Int -> (Decimal, Int) -> (Decimal, Int)-    applyExp exponent (quantity, precision) =-      (quantity * 10^^exponent, max 0 (precision - exponent))---disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber-disambiguateNumber suggestedStyle (AmbiguousNumber grp1 sep grp2) =-  -- If present, use the suggested style to disambiguate;-  -- otherwise, assume that the separator is a decimal point where possible.-  if isDecimalPointChar sep &&-     maybe True (sep `isValidDecimalBy`) suggestedStyle-  then NoSeparators grp1 (Just (sep, grp2))-  else WithSeparators sep [grp1, grp2] Nothing-  where-    isValidDecimalBy :: Char -> AmountStyle -> Bool-    isValidDecimalBy c = \case-      AmountStyle{asdecimalpoint = Just d} -> d == c-      AmountStyle{asdigitgroups = Just (DigitGroups g _)} -> g /= c-      AmountStyle{asprecision = 0} -> False-      _ -> True---- | Parse and interpret the structure of a number without external hints.--- Numbers are digit strings, possibly separated into digit groups by one--- of two types of separators. (1) Numbers may optionally have a decimal--- point, which may be either a period or comma. (2) Numbers may--- optionally contain digit group separators, which must all be either a--- period, a comma, or a space.------ It is our task to deduce the identities of the decimal point and digit--- separator characters, based on the allowed syntax. For instance, we--- make use of the fact that a decimal point can occur at most once and--- must succeed all digit group separators.------ >>> parseTest rawnumberp "1,234,567.89"--- Right (WithSeparators ',' ["1","234","567"] (Just ('.',"89")))--- >>> parseTest rawnumberp "1,000"--- Left (AmbiguousNumber "1" ',' "000")--- >>> parseTest rawnumberp "1 000"--- Right (WithSeparators ' ' ["1","000"] Nothing)----rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)-rawnumberp = label "number" $ do-  rawNumber <- fmap Right leadingDecimalPt <|> leadingDigits--  -- Guard against mistyped numbers-  mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalPointChar-  when (isJust mExtraDecimalSep) $-    fail "invalid number (invalid use of separator)"--  mExtraFragment <- optional $ lookAhead $ try $-    char ' ' *> getOffset <* digitChar-  case mExtraFragment of-    Just off -> customFailure $-                  parseErrorAt off "invalid number (excessive trailing digits)"-    Nothing -> pure ()--  return $ dbg8 "rawnumberp" rawNumber-  where--  leadingDecimalPt :: TextParser m RawNumber-  leadingDecimalPt = do-    decPt <- satisfy isDecimalPointChar-    decGrp <- digitgroupp-    pure $ NoSeparators mempty (Just (decPt, decGrp))--  leadingDigits :: TextParser m (Either AmbiguousNumber RawNumber)-  leadingDigits = do-    grp1 <- digitgroupp-    withSeparators grp1 <|> fmap Right (trailingDecimalPt grp1)-                        <|> pure (Right $ NoSeparators grp1 Nothing)--  withSeparators :: DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)-  withSeparators grp1 = do-    (sep, grp2) <- try $ (,) <$> satisfy isDigitSeparatorChar <*> digitgroupp-    grps <- many $ try $ char sep *> digitgroupp--    let digitGroups = grp1 : grp2 : grps-    fmap Right (withDecimalPt sep digitGroups)-      <|> pure (withoutDecimalPt grp1 sep grp2 grps)--  withDecimalPt :: Char -> [DigitGrp] -> TextParser m RawNumber-  withDecimalPt digitSep digitGroups = do-    decPt <- satisfy $ \c -> isDecimalPointChar c && c /= digitSep-    decDigitGrp <- option mempty digitgroupp--    pure $ WithSeparators digitSep digitGroups (Just (decPt, decDigitGrp))--  withoutDecimalPt-    :: DigitGrp-    -> Char-    -> DigitGrp-    -> [DigitGrp]-    -> Either AmbiguousNumber RawNumber-  withoutDecimalPt grp1 sep grp2 grps-    | null grps && isDecimalPointChar sep =-        Left $ AmbiguousNumber grp1 sep grp2-    | otherwise = Right $ WithSeparators sep (grp1:grp2:grps) Nothing--  trailingDecimalPt :: DigitGrp -> TextParser m RawNumber-  trailingDecimalPt grp1 = do-    decPt <- satisfy isDecimalPointChar-    pure $ NoSeparators grp1 (Just (decPt, mempty))---isDecimalPointChar :: Char -> Bool-isDecimalPointChar c = c == '.' || c == ','--isDigitSeparatorChar :: Char -> Bool-isDigitSeparatorChar c = isDecimalPointChar c || c == ' '---data DigitGrp = DigitGrp {-  digitGroupLength :: !Int,-  digitGroupNumber :: !Integer-} deriving (Eq)--instance Show DigitGrp where-  show (DigitGrp len num)-    | len > 0 = "\"" ++ padding ++ numStr ++ "\""-    | otherwise = "\"\""-    where numStr = show num-          padding = replicate (len - length numStr) '0'--instance Sem.Semigroup DigitGrp where-  DigitGrp l1 n1 <> DigitGrp l2 n2 = DigitGrp (l1 + l2) (n1 * 10^l2 + n2)--instance Monoid DigitGrp where-  mempty = DigitGrp 0 0-  mappend = (Sem.<>)--digitgroupp :: TextParser m DigitGrp-digitgroupp = label "digits"-            $ makeGroup <$> takeWhile1P (Just "digit") isDigit-  where-    makeGroup = uncurry DigitGrp . foldl' step (0, 0) . T.unpack-    step (!l, !a) c = (l+1, a*10 + fromIntegral (digitToInt c))--data RawNumber-  = NoSeparators   DigitGrp (Maybe (Char, DigitGrp))        -- 100 or 100. or .100 or 100.50-  | WithSeparators Char [DigitGrp] (Maybe (Char, DigitGrp)) -- 1,000,000 or 1,000.50-  deriving (Show, Eq)--data AmbiguousNumber = AmbiguousNumber DigitGrp Char DigitGrp  -- 1,000-  deriving (Show, Eq)----- ** comments--multilinecommentp :: TextParser m ()-multilinecommentp = startComment *> anyLine `skipManyTill` endComment-  where-    startComment = string "comment" *> trailingSpaces-    endComment = eof <|> string "end comment" *> trailingSpaces--    trailingSpaces = skipMany spacenonewline <* newline-    anyLine = void $ takeWhileP Nothing (\c -> c /= '\n') *> newline--{-# INLINABLE multilinecommentp #-}--emptyorcommentlinep :: TextParser m ()-emptyorcommentlinep = do-  skipMany spacenonewline-  skiplinecommentp <|> void newline-  where-    -- A line (file-level) comment can start with a semicolon, hash, or star-    -- (allowing org nodes).-    skiplinecommentp :: TextParser m ()-    skiplinecommentp = do-      satisfy $ \c -> c == ';' || c == '#' || c == '*'-      void $ takeWhileP Nothing (\c -> c /= '\n')-      optional newline-      pure ()--{-# INLINABLE emptyorcommentlinep #-}---- A parser combinator for parsing (possibly multiline) comments--- following journal items.------ Several journal items may be followed by comments, which begin with--- semicolons and extend to the end of the line. Such comments may span--- multiple lines, but comment lines below the journal item must be--- preceeded by leading whitespace.------ This parser combinator accepts a parser that consumes all input up--- until the next newline. This parser should extract the "content" from--- comments. The resulting parser returns this content plus the raw text--- of the comment itself.------ See followingcommentp for tests.----followingcommentp' :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)-followingcommentp' contentp = do-  skipMany spacenonewline-  -- there can be 0 or 1 sameLine-  sameLine <- try headerp *> ((:[]) <$> match' contentp) <|> pure []-  _ <- eolof-  -- there can be 0 or more nextLines-  nextLines <- many $-    try (skipSome spacenonewline *> headerp) *> match' contentp <* eolof-  let-    -- if there's just a next-line comment, insert an empty same-line comment-    -- so the next-line comment doesn't get rendered as a same-line comment.-    sameLine' | null sameLine && not (null nextLines) = [("",mempty)]-              | otherwise = sameLine -    (texts, contents) = unzip $ sameLine' ++ nextLines-    strippedCommentText = T.unlines $ map T.strip texts-    commentContent = mconcat contents-  pure (strippedCommentText, commentContent)--  where-    headerp = char ';' *> skipMany spacenonewline--{-# INLINABLE followingcommentp' #-}---- | Parse the text of a (possibly multiline) comment following a journal item.------ >>> rtp followingcommentp ""   -- no comment--- Right ""--- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added--- Right "\n"--- >>> rtp followingcommentp ";  \n"--- Right "\n"--- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment--- Right "\n\n"--- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.--- Right "\n\n"----followingcommentp :: TextParser m Text-followingcommentp =-  fst <$> followingcommentp' (void $ takeWhileP Nothing (/= '\n'))-{-# INLINABLE followingcommentp #-}----- | Parse a transaction comment and extract its tags.------ The first line of a transaction may be followed by comments, which--- begin with semicolons and extend to the end of the line. Transaction--- comments may span multiple lines, but comment lines below the--- transaction must be preceeded by leading whitespace.------ 2000/1/1 ; a transaction comment starting on the same line ...---   ; extending to the next line---   account1  $1---   account2------ Tags are name-value pairs.------ >>> let getTags (_,tags) = tags--- >>> let parseTags = fmap getTags . rtp transactioncommentp------ >>> parseTags "; name1: val1, name2:all this is value2"--- Right [("name1","val1"),("name2","all this is value2")]------ A tag's name must be immediately followed by a colon, without--- separating whitespace. The corresponding value consists of all the text--- following the colon up until the next colon or newline, stripped of--- leading and trailing whitespace.----transactioncommentp :: TextParser m (Text, [Tag])-transactioncommentp = followingcommentp' commenttagsp-{-# INLINABLE transactioncommentp #-}--commenttagsp :: TextParser m [Tag]-commenttagsp = do-  tagName <- fmap (last . T.split isSpace)-            $ takeWhileP Nothing (\c -> c /= ':' && c /= '\n')-  atColon tagName <|> pure [] -- if not ':', then either '\n' or EOF--  where-    atColon :: Text -> TextParser m [Tag]-    atColon name = char ':' *> do-      if T.null name-        then commenttagsp-        else do-          skipMany spacenonewline-          val <- tagValue-          let tag = (name, val)-          (tag:) <$> commenttagsp--    tagValue :: TextParser m Text-    tagValue = do-      val <- T.strip <$> takeWhileP Nothing (\c -> c /= ',' && c /= '\n')-      _ <- optional $ char ','-      pure val--{-# INLINABLE commenttagsp #-}----- | Parse a posting comment and extract its tags and dates.------ Postings may be followed by comments, which begin with semicolons and--- extend to the end of the line. Posting comments may span multiple--- lines, but comment lines below the posting must be preceeded by--- leading whitespace.------ 2000/1/1---   account1  $1 ; a posting comment starting on the same line ...---   ; extending to the next line------   account2---   ; a posting comment beginning on the next line------ Tags are name-value pairs.------ >>> let getTags (_,tags,_,_) = tags--- >>> let parseTags = fmap getTags . rtp (postingcommentp Nothing)------ >>> parseTags "; name1: val1, name2:all this is value2"--- Right [("name1","val1"),("name2","all this is value2")]------ A tag's name must be immediately followed by a colon, without--- separating whitespace. The corresponding value consists of all the text--- following the colon up until the next colon or newline, stripped of--- leading and trailing whitespace.------ Posting dates may be expressed with "date"/"date2" tags or with--- bracketed date syntax. Posting dates will inherit their year from the--- transaction date if the year is not specified. We throw parse errors on--- invalid dates.------ >>> let getDates (_,_,d1,d2) = (d1, d2)--- >>> let parseDates = fmap getDates . rtp (postingcommentp (Just 2000))------ >>> parseDates "; date: 1/2, date2: 1999/12/31"--- Right (Just 2000-01-02,Just 1999-12-31)--- >>> parseDates "; [1/2=1999/12/31]"--- Right (Just 2000-01-02,Just 1999-12-31)------ Example: tags, date tags, and bracketed dates--- >>> rtp (postingcommentp (Just 2000)) "; a:b, date:3/4, [=5/6]"--- Right ("a:b, date:3/4, [=5/6]\n",[("a","b"),("date","3/4")],Just 2000-03-04,Just 2000-05-06)------ Example: extraction of dates from date tags ignores trailing text--- >>> rtp (postingcommentp (Just 2000)) "; date:3/4=5/6"--- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)----postingcommentp-  :: Maybe Year -> TextParser m (Text, [Tag], Maybe Day, Maybe Day)-postingcommentp mYear = do-  (commentText, (tags, dateTags)) <--    followingcommentp' (commenttagsanddatesp mYear)-  let mdate  = fmap snd $ find ((=="date") .fst) dateTags-      mdate2 = fmap snd $ find ((=="date2").fst) dateTags-  pure (commentText, tags, mdate, mdate2)-{-# INLINABLE postingcommentp #-}---commenttagsanddatesp-  :: Maybe Year -> TextParser m ([Tag], [DateTag])-commenttagsanddatesp mYear = do-  (txt, dateTags) <- match $ readUpTo ':'-  -- next char is either ':' or '\n' (or EOF)-  let tagName = last (T.split isSpace txt)-  (fmap.second) (dateTags++) (atColon tagName) <|> pure ([], dateTags) -- if not ':', then either '\n' or EOF--  where-    readUpTo :: Char -> TextParser m [DateTag]-    readUpTo end = do-      void $ takeWhileP Nothing (\c -> c /= end && c /= '\n' && c /= '[')-      -- if not '[' then ':' or '\n' or EOF-      atBracket (readUpTo end) <|> pure []--    atBracket :: TextParser m [DateTag] -> TextParser m [DateTag]-    atBracket cont = do-      -- Uses the fact that bracketed date-tags cannot contain newlines-      dateTags <- option [] $ lookAhead (bracketeddatetagsp mYear)-      _ <- char '['-      dateTags' <- cont-      pure $ dateTags ++ dateTags'--    atColon :: Text -> TextParser m ([Tag], [DateTag])-    atColon name = char ':' *> do-      skipMany spacenonewline-      (tags, dateTags) <- case name of-        ""      -> pure ([], [])-        "date"  -> dateValue name-        "date2" -> dateValue name-        _       -> tagValue name-      _ <- optional $ char ','-      bimap (tags++) (dateTags++) <$> commenttagsanddatesp mYear--    dateValue :: Text -> TextParser m ([Tag], [DateTag])-    dateValue name = do-      (txt, (date, dateTags)) <- match' $ do-        date <- datep' mYear-        dateTags <- readUpTo ','-        pure (date, dateTags)-      let val = T.strip txt-      pure $ ( [(name, val)]-             , (name, date) : dateTags )--    tagValue :: Text -> TextParser m ([Tag], [DateTag])-    tagValue name = do-      (txt, dateTags) <- match' $ readUpTo ','-      let val = T.strip txt-      pure $ ( [(name, val)]-             , dateTags )--{-# INLINABLE commenttagsanddatesp #-}------ ** bracketed dates---- | Parse Ledger-style bracketed posting dates ([DATE=DATE2]), as--- "date" and/or "date2" tags. Anything that looks like an attempt at--- this (a square-bracketed sequence of 0123456789/-.= containing at--- least one digit and one date separator) is also parsed, and will--- throw an appropriate error.------ The dates are parsed in full here so that errors are reported in--- the right position. A missing year in DATE can be inferred if a--- default date is provided. A missing year in DATE2 will be inferred--- from DATE.------ >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"--- Right [("date",2016-01-02),("date2",2016-03-04)]------ >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"--- Left ...not a bracketed date...------ >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"--- Left ...1:2:...well-formed but invalid date: 2016/1/32...------ >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"--- Left ...1:2:...partial date 1/31 found, but the current year is unknown...------ >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"--- Left ...1:13:...expecting month or day...----bracketeddatetagsp-  :: Maybe Year -> TextParser m [(TagName, Day)]-bracketeddatetagsp mYear1 = do-  -- dbgparse 0 "bracketeddatetagsp"-  try $ do-    s <- lookAhead-       $ between (char '[') (char ']')-       $ takeWhile1P Nothing isBracketedDateChar-    unless (T.any isDigit s && T.any isDateSepChar s) $-      fail "not a bracketed date"-  -- Looks sufficiently like a bracketed date to commit to parsing a date--  between (char '[') (char ']') $ do-    md1 <- optional $ datep' mYear1--    let mYear2 = fmap readYear md1 <|> mYear1-    md2 <- optional $ char '=' *> datep' mYear2--    pure $ catMaybes [("date",) <$> md1, ("date2",) <$> md2]--  where-    readYear = first3 . toGregorian-    isBracketedDateChar c = isDigit c || isDateSepChar c || c == '='--{-# INLINABLE bracketeddatetagsp #-}------ ** helper parsers---- 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)----- * tests--tests_Common = tests "Common" [--   tests "amountp" [-    test "basic"                  $ expectParseEq amountp "$47.18"     (usd 47.18)-   ,test "ends with decimal mark" $ expectParseEq amountp "$1."        (usd 1  `withPrecision` 0)-   ,test "unit price"             $ expectParseEq amountp "$10 @ €0.5" -      -- not precise enough:-      -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'-      amount{-         acommodity="$"-        ,aquantity=10 -- need to test internal precision with roundTo ? I think not -        ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}-        ,aprice=UnitPrice $-          amount{-             acommodity="€"-            ,aquantity=0.5-            ,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'}-            } -        } -   ,test "total price"            $ expectParseEq amountp "$10 @@ €5"-      amount{-         acommodity="$"-        ,aquantity=10 -        ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}-        ,aprice=TotalPrice $-          amount{-             acommodity="€"-            ,aquantity=5-            ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}-            } -        } -    ]--  ,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in-   tests "numberp" [-     test "." $ expectParseEq p "0"          (0, 0, Nothing, Nothing)-    ,test "." $ expectParseEq p "1"          (1, 0, Nothing, Nothing)-    ,test "." $ expectParseEq p "1.1"        (1.1, 1, Just '.', Nothing)-    ,test "." $ expectParseEq p "1,000.1"    (1000.1, 1, Just '.', Just $ DigitGroups ',' [3])-    ,test "." $ expectParseEq p "1.00.000,1" (100000.1, 1, Just ',', Just $ DigitGroups '.' [3,2])-    ,test "." $ expectParseEq p "1,000,000"  (1000000, 0, Nothing, Just $ DigitGroups ',' [3,3])  -- could be simplified to [3]-    ,test "." $ expectParseEq p "1."         (1, 0, Just '.', Nothing)-    ,test "." $ expectParseEq p "1,"         (1, 0, Just ',', Nothing)-    ,test "." $ expectParseEq p ".1"         (0.1, 1, Just '.', Nothing)-    ,test "." $ expectParseEq p ",1"         (0.1, 1, Just ',', Nothing)-    ,test "." $ expectParseError p "" ""-    ,test "." $ expectParseError p "1,000.000,1" ""-    ,test "." $ expectParseError p "1.000,000.1" ""-    ,test "." $ expectParseError p "1,000.000.1" ""-    ,test "." $ expectParseError p "1,,1" ""-    ,test "." $ expectParseError p "1..1" ""-    ,test "." $ expectParseError p ".1," ""-    ,test "." $ expectParseError p ",1." ""-    ]-  -  ,tests "spaceandamountormissingp" [-     test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18])-    ,test "empty string" $ expectParseEq spaceandamountormissingp "" missingmixedamt-    ,_test "just space" $ expectParseEq spaceandamountormissingp " " missingmixedamt  -- XXX should it ?-    -- ,test "just amount" $ expectParseError spaceandamountormissingp "$47.18" ""  -- succeeds, consuming nothing-    ]--  ]+--- * -*- 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        #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Functor law" #-}++--- ** exports+module Hledger.Read.Common (+  Reader (..),+  PrefixedFilePath,+  isStdin,+  InputOpts(..),+  HasInputOpts(..),+  definputopts,+  rawOptsToInputOpts,+  handleReadFnToTextReadFn,++  -- * 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,+  accountnamenosemicolonp,++  -- ** account aliases+  accountaliasp,++  -- ** amounts+  spaceandamountormissingp,+  amountp,+  amountp',+  commoditysymbolp,+  costp,+  balanceassertionp,+  lotcostp,+  numberp,+  fromRawNumber,+  rawnumberp,+  parseamount,+  parseamount',+  parsemixedamount,+  parsemixedamount',++  -- ** comments+  isLineCommentStart,+  isSameLineCommentStart,+  multilinecommentp,+  emptyorcommentlinep,+  emptyorcommentlinep2,+  followingcommentp,+  transactioncommentp,+  commentlinetagsp,+  postingcommentp,++  -- ** bracketed dates+  bracketeddatetagsp,++  -- ** misc+  doublequotedtextp,+  noncommenttextp,+  noncommenttext1p,+  singlespacedtext1p,+  singlespacednoncommenttext1p,+  singlespacedtextsatisfying1p,+  singlespacep,+  skipNonNewlineSpaces,+  skipNonNewlineSpaces1,+  aliasesFromOpts,++  -- * tests+  tests_Common,+)+where++--- ** imports+import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)+import Control.Monad (foldM, join, liftM2, when, unless, (>=>), (<=<))+import Control.Monad.Fail qualified as Fail (fail)+import Control.Monad.Except (ExceptT(..), liftEither, withExceptT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.State.Strict (MonadState, evalStateT, modify', get, put)+import Control.Monad.Trans.Class (lift)+import Data.Bifunctor (bimap, second)+import Data.Char (digitToInt, isDigit, isSpace)+import Data.Decimal (DecimalRaw (Decimal), Decimal)+import Data.Either (rights)+import Data.Function ((&))+import Data.Functor ((<&>), ($>), void)+import Data.List (find, genericReplicate, union)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)+import Data.Map qualified as M+import Data.Semigroup qualified as Sem+import Data.Text (Text, stripEnd)+import Data.Text qualified 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.Directory (canonicalizePath)+import System.FilePath (takeFileName)+import System.IO (Handle)+import Text.Megaparsec+import Text.Megaparsec.Char (char, char', digitChar, newline, string)+import Text.Megaparsec.Char.Lexer (decimal)++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 storage format name,+-- a list of file extensions assumed to be in this format,+-- and an IO action that reads data in this format, returning a Journal.+--+-- The journal parser used by the latter is also stored separately for direct use+-- by the journal reader's includedirectivep to parse included files.+-- The type variable m is needed for this parser.+-- Lately it requires an InputOpts, basically to support --old-timeclock.+data Reader m = Reader {+    -- The canonical name of the format handled by this reader. "journal", "timedot", "csv" etc.+   rFormat :: StorageFormat+    -- The file extensions recognised as containing this format.+  ,rExtensions :: [String]+    -- An IO action for reading this format, producing a journal or an error message.+    -- It accepts input options, a file path to show in error messages, and a handle to read data from.+  ,rReadFn :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+    -- The megaparsec parser called by the above, provided separately for parsing included files.+  ,rParser :: MonadIO m => InputOpts -> ErroringJournalParser m ParsedJournal+  }++instance Show (Reader m) where show r = show (rFormat r) ++ " reader"++-- | A file path optionally prefixed by a reader name and colon (journal:, csv:, timedot:, etc.).+-- The file path part can also be - meaning standard input.+type PrefixedFilePath = FilePath++-- | Is this the special file path meaning standard input ? (-, possibly prefixed)+isStdin :: PrefixedFilePath -> Bool+isStdin f = case splitAtElement ':' f of+  [_,"-"] -> True+  ["-"] -> True+  _ -> False++-- | 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 -> Bool -> Bool -> RawOpts -> InputOpts+rawOptsToInputOpts day usecoloronstdout autopostingtags rawopts =++    let+        -- Allow/disallow implicit-cost conversion transactions, according to policy in Check.md.+        -- Disallow them if we see the --strict flag, or if we see a "balanced" argument with the "check" command,+        -- which we assume means the user is running "hledger check balanced".+        -- XXX #2377 The check was originally named "balancednoautoconversion",+        -- but later it was renamed, so this is no longer good; any command with "balanced"+        -- as an argument will also enable this check, normally enabled only in strict mode.+        noinferbalancingcosts =  -- keep synced with Check.*+             boolopt "strict" rawopts +          || (stringopt "args" rawopts == "balanced" && stringopt "command" rawopts == "check")++        -- 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 usecoloronstdout rawopts+        argsquery = map fst . rights . map (parseQueryTerm day) $ querystring_ ropts+        datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery++        txnbalancingprecision = either err id $ transactionBalancingPrecisionFromOpts rawopts+          where err e = error' $ "could not parse --txn-balancing: '" ++ e ++ "'"  -- PARTIAL:++        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" rawopts+      ,aliases_           = listofstringopt "alias" rawopts+      ,anon_              = boolopt "obfuscate" rawopts+      ,new_               = boolopt "new" rawopts+      ,new_save_          = True+      ,pivot_             = stringopt "pivot" rawopts+      ,forecast_          = forecastPeriodFromRawOpts day rawopts+      ,auto_posting_tags_ = autopostingtags+      ,verbose_tags_      = boolopt "verbose-tags" rawopts+      ,reportspan_        = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> 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_balancing_costs_ = not noinferbalancingcosts+                               , txn_balancing_         = txnbalancingprecision+                               , commodity_styles_      = Just styles+                               }+      ,strict_            = boolopt "strict" rawopts+      ,_ioDay             = day+      ,_oldtimeclock      = boolopt "oldtimeclock" rawopts+      }++handleReadFnToTextReadFn :: (InputOpts -> FilePath -> Text -> ExceptT String IO Journal) -> InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+handleReadFnToTextReadFn p iopts fp =+  p iopts fp <=< lift . hGetContentsPortably Nothing++-- | 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 raw options, return either+-- * if all options were successfully parsed: a map of successfully parsed commodity styles,+-- * if one or more options failed to parse: the first option which 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)++transactionBalancingPrecisionFromOpts :: RawOpts -> Either String TransactionBalancingPrecision+transactionBalancingPrecisionFromOpts rawopts =+  case maybestringopt "txn-balancing" rawopts of+    Nothing      -> Right TBPExact+    Just "old"   -> Right TBPOld+    Just "exact" -> Right TBPExact+    Just s       -> Left $ s<>", should be one of: old, exact"++-- | 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 finalisatison, as in parsing+-- Timeclock and Timedot files.+initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts+                          -> FilePath -> Text -> ExceptT String IO Journal+initialiseAndParseJournal parser iopts f txt = do+    cf <- liftIO $ canonicalizePath f+    prettyParseErrors $ runParserT (evalStateT parser (initJournal cf)) f txt+  where+    y = first3 . toGregorian $ _ioDay iopts+    initJournal cf = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [(f, cf)]}+    -- 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+--  note this 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+--+-- - propagate account tags to postings+--+-- - maybe add forecast transactions+--+-- - propagate account tags to postings (again to affect forecast transactions)+--+-- - maybe add auto postings+--+-- - propagate account tags to postings (again to affect auto postings)+--+-- - evaluate balance assignments and balance each transaction+--+-- - maybe check balance assertions+--+-- - maybe infer costs from equity postings+--+-- - maybe infer equity postings from costs+--+-- - manye infer market prices from costs+--+-- One correctness check (parseable) has already passed when this function is called.+-- Up to four more are performed here:+--+--  - ordereddates (when enabled)+--+--  - assertions (when enabled)+--+--  - autobalanced (and with --strict, balanced ?), in the journalBalanceTransactions step.+--+-- Others (commodities, accounts..) are done later by journalStrictChecks.+--+journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal+journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_,strict_,auto_posting_tags_,verbose_tags_,_ioDay} f txt pj = do+  let+    BalancingOpts{commodity_styles_, ignore_assertions_} = balancingopts_+    fname = "journalFinalise " <> takeFileName f+    lbl = lbl_ fname+    -- Some not so pleasant hacks+    -- We want to know when certain checks have been explicitly requested with the check command,+    -- but it does not run until later. For now, inspect the command line with unsafePerformIO.+    checking checkname = "check" `elem` args && checkname `elem` args where args = progArgs+    -- We will check ordered dates when "check ordereddates" is used.+    checkordereddates = checking "ordereddates"+    -- We will check balance assertions by default, unless -I is used, but always if -s or "check assertions" are used.+    checkassertions = not ignore_assertions_ || strict_ || checking "assertions"++  t <- liftIO getPOSIXTime+  liftEither $+    pj{jglobalcommoditystyles=fromMaybe mempty commodity_styles_}+      &   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+            -- XXX does not see conversion accounts generated by journalInferEquityFromCosts below, requiring a workaround in journalCheckAccounts. Do it later ?+      &   journalStyleAmounts                            -- Infer and apply commodity styles (but don't round) - should be done early+      <&> journalAddForecast verbose_tags_ (forecastPeriod iopts pj)   -- Add forecast transactions if enabled+      <&> (if auto_posting_tags_ then journalPostingsAddAccountTags else id)     -- Maybe propagate account tags to postings+      >>= journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ False   -- Tag equity conversion postings and redundant costs, to help journalBalanceTransactions ignore them.+      >>= (if auto_ && not (null $ jtxnmodifiers pj)+            then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed. Does preliminary transaction balancing.+            else pure)+      -- XXX how to force debug output here ?+       -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns)+       -- >>= \j -> deepseq (concatMap (T.unpack.showTransaction).jtxns $ j) (return j)+      <&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalPostingAmountsDebug)+      >>= (\j -> if checkordereddates then journalCheckOrdereddates j $> j else Right j)  -- check ordereddates before assertions. The outer parentheses are needed.+      >>= (\j -> journalBalanceTransactions balancingopts_{ignore_assertions_=not checkassertions, account_types_ = jaccounttypes j} j)  -- infer balance assignments and missing amounts, and maybe check balance assertions.+      <&> dbg9With (lbl "amounts after transaction-balancing".showJournalPostingAmountsDebug)+      -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalPostingAmountsDebug)+      >>= journalInferCommodityStyles                    -- infer commodity styles once more now that all posting amounts are present+      -- >>= Right . dbg0With (pshow.journalCommodityStyles)+      <&> (if auto_posting_tags_ then journalPostingsAddCommodityTags else id)  -- Maybe propagate commodity tags to postings (after amounts are inferred)+      >>= (if infer_costs_  then journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ True else pure)  -- With --infer-costs, infer costs from equity postings where possible+      <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)          -- With --infer-equity, infer equity postings from costs where possible+      <&> dbg9With (lbl "amounts after equity-inferring".showJournalPostingAmountsDebug)+      <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions+      -- <&> dbg6Msg fname  -- debug logging+      <&> dbgJournalAcctDeclOrder (fname <> ": acct decls           : ")+      <&> journalRenumberAccountDeclarations+      <&> dbgJournalAcctDeclOrder (fname <> ": acct decls renumbered: ")++-- | Apply any auto posting rules to generate extra postings on this journal's transactions.+-- With a true first argument, adds visible tags to generated postings and modified transactions.+journalAddAutoPostings :: Bool -> Day -> BalancingOpts -> Journal -> Either String Journal+journalAddAutoPostings verbosetags 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 verbosetags 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 :: Bool -> Maybe DateSpan -> Journal -> Journal+journalAddForecast _ Nothing j = j+journalAddForecast verbosetags (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns}+  where+    {-# HLINT ignore "Move concatMap out" #-}+    forecasttxns =+        map (txnTieKnot . transactionTransformPostings (styleAmounts $ journalCommodityStyles j))+      . filter (spanContainsDate forecastspan . tdate)+      . concatMap (\pt -> runPeriodicTransaction verbosetags pt forecastspan)+      $ jperiodictxns j++setYear :: Year -> JournalParser m ()+setYear y = modify' (\j -> j{jparsedefaultyear=Just y})++getYear :: JournalParser m (Maybe Year)+getYear = fmap jparsedefaultyear get++dp :: String -> TextParser m ()+dp = const $ return ()  -- no-op+-- dp = dbgparse 0  -- trace parse state at this --debug level++-- | 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{asdecimalmark=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{jdeclaredcommodities} <- get+  let mspecificStyle = M.lookup commodity jdeclaredcommodities >>= 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 d2+    <?> "full or partial date"+  where+    fullDate :: Int -> Year -> Char -> Month -> TextParser m Day+    fullDate startOffset year sep month = do+      sep2 <- satisfy isDateSepChar <?> "date separator"+      day <- decimal <?> "day"+      endOffset <- getOffset+      when (sep /= sep2) $ +        customFailure $ parseErrorAtRegion startOffset endOffset $+          "This date has different separators, please use consistent separators."+      case fromGregorianValid year month day of+        Nothing -> +          customFailure $ parseErrorAtRegion startOffset endOffset $+            "This is not a valid date, please fix it."+        Just date -> pure $! date++    partialDate :: Int -> Maybe Year -> Month -> MonthDay -> TextParser m Day+    partialDate startOffset myr month day = do+      endOffset <- getOffset+      case myr of+        Just year ->+          case fromGregorianValid year month day of+            Nothing -> +              customFailure $ parseErrorAtRegion startOffset endOffset $+                "This is not a valid date, please fix it."+            Just date -> pure $! date++        Nothing ->+          customFailure $ parseErrorAtRegion startOffset endOffset $+            "This partial date can not be parsed because the current year is unknown.\n"+            ++"Please make it a full date, or add a default year directive."++{-# 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 (see accountnamep);+-- 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.+-- The flag says whether account names may include semicolons; currently account names+-- in journal format may, but account names in timeclock/timedot formats may not.+modifiedaccountnamep :: Bool -> JournalParser m AccountName+modifiedaccountnamep allowsemicolon = do+  parent  <- getParentAccount+  als     <- getAccountAliases+  -- off1    <- getOffset+  a       <- lift $ if allowsemicolon then accountnamep else accountnamenosemicolonp+  -- 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.+-- (We should have required them to start with an alphanumeric, but didn't.)+-- Note, this means account names can contain all kinds of punctuation, including ; which usually starts a following comment.+-- Parent parsers usually remove the following comment before using this parser.+accountnamep :: TextParser m AccountName+accountnamep = singlespacedtext1p++-- Like accountnamep, but stops parsing if it reaches a semicolon.+accountnamenosemicolonp :: TextParser m AccountName+accountnamenosemicolonp = singlespacednoncommenttext1p++-- | Parse a single line of possibly empty text enclosed in double quotes.+doublequotedtextp :: TextParser m Text+doublequotedtextp = between (char '"') (char '"') $+  takeWhileP Nothing $ \c -> not $ isNewline c || c == '"'++-- | 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 (aquantity amt) <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces)+  let mcostbasis =+        case (mlotcost, mlotdate, mlotnote) of+          (Nothing, Nothing, Nothing) -> Nothing+          _ -> Just $ CostBasis { cbCost = join mlotcost, cbDate = mlotdate, cbLabel = mlotnote }+  pure $ amt { acost = mcost, acostbasis = mcostbasis }++-- 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 { acost = 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, asdecimalmark=mdec, asdigitgroups=mgrps}+    return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, acost=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, asdecimalmark=mdec, asdigitgroups=mgrps}+        return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=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, asdecimalmark=mdec, asdigitgroups=mgrps})+        return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=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 AmountCost+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 '@'+  totalCost <- 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 totalCost+            then TotalCost priceAmount{aquantity=amtsign * aquantity priceAmount}+            else UnitCost  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}} or {}.+-- If total cost syntax {{}} is used, converts it to unit cost by dividing by the posting quantity.+lotcostp :: Quantity -> JournalParser m (Maybe Amount)+lotcostp postingqty =+  -- dbg "lotcostp" $+  label "ledger-style lot cost" $ do+  char '{'+  doublebrace <- option False $ char '{' >> pure True+  lift skipNonNewlineSpaces+  _fixed <- fmap isJust $ optional $ char '='+  lift skipNonNewlineSpaces+  ma <- optional $ simpleamountp False+  lift skipNonNewlineSpaces+  char '}'+  when (doublebrace) $ void $ char '}'+  pure $ fmap (convertToUnitCost doublebrace) ma+  where+    -- Convert {{TOTALCOST}} to {UNITCOST} by dividing by posting quantity+    convertToUnitCost isTotal lotamt =+      if isTotal && postingqty /= 0+      then lotamt { aquantity = aquantity lotamt / postingqty }+      else lotamt++-- Parse a Ledger-style [LOTDATE].+lotdatep :: JournalParser m Day+lotdatep =+  -- dbg "lotdatep" $+  label "ledger-style lot date" $ do+  char '['+  lift skipNonNewlineSpaces+  d <- datep+  lift skipNonNewlineSpaces+  char ']'+  return d++-- Parse a Ledger-style (LOT NOTE).+lotnotep :: JournalParser m Text+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 note++-- | 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+exponentp = char' 'e' *> signp <*> decimal <?> "exponent"++-- | Interpret a raw number as a decimal number.+--+-- Returns:+-- - the decimal number+-- - the precision (number of digits after the decimal point)+-- - the decimal point character, if any+-- - the digit group style, if any (digit group character and sizes of digit groups)+fromRawNumber+  :: RawNumber+  -> Maybe Integer+  -> Either String+            (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)+fromRawNumber (WithSeparators{}) (Just _) =+    Left "invalid number: digit separators and exponents may not be used together"+fromRawNumber raw mExp = do+    (quantity, precision) <- toQuantity (fromMaybe 0 mExp) (digitGroup raw) (decimalGroup raw)+    return (quantity, precision, mDecPt raw, digitGroupStyle raw)+  where+    toQuantity :: Integer -> DigitGrp -> DigitGrp -> Either String (Quantity, Word8)+    toQuantity e preDecimalGrp postDecimalGrp+      | precision < 0   = Right (Decimal 0 (digitGrpNum * 10^(-precision)), 0)+      | precision < 256 = Right (Decimal precision8 digitGrpNum, precision8)+      | otherwise = Left "invalid number: numbers with more than 255 decimal places are currently not supported"+      where+        digitGrpNum = digitGroupNumber $ preDecimalGrp <> postDecimalGrp+        precision   = toInteger (digitGroupLength postDecimalGrp) - e+        precision8  = fromIntegral precision :: Word8++    mDecPt (NoSeparators _ mDecimals)           = fst <$> mDecimals+    mDecPt (WithSeparators _ _ mDecimals)       = fst <$> mDecimals+    decimalGroup (NoSeparators _ mDecimals)     = maybe mempty snd mDecimals+    decimalGroup (WithSeparators _ _ mDecimals) = maybe mempty snd mDecimals+    digitGroup (NoSeparators digitGrp _)        = digitGrp+    digitGroup (WithSeparators _ digitGrps _)   = mconcat digitGrps+    digitGroupStyle (NoSeparators _ _)          = Nothing+    digitGroupStyle (WithSeparators sep grps _) = Just . DigitGroups sep $ groupSizes grps++    -- Outputs digit group sizes from least significant to most significant+    groupSizes :: [DigitGrp] -> [Word8]+    groupSizes digitGrps = reverse $ case map (fromIntegral . digitGroupLength) digitGrps of+      (a:b:cs) | a < b -> b:cs+      gs               -> gs++disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber+disambiguateNumber msuggestedStyle (AmbiguousNumber grp1 sep grp2) =+  -- If present, use the suggested style to disambiguate;+  -- otherwise, assume that the separator is a decimal point where possible.+  if isDecimalMark sep &&+     maybe True (sep `isValidDecimalBy`) msuggestedStyle+  then NoSeparators grp1 (Just (sep, grp2))+  else WithSeparators sep [grp1, grp2] Nothing+  where+    isValidDecimalBy :: Char -> AmountStyle -> Bool+    isValidDecimalBy c = \case+      AmountStyle{asdecimalmark = Just d} -> d == c+      AmountStyle{asdigitgroups = Just (DigitGroups g _)} -> g /= c+      AmountStyle{asprecision = Precision 0} -> False+      _ -> True++-- | Parse and interpret the structure of a number without external hints.+-- Numbers are digit strings, possibly separated into digit groups by one+-- of two types of separators. (1) Numbers may optionally have a decimal+-- mark, which may be either a period or comma. (2) Numbers may+-- optionally contain digit group marks, which must all be either a+-- period, a comma, or a space.+--+-- It is our task to deduce the characters used as decimal mark and+-- digit group mark, based on the allowed syntax. For instance, we+-- make use of the fact that a decimal mark can occur at most once and+-- must be to the right of all digit group marks.+--+-- >>> parseTest rawnumberp "1,234,567.89"+-- Right (WithSeparators ',' ["1","234","567"] (Just ('.',"89")))+-- >>> parseTest rawnumberp "1,000"+-- Left (AmbiguousNumber "1" ',' "000")+-- >>> parseTest rawnumberp "1 000"+-- Right (WithSeparators ' ' ["1","000"] Nothing)+--+rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)+rawnumberp = label "number" $ do+  rawNumber <- fmap Right leadingDecimalPt <|> leadingDigits++  -- Guard against mistyped numbers+  mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalMark+  when (isJust mExtraDecimalSep) $+    Fail.fail "invalid number (invalid use of separator)"++  mExtraFragment <- optional $ lookAhead $ try $+    char ' ' *> getOffset <* digitChar+  case mExtraFragment of+    Just off -> customFailure $+                  parseErrorAt off "invalid number (excessive trailing digits)"+    Nothing -> pure ()++  return $ dbg7 "rawnumberp" rawNumber+  where++  leadingDecimalPt :: TextParser m RawNumber+  leadingDecimalPt = do+    decPt <- satisfy isDecimalMark+    decGrp <- digitgroupp+    pure $ NoSeparators mempty (Just (decPt, decGrp))++  leadingDigits :: TextParser m (Either AmbiguousNumber RawNumber)+  leadingDigits = do+    grp1 <- digitgroupp+    withSeparators grp1 <|> fmap Right (trailingDecimalPt grp1)+                        <|> pure (Right $ NoSeparators grp1 Nothing)++  withSeparators :: DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)+  withSeparators grp1 = do+    (sep, grp2) <- try $ (,) <$> satisfy isDigitSeparatorChar <*> digitgroupp+    grps <- many $ try $ char sep *> digitgroupp++    let digitGroups = grp1 : grp2 : grps+    fmap Right (withDecimalPt sep digitGroups)+      <|> pure (withoutDecimalPt grp1 sep grp2 grps)++  withDecimalPt :: Char -> [DigitGrp] -> TextParser m RawNumber+  withDecimalPt digitSep digitGroups = do+    decPt <- satisfy $ \c -> isDecimalMark c && c /= digitSep+    decDigitGrp <- option mempty digitgroupp++    pure $ WithSeparators digitSep digitGroups (Just (decPt, decDigitGrp))++  withoutDecimalPt+    :: DigitGrp+    -> Char+    -> DigitGrp+    -> [DigitGrp]+    -> Either AmbiguousNumber RawNumber+  withoutDecimalPt grp1 sep grp2 grps+    | null grps && isDecimalMark sep =+        Left $ AmbiguousNumber grp1 sep grp2+    | otherwise = Right $ WithSeparators sep (grp1:grp2:grps) Nothing++  trailingDecimalPt :: DigitGrp -> TextParser m RawNumber+  trailingDecimalPt grp1 = do+    decPt <- satisfy isDecimalMark+    pure $ NoSeparators grp1 (Just (decPt, mempty))++isDigitSeparatorChar :: Char -> Bool+isDigitSeparatorChar c = isDecimalMark c || isDigitSeparatorSpaceChar c++-- | Kinds of unicode space character we accept as digit group marks.+-- See also https://en.wikipedia.org/wiki/Decimal_separator#Digit_grouping .+isDigitSeparatorSpaceChar :: Char -> Bool+isDigitSeparatorSpaceChar c =+     c == ' '  -- space+  || c == ' '  -- no-break space+  || c == ' '  -- en space+  || c == ' '  -- em space+  || c == ' '  -- punctuation space+  || c == ' '  -- thin space+  || c == ' '  -- narrow no-break space+  || c == ' '  -- medium mathematical space++-- | Some kinds of number literal we might parse.+data RawNumber+  = NoSeparators   DigitGrp (Maybe (Char, DigitGrp))+    -- ^ A number with no digit group marks (eg 100),+    --   or with a leading or trailing comma or period+    --   which (apparently) we interpret as a decimal mark (like 100. or .100)+  | WithSeparators Char [DigitGrp] (Maybe (Char, DigitGrp))+    -- ^ A number with identifiable digit group marks+    --   (eg 1,000,000 or 1,000.50 or 1 000)+  deriving (Show, Eq)++-- | Another kind of number literal: this one contains either a digit+-- group separator or a decimal mark, we're not sure which (eg 1,000 or 100.50).+data AmbiguousNumber = AmbiguousNumber DigitGrp Char DigitGrp+  deriving (Show, Eq)++-- | Description of a single digit group in a number literal.+-- "Thousands" is one well known digit grouping, but there are others.+data DigitGrp = DigitGrp {+  digitGroupLength :: !Word,    -- ^ The number of digits in this group.+                                -- This is Word to avoid the need to do overflow+                                -- checking for the Semigroup instance of DigitGrp.+  digitGroupNumber :: !Integer  -- ^ The natural number formed by this group's digits. This should always be positive.+} deriving (Eq)++-- | A custom show instance, showing digit groups as the parser saw them.+instance Show DigitGrp where+  show (DigitGrp len n) = "\"" ++ padding ++ numStr ++ "\""+    where numStr = show n+          padding = genericReplicate (toInteger len - toInteger (length numStr)) '0'++instance Sem.Semigroup DigitGrp where+  DigitGrp l1 n1 <> DigitGrp l2 n2 = DigitGrp (l1 + l2) (n1 * 10^l2 + n2)++instance Monoid DigitGrp where+  mempty = DigitGrp 0 0+  mappend = (Sem.<>)++digitgroupp :: TextParser m DigitGrp+digitgroupp = label "digits"+            $ makeGroup <$> takeWhile1P (Just "digit") isDigit+  where+    makeGroup = uncurry DigitGrp . T.foldl' step (0, 0)+    step (!l, !a) c = (l+1, a*10 + fromIntegral (digitToInt c))++--- *** comments++multilinecommentp :: TextParser m ()+multilinecommentp = startComment *> anyLine `skipManyTill` endComment+  where+    startComment = string "comment" *> trailingSpaces+    endComment = eof <|> string "end comment" *> trailingSpaces++    trailingSpaces = skipNonNewlineSpaces <* newline+    anyLine = void $ takeWhileP Nothing (/='\n') *> newline++{-# INLINABLE multilinecommentp #-}++-- | A blank or comment line in journal format: a line that's empty or+-- containing only whitespace or whose first non-whitespace character+-- is semicolon, hash, or star. See also emptyorcommentlinep2.+emptyorcommentlinep :: TextParser m ()+emptyorcommentlinep = do+  dp "emptyorcommentlinep"+  skipNonNewlineSpaces+  skiplinecommentp <|> void newline+  where+    skiplinecommentp :: TextParser m ()+    skiplinecommentp = do+      satisfy isLineCommentStart+      void $ takeWhileP Nothing (/= '\n')+      optional newline+      pure ()++{-# INLINABLE emptyorcommentlinep #-}++-- | A newer comment line parser.+-- Parses a line which is empty, all blanks, or whose first non-blank character is one of those provided.+-- A final newline is optional.+emptyorcommentlinep2 :: [Char] -> TextParser m ()+emptyorcommentlinep2 cs =+  label ("empty line or comment line beginning with "++cs) $ do+    dp "emptyorcommentlinep2"+    skipNonNewlineSpaces+    void newline <|> void commentp+    where+      commentp = do+        choice (map (some.char) cs)+        takeWhileP Nothing (/='\n') <* optional newline++-- | Is this a character that, as the first non-whitespace on a line,+-- starts a comment line ?+isLineCommentStart :: Char -> Bool+isLineCommentStart '#' = True+isLineCommentStart '*' = True+isLineCommentStart ';' = True+isLineCommentStart _   = False++-- | Is this a character that, appearing anywhere within a line,+-- starts a comment ?+isSameLineCommentStart :: Char -> Bool+isSameLineCommentStart ';' = True+isSameLineCommentStart _   = False++-- | Parse a comment following a journal item, possibly continued on multiple lines,+-- and return the comment text.+--+-- >>> rtp followingcommentp ""   -- no comment+-- Right ""+-- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added+-- Right "\n"+-- >>> rtp followingcommentp ";  \n"+-- Right "\n"+-- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment+-- Right "\n\n"+-- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.+-- Right "\n\n"+--+followingcommentp :: TextParser m Text+followingcommentp = fst <$> followingcommentpWith (void $ takeWhileP Nothing (/= '\n'))++{-# INLINABLE followingcommentp #-}++-- | Parse a following comment, possibly continued on multiple lines,+-- using the provided line parser to parse each line.+-- This returns the comment text, and the combined results from the line parser.+--+-- Following comments are a 1-or-more-lines comment,+-- beginning with a semicolon possibly preceded by whitespace on the current line,+-- or with an indented semicolon on the next line.+-- Additional lines also must begin with an indented semicolon.+--+-- Like Ledger, we sometimes allow data to be embedded in comments.+-- account directive comments and transaction comments can contain tags,+-- and posting comments can contain tags or bracketed posting dates.+-- This helper lets us handle these variations. +-- The line parser should consume all input up until the next newline.+-- See followingcommentp for some tests.+--+followingcommentpWith :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)+followingcommentpWith contentp = do+  skipNonNewlineSpaces+  -- there can be 0 or 1 sameLine+  sameLine <- try headerp *> ((:[]) <$> match' contentp) <|> pure []+  _ <- eolof+  -- there can be 0 or more nextLines+  nextLines <- many $+    try (skipNonNewlineSpaces1 *> headerp) *> match' contentp <* eolof+  let+    -- if there's just a next-line comment, insert an empty same-line comment+    -- so the next-line comment doesn't get rendered as a same-line comment.+    sameLine' | null sameLine && not (null nextLines) = [("",mempty)]+              | otherwise = sameLine+    (texts, contents) = unzip $ sameLine' ++ nextLines+    strippedCommentText = T.unlines $ map T.strip texts+    commentContent = mconcat contents+  pure (strippedCommentText, commentContent)++  where+    headerp = char ';' *> skipNonNewlineSpaces++{-# INLINABLE followingcommentpWith #-}+++-- Parse the tags from a single comment line, eg for use with followingcommentpWith.+-- XXX what part of a comment line ? leading whitespace / semicolon or not ?+commentlinetagsp :: TextParser m [Tag]+commentlinetagsp = do+  -- XXX sketchy+  tagName <- (last . T.split isSpace) <$> takeWhileP Nothing (\c -> c /= ':' && c /= '\n')+  atColon tagName <|> pure [] -- if not ':', then either '\n' or EOF++  where+    atColon :: Text -> TextParser m [Tag]+    atColon name = char ':' *> do+      if T.null name+        then commentlinetagsp+        else do+          skipNonNewlineSpaces+          val <- tagValue+          let tag = (name, val)+          (tag:) <$> commentlinetagsp++    tagValue :: TextParser m Text+    tagValue = do+      val <- T.strip <$> takeWhileP Nothing (\c -> c /= ',' && c /= '\n')+      _ <- optional $ char ','+      pure val++{-# INLINABLE commentlinetagsp #-}+++-- | Parse a transaction comment and extract its tags.+--+-- The first line of a transaction may be followed a 1-or-more-lines comment,+-- beginning with a semicolon possibly preceded by whitespace on the current line,+-- or with an indented semicolon on the next line. Additional lines also must+-- begin with an indented semicolon.+-- See also followingcommentpWith.+--+-- 2000/1/1 ; a transaction comment starting on the same line ...+--   ; extending to the next line+--   account1  $1+--   account2+--+-- Tags are name-value pairs.+--+-- >>> let getTags (_,tags) = tags+-- >>> let parseTags = fmap getTags . rtp transactioncommentp+--+-- >>> parseTags "; name1: val1, name2:all this is value2"+-- Right [("name1","val1"),("name2","all this is value2")]+--+-- A tag's name must be immediately followed by a colon, without+-- separating whitespace. The corresponding value consists of all the text+-- following the colon up until the next colon or newline, stripped of+-- leading and trailing whitespace.+--+transactioncommentp :: TextParser m (Text, [Tag])+transactioncommentp = followingcommentpWith commentlinetagsp+{-# INLINABLE transactioncommentp #-}+++-- | Parse a posting comment and extract its tags and dates.+--+-- Postings may be followed by comments, which begin with semicolons and+-- extend to the end of the line. Posting comments may span multiple+-- lines, but comment lines below the posting must be preceded by+-- leading whitespace.+--+-- 2000/1/1+--   account1  $1 ; a posting comment starting on the same line ...+--   ; extending to the next line+--+--   account2+--   ; a posting comment beginning on the next line+--+-- Tags are name-value pairs.+--+-- >>> let getTags (_,tags,_,_) = tags+-- >>> let parseTags = fmap getTags . rtp (postingcommentp Nothing)+--+-- >>> parseTags "; name1: val1, name2:all this is value2"+-- Right [("name1","val1"),("name2","all this is value2")]+--+-- A tag's name must be immediately followed by a colon, without+-- separating whitespace. The corresponding value consists of all the text+-- following the colon up until the next colon or newline, stripped of+-- leading and trailing whitespace.+--+-- Posting dates may be expressed with "date"/"date2" tags or with+-- bracketed date syntax. Posting dates will inherit their year from the+-- transaction date if the year is not specified. We throw parse errors on+-- invalid dates.+--+-- >>> let getDates (_,_,d1,d2) = (d1, d2)+-- >>> let parseDates = fmap getDates . rtp (postingcommentp (Just 2000))+--+-- >>> parseDates "; date: 1/2, date2: 1999/12/31"+-- Right (Just 2000-01-02,Just 1999-12-31)+-- >>> parseDates "; [1/2=1999/12/31]"+-- Right (Just 2000-01-02,Just 1999-12-31)+--+-- Example: tags, date tags, and bracketed dates+-- >>> rtp (postingcommentp (Just 2000)) "; a:b, date:3/4, [=5/6]"+-- Right ("a:b, date:3/4, [=5/6]\n",[("a","b"),("date","3/4")],Just 2000-03-04,Just 2000-05-06)+--+-- Example: extraction of dates from date tags ignores trailing text+-- >>> rtp (postingcommentp (Just 2000)) "; date:3/4=5/6"+-- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)+--+postingcommentp+  :: Maybe Year -> TextParser m (Text, [Tag], Maybe Day, Maybe Day)+postingcommentp mYear = do+  (commentText, (tags, dateTags)) <-+    followingcommentpWith (commenttagsanddatesp mYear)+  let mdate  = snd <$> find ((=="date") .fst) dateTags+      mdate2 = snd <$> find ((=="date2").fst) dateTags+  pure (commentText, tags, mdate, mdate2)+{-# INLINABLE postingcommentp #-}+++commenttagsanddatesp+  :: Maybe Year -> TextParser m ([Tag], [DateTag])+commenttagsanddatesp mYear = do+  (txt, dateTags) <- match $ readUpTo ':'+  -- next char is either ':' or '\n' (or EOF)+  let tagName = last (T.split isSpace txt)+  (fmap.second) (dateTags++) (atColon tagName) <|> pure ([], dateTags) -- if not ':', then either '\n' or EOF++  where+    readUpTo :: Char -> TextParser m [DateTag]+    readUpTo end = do+      void $ takeWhileP Nothing (\c -> c /= end && c /= '\n' && c /= '[')+      -- if not '[' then ':' or '\n' or EOF+      atBracket (readUpTo end) <|> pure []++    atBracket :: TextParser m [DateTag] -> TextParser m [DateTag]+    atBracket cont = do+      -- Uses the fact that bracketed date-tags cannot contain newlines+      dateTags <- option [] $ lookAhead (bracketeddatetagsp mYear)+      _ <- char '['+      dateTags' <- cont+      pure $ dateTags ++ dateTags'++    atColon :: Text -> TextParser m ([Tag], [DateTag])+    atColon name = char ':' *> do+      skipNonNewlineSpaces+      (tags, dateTags) <- case name of+        ""      -> pure ([], [])+        "date"  -> dateValue name+        "date2" -> dateValue name+        _       -> tagValue name+      _ <- optional $ char ','+      bimap (tags++) (dateTags++) <$> commenttagsanddatesp mYear++    dateValue :: Text -> TextParser m ([Tag], [DateTag])+    dateValue name = do+      (txt, (date, dateTags)) <- match' $ do+        date <- datep' mYear+        dateTags <- readUpTo ','+        pure (date, dateTags)+      let val = T.strip txt+      pure $ ( [(name, val)]+             , (name, date) : dateTags )++    tagValue :: Text -> TextParser m ([Tag], [DateTag])+    tagValue name = do+      (txt, dateTags) <- match' $ readUpTo ','+      let val = T.strip txt+      pure $ ( [(name, val)]+             , dateTags )++{-# INLINABLE commenttagsanddatesp #-}++-- | Parse Ledger-style bracketed posting dates ([DATE=DATE2]), as+-- "date" and/or "date2" tags. Anything that looks like an attempt at+-- this (a square-bracketed sequence of 0123456789/-.= containing at+-- least one digit and one date separator) is also parsed, and will+-- throw an appropriate error.+--+-- The dates are parsed in full here so that errors are reported in+-- the right position. A missing year in DATE can be inferred if a+-- default date is provided. A missing year in DATE2 will be inferred+-- from DATE.+--+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"+-- Right [("date",2016-01-02),("date2",2016-03-04)]+--+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"+-- Left ...not a bracketed date...+--+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"+-- Left ...1:2:...This is not a valid date...+--+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"+-- Left ...1:2:...This partial date can not be parsed because the current year is unknown...+--+-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"+-- Left ...1:13:...expecting month or day...+--+bracketeddatetagsp+  :: Maybe Year -> TextParser m [(TagName, Day)]+bracketeddatetagsp mYear1 = do+  -- dbgparse 0 "bracketeddatetagsp"+  try $ do+    s <- lookAhead+       $ between (char '[') (char ']')+       $ takeWhile1P Nothing isBracketedDateChar+    unless (T.any isDigit s && T.any isDateSepChar s) $+      Fail.fail "not a bracketed date"+  -- Looks sufficiently like a bracketed date to commit to parsing a date++  between (char '[') (char ']') $ do+    md1 <- optional $ datep' mYear1++    let mYear2 = fmap readYear md1 <|> mYear1+    md2 <- optional $ char '=' *> datep' mYear2++    pure $ catMaybes [("date",) <$> md1, ("date2",) <$> md2]++  where+    readYear = first3 . toGregorian+    isBracketedDateChar c = isDigit c || isDateSepChar c || c == '='++{-# INLINABLE bracketeddatetagsp #-}++-- | Get the account name aliases from options, if any.+aliasesFromOpts :: InputOpts -> [AccountAlias]+aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)+                  . aliases_++accountaliasp :: TextParser m AccountAlias+accountaliasp = regexaliasp <|> basicaliasp++basicaliasp :: TextParser m AccountAlias+basicaliasp = do+  -- dbgparse 0 "basicaliasp"+  old <- rstrip <$> (some $ noneOf ("=" :: [Char]))+  char '='+  skipNonNewlineSpaces+  new <- rstrip <$> anySingle `manyTill` eolof  -- eol in journal, eof in command lines, normally+  return $ BasicAlias (T.pack old) (T.pack new)++regexaliasp :: TextParser m AccountAlias+regexaliasp = do+  -- dbgparse 0 "regexaliasp"+  (off1, off2, re) <- between (char '/') (char '/') $ do+    off1 <- getOffset+    re <- fmap T.concat . some $+             (T.singleton <$> noneOf ("/\\\n\r" :: [Char]))               -- paranoid: don't try to read past line end+             <|> string "\\/"                                             -- allow escaping forward slashes+             <|> (liftM2 T.cons (char '\\') (T.singleton <$> anySingle))  -- Otherwise leave backslashes in+    off2 <- getOffset+    return (off1, off2, re)+  skipNonNewlineSpaces+  char '='+  skipNonNewlineSpaces+  repl <- anySingle `manyTill` eolof+  case toRegexCI re of+    Right r -> return $! RegexAlias r repl+    Left e  -> customFailure $! parseErrorAtRegion off1 off2 e++--- ** tests++tests_Common = testGroup "Common" [++   testGroup "amountp" [+    testCase "basic"                  $ assertParseEq amountp "$47.18"     (usd 47.18)+   ,testCase "ends with decimal mark" $ assertParseEq amountp "$1."        (usd 1  `withPrecision` Precision 0)+   ,testCase "unit price"             $ assertParseEq amountp "$10 @ €0.5"+      -- not precise enough:+      -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalmark=Just '.'+      nullamt{+         acommodity="$"+        ,aquantity=10 -- need to test internal precision with roundTo ? I think not+        ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}+        ,acost=Just $ UnitCost $+          nullamt{+             acommodity="€"+            ,aquantity=0.5+            ,astyle=amountstyle{asprecision=Precision 1, asdecimalmark=Just '.'}+            }+        }+   ,testCase "total price"            $ assertParseEq amountp "$10 @@ €5"+      nullamt{+         acommodity="$"+        ,aquantity=10+        ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}+        ,acost=Just $ TotalCost $+          nullamt{+             acommodity="€"+            ,aquantity=5+            ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}+            }+        }+   ,testCase "unit price, parenthesised" $ assertParse amountp "$10 (@) €0.5"+   ,testCase "total price, parenthesised" $ assertParse amountp "$10 (@@) €0.5"+   ]++  ,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle) in+   testCase "numberp" $ do+     assertParseEq p "0"          (0, 0, Nothing, Nothing)+     assertParseEq p "1"          (1, 0, Nothing, Nothing)+     assertParseEq p "1.1"        (1.1, 1, Just '.', Nothing)+     assertParseEq p "1,000.1"    (1000.1, 1, Just '.', Just $ DigitGroups ',' [3])+     assertParseEq p "1.00.000,1" (100000.1, 1, Just ',', Just $ DigitGroups '.' [3,2])+     assertParseEq p "1,000,000"  (1000000, 0, Nothing, Just $ DigitGroups ',' [3,3])  -- could be simplified to [3]+     assertParseEq p "1."         (1, 0, Just '.', Nothing)+     assertParseEq p "1,"         (1, 0, Just ',', Nothing)+     assertParseEq p ".1"         (0.1, 1, Just '.', Nothing)+     assertParseEq p ",1"         (0.1, 1, Just ',', Nothing)+     assertParseError p "" ""+     assertParseError p "1,000.000,1" ""+     assertParseError p "1.000,000.1" ""+     assertParseError p "1,000.000.1" ""+     assertParseError p "1,,1" ""+     assertParseError p "1..1" ""+     assertParseError p ".1," ""+     assertParseError p ",1." ""+     assertParseEq    p "1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" (1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555, 255, Just '.', Nothing)+     assertParseError p "1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" ""++  ,testGroup "spaceandamountormissingp" [+     testCase "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (mixedAmount $ usd 47.18)+    ,testCase "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt+    -- ,testCase "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt  -- XXX should it ?+    -- ,testCase "just amount" $ assertParseError spaceandamountormissingp "$47.18" ""  -- succeeds, consuming nothing+    ]++  ]++
Hledger/Read/CsvReader.hs view
@@ -1,900 +1,80 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections. {-| -A reader for CSV data, using an extra rules file to help interpret the data.+A reader for CSV (character-separated) data.+This also reads a rules file to help interpret the CSV data.  -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-} +--- ** language+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}++--- ** exports module Hledger.Read.CsvReader (   -- * Reader   reader,-  -- * Misc.-  CsvRecord,-  CSV, Record, Field,-  -- rules,-  rulesFileFor,-  parseRulesFile,-  parseAndValidateCsvRules,-  expandIncludes,-  transactionFromCsvRecord,-  printCSV,   -- * Tests   tests_CsvReader, ) where-import Prelude ()-import "base-compat-batteries" Prelude.Compat-import Control.Exception hiding (try)-import Control.Monad-import Control.Monad.Except-import Control.Monad.State.Strict (StateT, get, modify', evalStateT)-import Data.Char (toLower, isDigit, isSpace, ord)-import "base-compat-batteries" Data.List.Compat-import Data.Maybe-import Data.Ord-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.IO as T-import Data.Time.Calendar (Day)-#if MIN_VERSION_time(1,5,0)-import Data.Time.Format (parseTimeM, defaultTimeLocale)-#else-import Data.Time.Format (parseTime)-import System.Locale (defaultTimeLocale)-#endif-import Safe-import System.Directory (doesFileExist)-import System.FilePath-import qualified Data.Csv as Cassava-import qualified Data.Csv.Parser.Megaparsec as CassavaMP-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Foldable-import Text.Megaparsec hiding (parse)-import Text.Megaparsec.Char-import Text.Megaparsec.Custom-import Text.Printf (printf) +--- ** imports+import Prelude hiding (Applicative(..))+import Control.Monad.Except       (ExceptT(..), liftEither)+import Control.Monad.IO.Class     (MonadIO)+import System.IO                  (Handle)+ import Hledger.Data import Hledger.Utils-import Hledger.Read.Common (Reader(..),InputOpts(..),amountp, statusp, genericSourcePos)--type CSV = [Record]--type Record = [Field]+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), journalFinalise)+import Hledger.Read.RulesReader (readJournalFromCsv, getRulesFile, rulesEncoding, readRules)+import Control.Monad.Trans (lift) -type Field = String+--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings -data CSVError = CSVError (ParseErrorBundle BL.ByteString CassavaMP.ConversionError)-    deriving Show+--- ** reader -reader :: Reader-reader = Reader-  {rFormat     = "csv"-  ,rExtensions = ["csv"]-  ,rParser     = parse-  ,rExperimental = False+reader :: MonadIO m => SepFormat -> Reader m+reader sep = Reader+  {rFormat     = Sep sep+  ,rExtensions = [show sep]+  ,rReadFn     = parse sep+  ,rParser     = const $ fail "sorry, CSV files can't be included yet"+    -- This unnecessarily shows the CSV file's first line in the error message,+    -- but gives a more useful message than just calling error'.+    -- XXX Note every call to error' in Hledger.Read.* is potentially a similar problem -+    -- the error message is good enough when the file was specified directly by the user,+    -- but not good if it was loaded by a possibly long chain of include directives.   } --- | Parse and post-process a "Journal" from CSV data, or give an error.--- XXX currently ignores the string and reads from the file path-parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts f t = do-  let rulesfile = mrules_file_ iopts-  let separator = separator_ iopts-  r <- liftIO $ readJournalFromCsv separator rulesfile f t-  case r of Left e -> throwError e-            Right j -> return $ journalNumberAndTieTransactions j--- XXX does not use parseAndFinaliseJournal like the other readers---- | Read a Journal from the given CSV data (and filename, used for error--- messages), or return an error. Proceed as follows:--- @--- 1. parse CSV conversion rules from the specified rules file, or from---    the default rules file for the specified CSV file, if it exists,---    or throw a parse error; if it doesn't exist, use built-in default rules--- 2. parse the CSV data, or throw a parse error--- 3. convert the CSV records to transactions using the rules--- 4. if the rules file didn't exist, create it with the default rules and filename--- 5. return the transactions as a Journal--- @-readJournalFromCsv :: Char -> Maybe FilePath -> FilePath -> Text -> IO (Either String Journal)-readJournalFromCsv _ Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin"-readJournalFromCsv separator mrulesfile csvfile csvdata =- handle (\e -> return $ Left $ show (e :: IOException)) $ do-  let throwerr = throw.userError--  -- parse rules-  let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile-  rulesfileexists <- doesFileExist rulesfile-  rulestext <--    if rulesfileexists-    then do-      dbg1IO "using conversion rules file" rulesfile-      liftIO $ (readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile))-    else return $ defaultRulesText rulesfile-  rules <- liftIO (runExceptT $ parseAndValidateCsvRules rulesfile rulestext) >>= either throwerr return-  dbg2IO "rules" rules--  -- apply skip directive-  let skip = maybe 0 oneorerror $ getDirective "skip" rules-        where-          oneorerror "" = 1-          oneorerror s  = readDef (throwerr $ "could not parse skip value: " ++ show s) s--  -- parse csv-  -- parsec seems to fail if you pass it "-" here XXX try again with megaparsec-  let parsecfilename = if csvfile == "-" then "(stdin)" else csvfile-  records <- (either throwerr id .-              dbg2 "validateCsv" . validateCsv skip .-              dbg2 "parseCsv")-             `fmap` parseCsv separator parsecfilename csvdata-  dbg1IO "first 3 csv records" $ take 3 records--  -- identify header lines-  -- let (headerlines, datalines) = identifyHeaderLines records-  --     mfieldnames = lastMay headerlines--  let-    -- convert CSV records to transactions-    txns = snd $ mapAccumL-                   (\pos r ->-                      let-                        SourcePos name line col = pos-                        line' = (mkPos . (+1) . unPos) line-                        pos' = SourcePos name line' col-                      in-                        (pos, transactionFromCsvRecord pos' rules r)-                   )-                   (initialPos parsecfilename) records--    -- Ensure transactions are ordered chronologically.-    -- First, reverse them to get same-date transactions ordered chronologically,-    -- if the CSV records seem to be most-recent-first, ie if there's an explicit-    -- "newest-first" directive, or if there's more than one date and the first date-    -- is more recent than the last.-    txns' =-      (if newestfirst || mseemsnewestfirst == Just True then reverse else id) txns-      where-        newestfirst = dbg3 "newestfirst" $ isJust $ getDirective "newest-first" rules-        mseemsnewestfirst = dbg3 "mseemsnewestfirst" $-          case nub $ map tdate txns of-            ds | length ds > 1 -> Just $ head ds > last ds-            _                  -> Nothing-    -- Second, sort by date.-    txns'' = sortBy (comparing tdate) txns'--  when (not rulesfileexists) $ do-    dbg1IO "creating conversion rules file" rulesfile-    writeFile rulesfile $ T.unpack rulestext--  return $ Right nulljournal{jtxns=txns''}--parseCsv :: Char -> FilePath -> Text -> IO (Either CSVError CSV)-parseCsv separator filePath csvdata =-  case filePath of-    "-" -> liftM (parseCassava separator "(stdin)") T.getContents-    _   -> return $ parseCassava separator filePath csvdata--parseCassava :: Char -> FilePath -> Text -> Either CSVError CSV-parseCassava separator path content =-    case parseResult of-        Left  msg -> Left $ CSVError msg-        Right a   -> Right a-    where parseResult = fmap parseResultToCsv $ CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path lazyContent-          lazyContent = BL.fromStrict $ T.encodeUtf8 content--decodeOptions :: Char -> Cassava.DecodeOptions-decodeOptions separator = Cassava.defaultDecodeOptions {-                      Cassava.decDelimiter = fromIntegral (ord separator)-                    }--parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV-parseResultToCsv = toListList . unpackFields-    where-        toListList = toList . fmap toList-        unpackFields  = (fmap . fmap) (T.unpack . T.decodeUtf8)--printCSV :: CSV -> String-printCSV records = unlined (printRecord `map` records)-    where printRecord = concat . intersperse "," . map printField-          printField f = "\"" ++ concatMap escape f ++ "\""-          escape '"' = "\"\""-          escape x = [x]-          unlined = concat . intersperse "\n"---- | Return the cleaned up and validated CSV data (can be empty), or an error.-validateCsv :: Int -> Either CSVError CSV -> Either String [CsvRecord]-validateCsv _ (Left e) = Left $ show e-validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs-  where-    filternulls = filter (/=[""])-    validate [] = Right []-    validate rs@(first:_)-      | isJust lessthan2 = let r = fromJust lessthan2 in Left $ printf "CSV record %s has less than two fields" (show r)-      | isJust different = let r = fromJust different in Left $ printf "the first CSV record %s has %d fields but %s has %d" (show first) length1 (show r) (length r)-      | otherwise        = Right rs-      where-        length1   = length first-        lessthan2 = headMay $ filter ((<2).length) rs-        different = headMay $ filter ((/=length1).length) rs---- -- | The highest (0-based) field index referenced in the field--- -- definitions, or -1 if no fields are defined.--- maxFieldIndex :: CsvRules -> Int--- maxFieldIndex r = maximumDef (-1) $ catMaybes [---                    dateField r---                   ,statusField r---                   ,codeField r---                   ,amountField r---                   ,amountInField r---                   ,amountOutField r---                   ,currencyField r---                   ,accountField r---                   ,account2Field r---                   ,date2Field r---                   ]---- rulesFileFor :: CliOpts -> FilePath -> FilePath--- rulesFileFor CliOpts{rules_file_=Just f} _ = f--- rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules"-rulesFileFor :: FilePath -> FilePath-rulesFileFor = (++ ".rules")--csvFileFor :: FilePath -> FilePath-csvFileFor = reverse . drop 6 . reverse--defaultRulesText :: FilePath -> Text-defaultRulesText csvfile = T.pack $ unlines-  ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName csvfile)-  ,"# cf http://hledger.org/manual#csv-files"-  ,""-  ,"account1 assets:bank:checking"-  ,""-  ,"fields date, description, amount"-  ,""-  ,"#skip 1"-  ,"#newest-first"-  ,""-  ,"#date-format %-d/%-m/%Y"-  ,"#date-format %-m/%-d/%Y"-  ,"#date-format %Y-%h-%d"-  ,""-  ,"#currency $"-  ,""-  ,"if ITUNES"-  ," account2 expenses:entertainment"-  ,""-  ,"if (TO|FROM) SAVINGS"-  ," account2 assets:bank:savings\n"-  ]------------------------------------------------------------------------------------- Conversion rules parsing--{--Grammar for the CSV conversion rules, more or less:--RULES: RULE*--RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | NEWEST-FIRST | DATE-FORMAT | COMMENT | BLANK ) NEWLINE--FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )*--FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME--QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ "--BARE-FIELD-NAME: any CHAR except space, tab, #, ;--FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE--JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD--JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency--ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? )--FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs)--CSV-FIELD-REFERENCE: % CSV-FIELD--CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field)--FIELD-NUMBER: DIGIT+--CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK--FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS--MATCHOP: ~--PATTERNS: ( NEWLINE REGEXP )* REGEXP--INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+--REGEXP: ( NONSPACE CHAR* ) SPACE?--VALUE: SPACE? ( CHAR* ) SPACE?--COMMENT: SPACE? COMMENT-CHAR VALUE--COMMENT-CHAR: # | ;--NONSPACE: any CHAR not a SPACE-CHAR--BLANK: SPACE?--SPACE: SPACE-CHAR+--SPACE-CHAR: space | tab--CHAR: any character except newline--DIGIT: 0-9---}--{- |-A set of data definitions and account-matching patterns sufficient to-convert a particular CSV data file into meaningful journal transactions.--}-data CsvRules = CsvRules {-  rdirectives        :: [(DirectiveName,String)],-  rcsvfieldindexes   :: [(CsvFieldName, CsvFieldIndex)],-  rassignments       :: [(JournalFieldName, FieldTemplate)],-  rconditionalblocks :: [ConditionalBlock]-} deriving (Show, Eq)--type CsvRulesParser a = StateT CsvRules SimpleTextParser a--type DirectiveName    = String-type CsvFieldName     = String-type CsvFieldIndex    = Int-type JournalFieldName = String-type FieldTemplate    = String-type ConditionalBlock = ([RecordMatcher], [(JournalFieldName, FieldTemplate)]) -- block matches if all RecordMatchers match-type RecordMatcher    = [RegexpPattern] -- match if any regexps match any of the csv fields--- type FieldMatcher     = (CsvFieldName, [RegexpPattern]) -- match if any regexps match this csv field-type DateFormat       = String-type RegexpPattern           = String--rules = CsvRules {-  rdirectives=[],-  rcsvfieldindexes=[],-  rassignments=[],-  rconditionalblocks=[]-}--addDirective :: (DirectiveName, String) -> CsvRules -> CsvRules-addDirective d r = r{rdirectives=d:rdirectives r}--addAssignment :: (JournalFieldName, FieldTemplate) -> CsvRules -> CsvRules-addAssignment a r = r{rassignments=a:rassignments r}--setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules-setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r--setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRules -> CsvRules-setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]}--addAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules-addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames-  where-    maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules-      where-        addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1))--addConditionalBlock :: ConditionalBlock -> CsvRules -> CsvRules-addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}--getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate-getDirective directivename = lookup directivename . rdirectives--instance ShowErrorComponent String where-  showErrorComponent = id---- | An error-throwing action that parses this file's content--- as CSV conversion rules, interpolating any included files first,--- and runs some extra validation checks.-parseRulesFile :: FilePath -> ExceptT String IO CsvRules-parseRulesFile f =-  liftIO (readFilePortably f >>= expandIncludes (takeDirectory f)) >>= parseAndValidateCsvRules f---- | Inline all files referenced by include directives in this hledger CSV rules text, recursively.--- Included file paths may be relative to the directory of the provided file path.--- This is a cheap hack to avoid rewriting the CSV rules parser.-expandIncludes dir content = mapM (expandLine dir) (T.lines content) >>= return . T.unlines-  where-    expandLine dir line =-      case line of-        (T.stripPrefix "include " -> Just f) -> expandIncludes dir' =<< T.readFile f'-          where-            f' = dir </> dropWhile isSpace (T.unpack f)-            dir' = takeDirectory f'-        _ -> return line---- | An error-throwing action that parses this text as CSV conversion rules--- and runs some extra validation checks. The file path is for error messages.-parseAndValidateCsvRules :: FilePath -> T.Text -> ExceptT String IO CsvRules-parseAndValidateCsvRules rulesfile s = do-  let rules = parseCsvRules rulesfile s-  case rules of-    Left e -> ExceptT $ return $ Left $ customErrorBundlePretty e-    Right r -> do-               r_ <- liftIO $ runExceptT $ validateRules r-               ExceptT $ case r_ of-                 Left  s -> return $ Left $ parseErrorPretty $ makeParseError s-                 Right r -> return $ Right r--  where-    makeParseError :: String -> ParseError T.Text String-    makeParseError s = FancyError 0 (S.singleton $ ErrorFail s)---- | Parse this text as CSV conversion rules. The file path is for error messages.-parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules--- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s-parseCsvRules rulesfile s =-  runParser (evalStateT rulesp rules) rulesfile s---- | Return the validated rules, or an error.-validateRules :: CsvRules -> ExceptT String IO CsvRules-validateRules rules = do-  unless (isAssigned "date")   $ ExceptT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n"-  unless ((amount && not (amountin || amountout)) ||-          (not amount && (amountin && amountout)))-    $ ExceptT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"-  ExceptT $ return $ Right rules-  where-    amount = isAssigned "amount"-    amountin = isAssigned "amount-in"-    amountout = isAssigned "amount-out"-    isAssigned f = isJust $ getEffectiveAssignment rules [] f---- parsers--rulesp :: CsvRulesParser CsvRules-rulesp = do-  many $ choiceInState-    [blankorcommentlinep                                                <?> "blank or comment line"-    ,(directivep        >>= modify' . addDirective)                     <?> "directive"-    ,(fieldnamelistp    >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"-    ,(fieldassignmentp  >>= modify' . addAssignment)                    <?> "field assignment"-    ,(conditionalblockp >>= modify' . addConditionalBlock)              <?> "conditional block"-    ]-  eof-  r <- get-  return r{rdirectives=reverse $ rdirectives r-          ,rassignments=reverse $ rassignments r-          ,rconditionalblocks=reverse $ rconditionalblocks r-          }--blankorcommentlinep :: CsvRulesParser ()-blankorcommentlinep = lift (dbgparse 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]--blanklinep :: CsvRulesParser ()-blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"--commentlinep :: CsvRulesParser ()-commentlinep = lift (skipMany spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line"--commentcharp :: CsvRulesParser Char-commentcharp = oneOf (";#*" :: [Char])--directivep :: CsvRulesParser (DirectiveName, String)-directivep = (do-  lift $ dbgparse 3 "trying directive"-  d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives-  v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)-       <|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")-  return (d, v)-  ) <?> "directive"--directives =-  ["date-format"-  -- ,"default-account1"-  -- ,"default-currency"-  -- ,"skip-lines" -- old-  ,"skip"-  ,"newest-first"-   -- ,"base-account"-   -- ,"base-currency"-  ]--directivevalp :: CsvRulesParser String-directivevalp = anySingle `manyTill` lift eolof--fieldnamelistp :: CsvRulesParser [CsvFieldName]-fieldnamelistp = (do-  lift $ dbgparse 3 "trying fieldnamelist"-  string "fields"-  optional $ char ':'-  lift (skipSome spacenonewline)-  let separator = lift (skipMany spacenonewline) >> char ',' >> lift (skipMany spacenonewline)-  f <- fromMaybe "" <$> optional fieldnamep-  fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)-  lift restofline-  return $ map (map toLower) $ f:fs-  ) <?> "field name list"--fieldnamep :: CsvRulesParser String-fieldnamep = quotedfieldnamep <|> barefieldnamep--quotedfieldnamep :: CsvRulesParser String-quotedfieldnamep = do-  char '"'-  f <- some $ noneOf ("\"\n:;#~" :: [Char])-  char '"'-  return f--barefieldnamep :: CsvRulesParser String-barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])--fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)-fieldassignmentp = do-  lift $ dbgparse 3 "trying fieldassignmentp"-  f <- journalfieldnamep-  assignmentseparatorp-  v <- fieldvalp-  return (f,v)-  <?> "field assignment"--journalfieldnamep :: CsvRulesParser String-journalfieldnamep = do-  lift (dbgparse 2 "trying journalfieldnamep")-  T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)---- Transaction fields and pseudo fields for CSV conversion.--- Names must precede any other name they contain, for the parser--- (amount-in before amount; date2 before date). TODO: fix-journalfieldnames = [-   "account1"-  ,"account2"-  ,"amount-in"-  ,"amount-out"-  ,"amount"-  ,"balance"-  ,"code"-  ,"comment"-  ,"currency"-  ,"date2"-  ,"date"-  ,"description"-  ,"status"-  ]--assignmentseparatorp :: CsvRulesParser ()-assignmentseparatorp = do-  lift $ dbgparse 3 "trying assignmentseparatorp"-  choice [-    -- try (lift (skipMany spacenonewline) >> oneOf ":="),-    try (lift (skipMany spacenonewline) >> char ':'),-    spaceChar-    ]-  _ <- lift (skipMany spacenonewline)-  return ()--fieldvalp :: CsvRulesParser String-fieldvalp = do-  lift $ dbgparse 2 "trying fieldvalp"-  anySingle `manyTill` lift eolof--conditionalblockp :: CsvRulesParser ConditionalBlock-conditionalblockp = do-  lift $ dbgparse 3 "trying conditionalblockp"-  string "if" >> lift (skipMany spacenonewline) >> optional newline-  ms <- some recordmatcherp-  as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)-  when (null as) $-    fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"-  return (ms, as)-  <?> "conditional block"--recordmatcherp :: CsvRulesParser [String]-recordmatcherp = do-  lift $ dbgparse 2 "trying recordmatcherp"-  -- pos <- currentPos-  _  <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)-  ps <- patternsp-  when (null ps) $-    fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"-  return ps-  <?> "record matcher"--matchoperatorp :: CsvRulesParser String-matchoperatorp = fmap T.unpack $ choiceInState $ map string-  ["~"-  -- ,"!~"-  -- ,"="-  -- ,"!="-  ]--patternsp :: CsvRulesParser [String]-patternsp = do-  lift $ dbgparse 3 "trying patternsp"-  ps <- many regexp-  return ps--regexp :: CsvRulesParser String-regexp = do-  lift $ dbgparse 3 "trying regexp"-  notFollowedBy matchoperatorp-  c <- lift nonspace-  cs <- anySingle `manyTill` lift eolof-  return $ strip $ c:cs---- fieldmatcher = do---   dbgparse 2 "trying fieldmatcher"---   f <- fromMaybe "all" `fmap` (optional $ do---          f' <- fieldname---          lift (skipMany spacenonewline)---          return f')---   char '~'---   lift (skipMany spacenonewline)---   ps <- patterns---   let r = "(" ++ intercalate "|" ps ++ ")"---   return (f,r)---   <?> "field matcher"------------------------------------------------------------------------------------- Converting CSV records to journal transactions--type CsvRecord = [String]---- Convert a CSV record to a transaction using the rules, or raise an--- error if the data can not be parsed.-transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction-transactionFromCsvRecord sourcepos rules record = t-  where-    mdirective       = (`getDirective` rules)-    mfieldtemplate   = getEffectiveAssignment rules record-    render           = renderTemplate rules record-    mskip            = mdirective "skip"-    mdefaultcurrency = mdirective "default-currency"-    mparsedate       = parseDateWithFormatOrDefaultFormats (mdirective "date-format")--    -- render each field using its template and the csv record, and-    -- in some cases parse the rendered string (eg dates and amounts)-    mdateformat = mdirective "date-format"-    date        = render $ fromMaybe "" $ mfieldtemplate "date"-    date'       = fromMaybe (error' $ dateerror "date" date mdateformat) $ mparsedate date-    mdate2      = maybe Nothing (Just . render) $ mfieldtemplate "date2"-    mdate2'     = maybe Nothing (maybe (error' $ dateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . mparsedate) mdate2-    dateerror datefield value mdateformat = unlines-      ["error: could not parse \""++value++"\" as a date using date format "++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat-      ,"the CSV record is:  "++intercalate ", " (map show record)-      ,"the "++datefield++" rule is:   "++(fromMaybe "required, but missing" $ mfieldtemplate datefield)-      ,"the date-format is: "++fromMaybe "unspecified" mdateformat-      ,"you may need to "-       ++"change your "++datefield++" rule, "-       ++maybe "add a" (const "change your") mdateformat++" date-format rule, "-       ++"or "++maybe "add a" (const "change your") mskip++" skip rule"-      ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"-      ]-    status      =-      case mfieldtemplate "status" of-        Nothing  -> Unmarked-        Just str -> either statuserror id .-                    runParser (statusp <* eof) "" .-                    T.pack $ render str-          where-            statuserror err = error' $ unlines-              ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"-              ,"the parse error is:      "++customErrorBundlePretty err-              ]-    code        = maybe "" render $ mfieldtemplate "code"-    description = maybe "" render $ mfieldtemplate "description"-    comment     = maybe "" render $ mfieldtemplate "comment"-    precomment  = maybe "" render $ mfieldtemplate "precomment"-    currency    = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"-    amountstr   = (currency++) <$> simplifySign <$> getAmountStr rules record-    maybeamount      = either amounterror (Mixed . (:[])) <$> runParser (evalStateT (amountp <* eof) mempty) "" <$> T.pack <$> amountstr-    amounterror err = error' $ unlines-      ["error: could not parse \""++fromJust amountstr++"\" as an amount"-      ,showRecord record-      ,"the amount rule is:      "++(fromMaybe "" $ mfieldtemplate "amount")-      ,"the currency rule is:    "++(fromMaybe "unspecified" $ mfieldtemplate "currency")-      ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency-      ,"the parse error is:      "++customErrorBundlePretty err-      ,"you may need to "-       ++"change your amount or currency rules, "-       ++"or "++maybe "add a" (const "change your") mskip++" skip rule"-      ]-    amount1 = case maybeamount of-                Just a -> a-                Nothing | balance /= Nothing -> nullmixedamt-                Nothing -> error' $ "amount and balance have no value\n"++showRecord record-    -- convert balancing amount to cost like hledger print, so eg if-    -- amount1 is "10 GBP @@ 15 USD", amount2 will be "-15 USD".-    amount2        = costOfMixedAmount (-amount1)-    s `or` def  = if null s then def else s-    defaccount1 = fromMaybe "unknown" $ mdirective "default-account1"-    defaccount2 = case isNegativeMixedAmount amount2 of-                   Just True -> "income:unknown"-                   _         -> "expenses:unknown"-    account1    = T.pack $ maybe "" render (mfieldtemplate "account1") `or` defaccount1-    account2    = T.pack $ maybe "" render (mfieldtemplate "account2") `or` defaccount2-    balance     = maybe Nothing (parsebalance.render) $ mfieldtemplate "balance"-    parsebalance str-      | all isSpace str  = Nothing-      | otherwise = Just $ (either (balanceerror str) id $ runParser (evalStateT (amountp <* eof) mempty) "" $ T.pack $ (currency++) $ simplifySign str, nullsourcepos)-    balanceerror str err = error' $ unlines-      ["error: could not parse \""++str++"\" as balance amount"-      ,showRecord record-      ,"the balance rule is:      "++(fromMaybe "" $ mfieldtemplate "balance")-      ,"the currency rule is:    "++(fromMaybe "unspecified" $ mfieldtemplate "currency")-      ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency-      ,"the parse error is:      "++customErrorBundlePretty err-      ]--    -- build the transaction-    t = nulltransaction{-      tsourcepos               = genericSourcePos sourcepos,-      tdate                    = date',-      tdate2                   = mdate2',-      tstatus                  = status,-      tcode                    = T.pack code,-      tdescription             = T.pack description,-      tcomment                 = T.pack comment,-      tprecedingcomment = T.pack precomment,-      tpostings                =-        [posting {paccount=account1, pamount=amount1, ptransaction=Just t, pbalanceassertion=toAssertion <$> balance}-        ,posting {paccount=account2, pamount=amount2, ptransaction=Just t}-        ]-      }-    toAssertion (a, b) = assertion{-      baamount   = a,-      baposition = b-      }--getAmountStr :: CsvRules -> CsvRecord -> Maybe String-getAmountStr rules record =- let-   mamount    = getEffectiveAssignment rules record "amount"-   mamountin  = getEffectiveAssignment rules record "amount-in"-   mamountout = getEffectiveAssignment rules record "amount-out"-   render     = fmap (strip . renderTemplate rules record)- in-  case (render mamount, render mamountin, render mamountout) of-    (Just "", Nothing, Nothing) -> Nothing-    (Just a,  Nothing, Nothing) -> Just a-    (Nothing, Just "", Just "") -> error' $    "neither amount-in or amount-out has a value\n"-                                            ++ "    record: " ++ showRecord record-    (Nothing, Just i,  Just "") -> Just i-    (Nothing, Just "", Just o)  -> Just $ negateStr o-    (Nothing, Just i,  Just o)  -> error' $    "both amount-in and amount-out have a value\n"-                                            ++ "    amount-in: "  ++ i ++ "\n"-                                            ++ "    amount-out: " ++ o ++ "\n"-                                            ++ "    record: "     ++ showRecord record-    _                           -> error' $    "found values for amount and for amount-in/amount-out\n"-                                            ++ "please use either amount or amount-in/amount-out\n"-                                            ++ "    record: " ++ showRecord record--type CsvAmountString = String---- | Canonicalise the sign in a CSV amount string.--- Such strings can have a minus sign, negating parentheses,--- or any two of these (which cancels out).------ >>> simplifySign "1"--- "1"--- >>> simplifySign "-1"--- "-1"--- >>> simplifySign "(1)"--- "-1"--- >>> simplifySign "--1"--- "1"--- >>> simplifySign "-(1)"--- "1"--- >>> simplifySign "(-1)"--- "1"--- >>> simplifySign "((1))"--- "1"-simplifySign :: CsvAmountString -> CsvAmountString-simplifySign ('(':s) | lastMay s == Just ')' = simplifySign $ negateStr $ init s-simplifySign ('-':'(':s) | lastMay s == Just ')' = simplifySign $ init s-simplifySign ('-':'-':s) = s-simplifySign s = s--negateStr :: String -> String-negateStr ('-':s) = s-negateStr s       = '-':s---- | Show a (approximate) recreation of the original CSV record.-showRecord :: CsvRecord -> String-showRecord r = "the CSV record is:       "++intercalate ", " (map show r)---- | Given the conversion rules, a CSV record and a journal entry field name, find--- the template value ultimately assigned to this field, either at top--- level or in a matching conditional block.  Conditional blocks'--- patterns are matched against an approximation of the original CSV--- record: all the field values with commas intercalated.-getEffectiveAssignment :: CsvRules -> CsvRecord -> JournalFieldName -> Maybe FieldTemplate-getEffectiveAssignment rules record f = lastMay $ assignmentsFor f-  where-    assignmentsFor f = map snd $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments-      where-        toplevelassignments    = rassignments rules-        conditionalassignments = concatMap snd $ filter blockMatches $ blocksAssigning f-          where-            blocksAssigning f = filter (any ((==f).fst) . snd) $ rconditionalblocks rules-            blockMatches :: ConditionalBlock -> Bool-            blockMatches (matchers,_) = all matcherMatches matchers-              where-                matcherMatches :: RecordMatcher -> Bool-                -- matcherMatches pats = any patternMatches pats-                matcherMatches pats = patternMatches $  "(" ++ intercalate "|" pats ++ ")"-                  where-                    patternMatches :: RegexpPattern -> Bool-                    patternMatches pat = regexMatchesCI pat csvline-                      where-                        csvline = intercalate "," record--renderTemplate ::  CsvRules -> CsvRecord -> FieldTemplate -> String-renderTemplate rules record t = regexReplaceBy "%[A-z0-9]+" replace t-  where-    replace ('%':pat) = maybe pat (\i -> atDef "" record (i-1)) mindex-      where-        mindex | all isDigit pat = readMay pat-               | otherwise       = lookup (map toLower pat) $ rcsvfieldindexes rules-    replace pat       = pat---- Parse the date string using the specified date-format, or if unspecified try these default formats:--- YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, MM/DD/YYYY (month and day can be 1 or 2 digits, year must be 4).-parseDateWithFormatOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day-parseDateWithFormatOrDefaultFormats mformat s = firstJust $ map parsewith formats-  where-    parsetime =-#if MIN_VERSION_time(1,5,0)-     parseTimeM True-#else-     parseTime-#endif-    parsewith = flip (parsetime defaultTimeLocale) s-    formats = maybe-               ["%Y/%-m/%-d"-               ,"%Y-%-m-%-d"-               ,"%Y.%-m.%-d"-               -- ,"%-m/%-d/%Y"-                -- ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)-                -- ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)-                -- ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s)-                -- ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s)-               ]-               (:[])-                mformat------------------------------------------------------------------------------------- tests--tests_CsvReader = tests "CsvReader" [-   tests "parseCsvRules" [-     test "empty file" $-      parseCsvRules "unknown" "" `is` Right rules-    ]-  ,tests "rulesp" [-     test "trailing comments" $-      parseWithState' rules rulesp "skip\n# \n#\n" `is` Right rules{rdirectives = [("skip","")]}--    ,test "trailing blank lines" $-      parseWithState' rules rulesp "skip\n\n  \n" `is` (Right rules{rdirectives = [("skip","")]})--    ,test "no final newline" $-      parseWithState' rules rulesp "skip" `is` (Right rules{rdirectives=[("skip","")]})+-- | Parse and post-process a "Journal" from a CSV(/SSV/TSV/*SV) data file, or give an error.+-- This currently ignores the provided input file handle, and reads from the data file itself,+-- inferring a corresponding rules file to help convert it.+-- This does not check balance assertions.+parse :: SepFormat -> InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+parse sep iopts f h = do+  rules <- readRules $ getRulesFile f (mrules_file_ iopts)+  mencoding <- rulesEncoding rules+  csvtext <- lift $ hGetContentsPortably mencoding h+  readJournalFromCsv rules f csvtext (Just sep)+  -- apply any command line account aliases. Can fail with a bad replacement pattern.+  >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+      -- journalFinalise assumes the journal's items are+      -- reversed, as produced by JournalReader's parser.+      -- But here they are already properly ordered. So we'd+      -- better preemptively reverse them once more. XXX inefficient+      . journalReverse+  >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f "" -    ,test "assignment with empty value" $-      parseWithState' rules rulesp "account1 \nif foo\n  account2 foo\n" `is`-        (Right rules{rassignments = [("account1","")], rconditionalblocks = [([["foo"]],[("account2","foo")])]})+--- ** tests -    ]+tests_CsvReader = testGroup "CsvReader" [   ]
+ Hledger/Read/InputOptions.hs view
@@ -0,0 +1,98 @@+{-|++Various options to use when reading journal files.+Similar to CliOptions.inputflags, simplifies the journal-reading functions.++-}+{-# LANGUAGE TemplateHaskell #-}++module Hledger.Read.InputOptions (+-- * Types and helpers for input options+  InputOpts(..)+, HasInputOpts(..)+, definputopts+, forecastPeriod+) where++import Control.Applicative ((<|>))+import Data.Time (Day, addDays)++import Hledger.Data.Types+import Hledger.Data.Journal (journalEndDate)+import Hledger.Data.Dates (nulldate, nulldatespan)+import Hledger.Data.Balancing (BalancingOpts(..), HasBalancingOpts(..), defbalancingopts)+import Hledger.Utils (dbg2, makeHledgerClassyLenses)++data InputOpts = InputOpts {+     -- files_             :: [FilePath]+     mformat_           :: Maybe StorageFormat  -- ^ a file/storage format to try, unless overridden+                                                --   by a filename prefix. Nothing means try all.+    ,mrules_file_       :: Maybe FilePath       -- ^ a conversion rules file to use (when reading CSV)+    ,aliases_           :: [String]             -- ^ account name aliases to apply+    ,anon_              :: Bool                 -- ^ do light obfuscation of the data ? Now corresponds to --obfuscate, not the old --anon flag.+    ,new_               :: Bool                 -- ^ read only new transactions since this file was last read ?+    ,new_save_          :: Bool                 -- ^ save latest new transactions state for next time ?+    ,pivot_             :: String               -- ^ use the given field's value as the account name+    ,forecast_          :: Maybe DateSpan       -- ^ span in which to generate forecast transactions+    ,auto_posting_tags_ :: Bool                 -- ^ propagate commodity and account tags to postings ? Can be disabled (for beancount export).+    ,verbose_tags_      :: Bool                 -- ^ add user-visible tags when generating/modifying transactions & postings ?+    ,reportspan_        :: DateSpan             -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here.+    ,auto_              :: Bool                 -- ^ generate extra postings according to auto posting rules ?+    ,infer_equity_      :: Bool                 -- ^ infer equity conversion postings from costs ?+    ,infer_costs_       :: Bool                 -- ^ infer costs from equity conversion postings ? distinct from BalancingOpts{infer_balancing_costs_}+    ,balancingopts_     :: BalancingOpts        -- ^ options for transaction balancing+    ,strict_            :: Bool                 -- ^ do extra correctness checks ?+    ,_defer             :: Bool                 -- ^ internal flag: postpone checks, because we are processing multiple files ?+    ,_ioDay             :: Day                  -- ^ today's date, for use with forecast transactions  XXX this duplicates _rsDay, and should eventually be removed when it's not needed anymore.+    ,_oldtimeclock      :: Bool                 -- ^ parse with the old timeclock pairing rules?+ } deriving (Eq, Ord, Show)++definputopts :: InputOpts+definputopts = InputOpts+    { mformat_           = Nothing+    , mrules_file_       = Nothing+    , aliases_           = []+    , anon_              = False+    , new_               = False+    , new_save_          = True+    , pivot_             = ""+    , forecast_          = Nothing+    , auto_posting_tags_ = False+    , verbose_tags_      = False+    , reportspan_        = nulldatespan+    , auto_              = False+    , infer_equity_      = False+    , infer_costs_       = False+    , balancingopts_     = defbalancingopts+    , strict_            = False+    , _defer             = False+    , _ioDay             = nulldate+    , _oldtimeclock      = False+    }++-- | Get the Maybe the DateSpan to generate forecast options from.+-- This begins on:+-- - the start date supplied to the `--forecast` argument, if present+-- - otherwise, the later of+--   - the report start date if specified with -b/-p/date:+--   - the day after the latest normal (non-periodic) transaction in the journal, if any+-- - otherwise today.+-- It ends on:+-- - the end date supplied to the `--forecast` argument, if present+-- - otherwise the report end date if specified with -e/-p/date:+-- - otherwise 180 days (6 months) from today.+forecastPeriod :: InputOpts -> Journal -> Maybe DateSpan+forecastPeriod iopts j = do+    DateSpan requestedStart requestedEnd <- forecast_ iopts+    let forecastStart = fromEFDay <$> requestedStart <|> max mjournalend (fromEFDay <$> reportStart) <|> Just (_ioDay iopts)+        forecastEnd   = fromEFDay <$> requestedEnd <|> fromEFDay <$> reportEnd <|> (Just $ addDays 180 $ _ioDay iopts)+        mjournalend   = dbg2 "journalEndDate" $ journalEndDate False j  -- ignore secondary dates+        DateSpan reportStart reportEnd = reportspan_ iopts+    return . dbg2 "forecastspan" $ DateSpan (Exact <$> forecastStart) (Exact <$> forecastEnd)++-- ** Lenses++makeHledgerClassyLenses ''InputOpts++instance HasBalancingOpts InputOpts where+    balancingOpts = balancingopts
Hledger/Read/JournalReader.hs view
@@ -1,946 +1,1308 @@---- * doc--- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,--- (add-hook 'haskell-mode-hook---   (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))---   'orgstruct-mode)--- and press TAB on nodes to expand/collapse.--{-|--A reader for hledger's journal file format-(<http://hledger.org/MANUAL.html#the-journal-file>).  hledger's journal-format is a compatible subset of c++ ledger's-(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this-reader should handle many ledger files as well. Example:--@-2012\/3\/24 gift-    expenses:gifts  $10-    assets:cash-@--Journal format supports the include directive which can read files in-other formats, so the other file format readers need to be importable-here.  Some low-level journal syntax parsers which those readers also-use are therefore defined separately in Hledger.Read.Common, avoiding-import cycles.---}----- * module--{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections, OverloadedStrings, PackageImports #-}--module Hledger.Read.JournalReader (---- * exports--  -- * Reader-  reader,--  -- * Parsing utils-  genericSourcePos,-  parseAndFinaliseJournal,-  runJournalParser,-  rjp,--  -- * Parsers used elsewhere-  getParentAccount,-  journalp,-  directivep,-  defaultyeardirectivep,-  marketpricedirectivep,-  datetimep,-  datep,-  modifiedaccountnamep,-  postingp,-  statusp,-  emptyorcommentlinep,-  followingcommentp--  -- * Tests-  ,tests_JournalReader-)-where---- * imports-import Prelude ()-import "base-compat-batteries" Prelude.Compat hiding (readFile)-import qualified Control.Exception as C-import Control.Monad-import Control.Monad.Except (ExceptT(..), runExceptT)-import Control.Monad.State.Strict-import qualified Data.Map.Strict as M-import Data.Text (Text)-import Data.String-import Data.List-import qualified Data.Text as T-import Data.Time.Calendar-import Data.Time.LocalTime-import Safe-import Text.Megaparsec hiding (parse)-import Text.Megaparsec.Char-import Text.Megaparsec.Custom-import Text.Printf-import System.FilePath-import "Glob" System.FilePath.Glob hiding (match)--import Hledger.Data-import Hledger.Read.Common-import Hledger.Read.TimeclockReader (timeclockfilep)-import Hledger.Read.TimedotReader (timedotfilep)-import Hledger.Utils---- $setup--- >>> :set -XOverloadedStrings----- * reader--reader :: Reader-reader = Reader-  {rFormat     = "journal"-  ,rExtensions = ["journal", "j", "hledger", "ledger"]-  ,rParser     = parse-  ,rExperimental = False-  }---- | Parse and post-process a "Journal" from hledger's journal file--- format, or give an error.-parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse iopts = parseAndFinaliseJournal journalp' iopts-  where-    journalp' = do -      -- reverse parsed aliases to ensure that they are applied in order given on commandline-      mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts) -      journalp---- | Get the account name aliases from options, if any.-aliasesFromOpts :: InputOpts -> [AccountAlias]-aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)-                  . aliases_----- * parsers---- ** journal---- | A journal parser. Accumulates and returns a "ParsedJournal",--- which should be finalised/validated before use.------ >>> rejp (journalp <* eof) "2015/1/1\n a  0\n"--- Right (Right Journal  with 1 transactions, 1 accounts)----journalp :: MonadIO m => ErroringJournalParser m ParsedJournal-journalp = do-  many addJournalItemP-  eof-  get---- | A side-effecting parser; parses any kind of journal item--- and updates the parse state accordingly.-addJournalItemP :: MonadIO m => ErroringJournalParser m ()-addJournalItemP =-  -- all journal line types can be distinguished by the first-  -- character, can use choice without backtracking-  choice [-      directivep-    , transactionp          >>= modify' . addTransaction-    , transactionmodifierp  >>= modify' . addTransactionModifier-    , periodictransactionp  >>= modify' . addPeriodicTransaction-    , marketpricedirectivep >>= modify' . addMarketPrice-    , void (lift emptyorcommentlinep)-    , void (lift multilinecommentp)-    ] <?> "transaction or directive"----- ** directives---- | Parse any journal directive and update the parse state accordingly.--- Cf http://hledger.org/manual.html#directives,--- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives-directivep :: MonadIO m => ErroringJournalParser m ()-directivep = (do-  optional $ char '!'-  choice [-    includedirectivep-   ,aliasdirectivep-   ,endaliasesdirectivep-   ,accountdirectivep-   ,applyaccountdirectivep-   ,commoditydirectivep-   ,endapplyaccountdirectivep-   ,tagdirectivep-   ,endtagdirectivep-   ,defaultyeardirectivep-   ,defaultcommoditydirectivep-   ,commodityconversiondirectivep-   ,ignoredpricecommoditydirectivep-   ]-  ) <?> "directive"--includedirectivep :: MonadIO m => ErroringJournalParser m ()-includedirectivep = do-  string "include"-  lift (skipSome spacenonewline)-  filename <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet--  parentoff <- getOffset-  parentpos <- getSourcePos--  filepaths <- getFilePaths parentoff parentpos filename--  forM_ filepaths $ parseChild parentpos--  void newline--  where-    getFilePaths-      :: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath]-    getFilePaths parseroff parserpos filename = do-        let curdir = takeDirectory (sourceName parserpos)-        filename' <- lift $ expandHomePath filename-                         `orRethrowIOError` (show parserpos ++ " locating " ++ filename)-        -- Compiling filename as a glob pattern works even if it is a literal-        fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename' of-            Right x -> pure x-            Left e -> customFailure $-                        parseErrorAt parseroff $ "Invalid glob pattern: " ++ e-        -- Get all matching files in the current working directory, sorting in-        -- lexicographic order to simulate the output of 'ls'.-        filepaths <- liftIO $ sort <$> globDir1 fileglob curdir-        if (not . null) filepaths-            then pure filepaths-            else customFailure $ parseErrorAt parseroff $-                   "No existing files match pattern: " ++ filename--    parseChild :: MonadIO m => SourcePos -> FilePath -> ErroringJournalParser m ()-    parseChild parentpos filepath = do-      parentj <- get--      let parentfilestack = jincludefilestack parentj-      when (filepath `elem` parentfilestack) $-        fail ("Cyclic include: " ++ filepath)--      childInput <- lift $ readFilePortably filepath-                            `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)-      let initChildj = newJournalWithParseStateFrom filepath parentj--      let parser = choiceInState-            [ journalp-            , timeclockfilep-            , timedotfilep-            ] -- can't include a csv file yet, that reader is special-      updatedChildj <- journalAddFile (filepath, childInput) <$>-                        parseIncludeFile parser initChildj filepath childInput--      -- discard child's parse info,  combine other fields-      put $ updatedChildj <> parentj--    newJournalWithParseStateFrom :: FilePath -> Journal -> Journal-    newJournalWithParseStateFrom filepath j = mempty{-      jparsedefaultyear      = jparsedefaultyear j-      ,jparsedefaultcommodity = jparsedefaultcommodity j-      ,jparseparentaccounts   = jparseparentaccounts j-      ,jparsealiases          = jparsealiases j-      ,jcommodities           = jcommodities j-      -- ,jparsetransactioncount = jparsetransactioncount j-      ,jparsetimeclockentries = jparsetimeclockentries j-      ,jincludefilestack      = filepath : jincludefilestack j-      }---- | Lift an IO action into the exception monad, rethrowing any IO--- error with the given message prepended.-orRethrowIOError :: MonadIO m => IO a -> String -> TextParser m a-orRethrowIOError io msg = do-  eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)-  case eResult of-    Right res -> pure res-    Left errMsg -> fail errMsg---- Parse an account directive, adding its info to the journal's--- list of account declarations.-accountdirectivep :: JournalParser m ()-accountdirectivep = do-  off <- getOffset -- XXX figure out a more precise position later--  string "account"-  lift (skipSome spacenonewline)--  -- the account name, possibly modified by preceding alias or apply account directives-  acct <- modifiedaccountnamep--  -- maybe an account type code (ALERX) after two or more spaces-  -- XXX added in 1.11, deprecated in 1.13, remove in 1.14-  mtypecode :: Maybe Char <- lift $ optional $ try $ do-    skipSome spacenonewline -- at least one more space in addition to the one consumed by modifiedaccountp -    choice $ map char "ALERX"--  -- maybe a comment, on this and/or following lines-  (cmt, tags) <- lift transactioncommentp-  -  -- maybe Ledger-style subdirectives (ignored)-  skipMany indentedlinep--  -- an account type may have been set by account type code or a tag;-  -- the latter takes precedence-  let-    mtypecode' :: Maybe Text = maybe-      (T.singleton <$> mtypecode)-      Just-      $ lookup accountTypeTagName tags-    metype = parseAccountTypeCode <$> mtypecode'--  -- update the journal-  addAccountDeclaration (acct, cmt, tags)-  case metype of-    Nothing         -> return ()-    Just (Right t)  -> addDeclaredAccountType acct t-    Just (Left err) -> customFailure $ parseErrorAt off err---- The special tag used for declaring account type. XXX change to "class" ?-accountTypeTagName = "type"--parseAccountTypeCode :: Text -> Either String AccountType-parseAccountTypeCode s =-  case T.toLower s of-    "asset"     -> Right Asset-    "a"         -> Right Asset-    "liability" -> Right Liability-    "l"         -> Right Liability-    "equity"    -> Right Equity-    "e"         -> Right Equity-    "revenue"   -> Right Revenue-    "r"         -> Right Revenue-    "expense"   -> Right Expense-    "x"         -> Right Expense-    _           -> Left err-  where-    err = "invalid account type code "++T.unpack s++", should be one of " ++-          (intercalate ", " $ ["A","L","E","R","X","ASSET","LIABILITY","EQUITY","REVENUE","EXPENSE"])---- Add an account declaration to the journal, auto-numbering it.-addAccountDeclaration :: (AccountName,Text,[Tag]) -> JournalParser m ()-addAccountDeclaration (a,cmt,tags) =-  modify' (\j ->-             let-               decls = jdeclaredaccounts j-               d     = (a, nullaccountdeclarationinfo{-                              adicomment          = cmt-                             ,aditags             = tags-                             ,adideclarationorder = length decls + 1-                             })-             in-               j{jdeclaredaccounts = d:decls})--indentedlinep :: JournalParser m String-indentedlinep = lift (skipSome spacenonewline) >> (rstrip <$> lift restofline)---- | Parse a one-line or multi-line commodity directive.------ >>> Right _ <- rjp commoditydirectivep "commodity $1.00"--- >>> Right _ <- rjp commoditydirectivep "commodity $\n  format $1.00"--- >>> Right _ <- rjp commoditydirectivep "commodity $\n\n" -- a commodity with no format--- >>> Right _ <- rjp commoditydirectivep "commodity $1.00\n  format $1.00" -- both, what happens ?-commoditydirectivep :: JournalParser m ()-commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultilinep---- | Parse a one-line commodity directive.------ >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00"--- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n"-commoditydirectiveonelinep :: JournalParser m ()-commoditydirectiveonelinep = do-  (off, Amount{acommodity,astyle}) <- try $ do-    string "commodity"-    lift (skipSome spacenonewline)-    off <- getOffset-    amount <- amountp-    pure $ (off, amount)-  lift (skipMany spacenonewline)-  _ <- lift followingcommentp-  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle}-  if asdecimalpoint astyle == Nothing-  then customFailure $ parseErrorAt off pleaseincludedecimalpoint-  else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})--pleaseincludedecimalpoint :: String-pleaseincludedecimalpoint = "to avoid ambiguity, please include a decimal separator in commodity directives"---- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.------ >>> Right _ <- rjp commoditydirectivemultilinep "commodity $ ; blah \n  format $1.00 ; blah"-commoditydirectivemultilinep :: JournalParser m ()-commoditydirectivemultilinep = do-  string "commodity"-  lift (skipSome spacenonewline)-  sym <- lift commoditysymbolp-  _ <- lift followingcommentp-  mformat <- lastMay <$> many (indented $ formatdirectivep sym)-  let comm = Commodity{csymbol=sym, cformat=mformat}-  modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})-  where-    indented = (lift (skipSome spacenonewline) >>)---- | Parse a format (sub)directive, throwing a parse error if its--- symbol does not match the one given.-formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle-formatdirectivep expectedsym = do-  string "format"-  lift (skipSome spacenonewline)-  off <- getOffset-  Amount{acommodity,astyle} <- amountp-  _ <- lift followingcommentp-  if acommodity==expectedsym-    then -      if asdecimalpoint astyle == Nothing-      then customFailure $ parseErrorAt off pleaseincludedecimalpoint-      else return $ dbg2 "style from format subdirective" astyle-    else customFailure $ parseErrorAt off $-         printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity--keywordp :: String -> JournalParser m ()-keywordp = (() <$) . string . fromString--spacesp :: JournalParser m ()-spacesp = () <$ lift (skipSome spacenonewline)---- | Backtracking parser similar to string, but allows varying amount of space between words-keywordsp :: String -> JournalParser m ()-keywordsp = try . sequence_ . intersperse spacesp . map keywordp . words--applyaccountdirectivep :: JournalParser m ()-applyaccountdirectivep = do-  keywordsp "apply account" <?> "apply account directive"-  lift (skipSome spacenonewline)-  parent <- lift accountnamep-  newline-  pushParentAccount parent--endapplyaccountdirectivep :: JournalParser m ()-endapplyaccountdirectivep = do-  keywordsp "end apply account" <?> "end apply account directive"-  popParentAccount--aliasdirectivep :: JournalParser m ()-aliasdirectivep = do-  string "alias"-  lift (skipSome spacenonewline)-  alias <- lift accountaliasp-  addAccountAlias alias--accountaliasp :: TextParser m AccountAlias-accountaliasp = regexaliasp <|> basicaliasp--basicaliasp :: TextParser m AccountAlias-basicaliasp = do-  -- dbgparse 0 "basicaliasp"-  old <- rstrip <$> (some $ noneOf ("=" :: [Char]))-  char '='-  skipMany spacenonewline-  new <- rstrip <$> anySingle `manyTill` eolof  -- eol in journal, eof in command lines, normally-  return $ BasicAlias (T.pack old) (T.pack new)--regexaliasp :: TextParser m AccountAlias-regexaliasp = do-  -- dbgparse 0 "regexaliasp"-  char '/'-  re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end-  char '/'-  skipMany spacenonewline-  char '='-  skipMany spacenonewline-  repl <- anySingle `manyTill` eolof-  return $ RegexAlias re repl--endaliasesdirectivep :: JournalParser m ()-endaliasesdirectivep = do-  keywordsp "end aliases" <?> "end aliases directive"-  clearAccountAliases--tagdirectivep :: JournalParser m ()-tagdirectivep = do-  string "tag" <?> "tag directive"-  lift (skipSome spacenonewline)-  _ <- lift $ some nonspace-  lift restofline-  return ()--endtagdirectivep :: JournalParser m ()-endtagdirectivep = do-  (keywordsp "end tag" <|> keywordp "pop") <?> "end tag or pop directive"-  lift restofline-  return ()--defaultyeardirectivep :: JournalParser m ()-defaultyeardirectivep = do-  char 'Y' <?> "default year"-  lift (skipMany spacenonewline)-  y <- some digitChar-  let y' = read y-  failIfInvalidYear y-  setYear y'--defaultcommoditydirectivep :: JournalParser m ()-defaultcommoditydirectivep = do-  char 'D' <?> "default commodity"-  lift (skipSome spacenonewline)-  off <- getOffset-  Amount{acommodity,astyle} <- amountp-  lift restofline-  if asdecimalpoint astyle == Nothing-  then customFailure $ parseErrorAt off pleaseincludedecimalpoint-  else setDefaultCommodityAndStyle (acommodity, astyle)--marketpricedirectivep :: JournalParser m MarketPrice-marketpricedirectivep = do-  char 'P' <?> "market price"-  lift (skipMany spacenonewline)-  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored-  lift (skipSome spacenonewline)-  symbol <- lift commoditysymbolp-  lift (skipMany spacenonewline)-  price <- amountp-  lift restofline-  return $ MarketPrice date symbol price--ignoredpricecommoditydirectivep :: JournalParser m ()-ignoredpricecommoditydirectivep = do-  char 'N' <?> "ignored-price commodity"-  lift (skipSome spacenonewline)-  lift commoditysymbolp-  lift restofline-  return ()--commodityconversiondirectivep :: JournalParser m ()-commodityconversiondirectivep = do-  char 'C' <?> "commodity conversion"-  lift (skipSome spacenonewline)-  amountp-  lift (skipMany spacenonewline)-  char '='-  lift (skipMany spacenonewline)-  amountp-  lift restofline-  return ()----- ** transactions--transactionmodifierp :: JournalParser m TransactionModifier-transactionmodifierp = do-  char '=' <?> "modifier transaction"-  lift (skipMany spacenonewline)-  querytxt <- lift $ T.strip <$> descriptionp-  (_comment, _tags) <- lift transactioncommentp   -- TODO apply these to modified txns ?-  postings <- postingsp Nothing-  return $ TransactionModifier querytxt postings---- | Parse a periodic transaction------ This reuses periodexprp which parses period expressions on the command line.--- This is awkward because periodexprp supports relative and partial dates, --- which we don't really need here, and it doesn't support the notion of a--- default year set by a Y directive, which we do need to consider here.--- We resolve it as follows: in periodic transactions' period expressions,--- if there is a default year Y in effect, partial/relative dates are calculated--- relative to Y/1/1. If not, they are calculated related to today as usual.-periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction-periodictransactionp = do--  -- first line-  char '~' <?> "periodic transaction"-  lift $ skipMany spacenonewline-  -- a period expression-  off <- getOffset-  -  -- if there's a default year in effect, use Y/1/1 as base for partial/relative dates-  today <- liftIO getCurrentDay-  mdefaultyear <- getYear-  let refdate = case mdefaultyear of-                  Nothing -> today -                  Just y  -> fromGregorian y 1 1-  periodExcerpt <- lift $ excerpt_ $-                    singlespacedtextsatisfyingp (\c -> c /= ';' && c /= '\n')-  let periodtxt = T.strip $ getExcerptText periodExcerpt--  -- first parsing with 'singlespacedtextp', then "re-parsing" with-  -- 'periodexprp' saves 'periodexprp' from having to respect the single--  -- and double-space parsing rules-  (interval, span) <- lift $ reparseExcerpt periodExcerpt $ do-    pexp <- periodexprp refdate-    (<|>) eof $ do-      offset1 <- getOffset-      void takeRest-      offset2 <- getOffset-      customFailure $ parseErrorAtRegion offset1 offset2 $-           "remainder of period expression cannot be parsed"-        <> "\nperhaps you need to terminate the period expression with a double space?"-        <> "\na double space is required between period expression and description/comment"-    pure pexp--  -- In periodic transactions, the period expression has an additional constraint:-  case checkPeriodicTransactionStartDate interval span periodtxt of-    Just e -> customFailure $ parseErrorAt off e-    Nothing -> pure ()-  -  status <- lift statusp <?> "cleared status"-  code <- lift codep <?> "transaction code"-  description <- lift $ T.strip <$> descriptionp-  (comment, tags) <- lift transactioncommentp-  -- next lines; use same year determined above-  postings <- postingsp (Just $ first3 $ toGregorian refdate)--  return $ nullperiodictransaction{-     ptperiodexpr=periodtxt-    ,ptinterval=interval-    ,ptspan=span-    ,ptstatus=status-    ,ptcode=code-    ,ptdescription=description-    ,ptcomment=comment-    ,pttags=tags-    ,ptpostings=postings-    }---- | Parse a (possibly unbalanced) transaction.-transactionp :: JournalParser m Transaction-transactionp = do-  -- dbgparse 0 "transactionp"-  startpos <- getSourcePos-  date <- datep <?> "transaction"-  edate <- optional (lift $ secondarydatep date) <?> "secondary date"-  lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"-  status <- lift statusp <?> "cleared status"-  code <- lift codep <?> "transaction code"-  description <- lift $ T.strip <$> descriptionp-  (comment, tags) <- lift transactioncommentp-  let year = first3 $ toGregorian date-  postings <- postingsp (Just year)-  endpos <- getSourcePos-  let sourcepos = journalSourcePos startpos endpos-  return $ txnTieKnot $ Transaction 0 "" sourcepos date edate status code description comment tags postings----- ** postings---- Parse the following whitespace-beginning lines as postings, posting--- tags, and/or comments (inferring year, if needed, from the given date).-postingsp :: Maybe Year -> JournalParser m [Posting]-postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"---- linebeginningwithspaces :: JournalParser m String--- linebeginningwithspaces = do---   sp <- lift (skipSome spacenonewline)---   c <- nonspace---   cs <- lift restofline---   return $ sp ++ (c:cs) ++ "\n"--postingp :: Maybe Year -> JournalParser m Posting-postingp mTransactionYear = do-  -- lift $ dbgparse 0 "postingp"-  (status, account) <- try $ do-    lift (skipSome spacenonewline)-    status <- lift statusp-    lift (skipMany spacenonewline)-    account <- modifiedaccountnamep-    return (status, account)-  let (ptype, account') = (accountNamePostingType account, textUnbracket account)-  lift (skipMany spacenonewline)-  amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp-  lift (skipMany spacenonewline)-  massertion <- optional $ balanceassertionp-  _ <- fixedlotpricep-  lift (skipMany spacenonewline)-  (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear-  return posting-   { pdate=mdate-   , pdate2=mdate2-   , pstatus=status-   , paccount=account'-   , pamount=amount-   , pcomment=comment-   , ptype=ptype-   , ptags=tags-   , pbalanceassertion=massertion-   }----- * tests--tests_JournalReader = tests "JournalReader" [--   let p = lift accountnamep :: JournalParser IO AccountName in-   tests "accountnamep" [-     test "basic" $ expectParse p "a:b:c"-    ,_test "empty inner component" $ expectParseError p "a::c" ""  -- TODO-    ,_test "empty leading component" $ expectParseError p ":b:c" "x"-    ,_test "empty trailing component" $ expectParseError p "a:b:" "x"-    ]--  -- "Parse a date in YYYY/MM/DD format.-  -- Hyphen (-) and period (.) are also allowed as separators.-  -- The year may be omitted if a default year has been set.-  -- Leading zeroes may be omitted."-  ,test "datep" $ do-    test "YYYY/MM/DD" $ expectParseEq datep "2018/01/01" (fromGregorian 2018 1 1)-    test "YYYY-MM-DD" $ expectParse datep "2018-01-01"-    test "YYYY.MM.DD" $ expectParse datep "2018.01.01"-    test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown"-    test "yearless date with default year" $ do -      let s = "1/1"-      ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s-      either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep-    test "no leading zero" $ expectParse datep "2018/1/1"--  ,test "datetimep" $ do-      let-        good = expectParse datetimep-        bad = (\t -> expectParseError datetimep t "")-      good "2011/1/1 00:00"-      good "2011/1/1 23:59:59"-      bad "2011/1/1"-      bad "2011/1/1 24:00:00"-      bad "2011/1/1 00:60:00"-      bad "2011/1/1 00:00:60"-      bad "2011/1/1 3:5:7"-      test "timezone is parsed but ignored" $ do-        let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 (fromIntegral 0))-        expectParseEq datetimep "2018/1/1 00:00-0800" t-        expectParseEq datetimep "2018/1/1 00:00+1234" t--  ,tests "periodictransactionp" [--    test "more period text in comment after one space" $ expectParseEq periodictransactionp-      "~ monthly from 2018/6 ;In 2019 we will change this\n" -      nullperiodictransaction {-         ptperiodexpr  = "monthly from 2018/6"-        ,ptinterval    = Months 1-        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing-        ,ptdescription = ""-        ,ptcomment     = "In 2019 we will change this\n"-        }--    ,test "more period text in description after two spaces" $ expectParseEq periodictransactionp-      "~ monthly from 2018/6   In 2019 we will change this\n" -      nullperiodictransaction {-         ptperiodexpr  = "monthly from 2018/6"-        ,ptinterval    = Months 1-        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing-        ,ptdescription = "In 2019 we will change this"-        ,ptcomment     = ""-        }--    ,test "Next year in description" $ expectParseEq periodictransactionp-      "~ monthly  Next year blah blah\n"-      nullperiodictransaction {-         ptperiodexpr  = "monthly"-        ,ptinterval    = Months 1-        ,ptspan        = DateSpan Nothing Nothing-        ,ptdescription = "Next year blah blah"-        ,ptcomment     = ""-        }--    ,test "Just date, no description" $ expectParseEq periodictransactionp-      "~ 2019-01-04\n"-      nullperiodictransaction {-         ptperiodexpr  = "2019-01-04"-        ,ptinterval    = NoInterval-        ,ptspan        = DateSpan (Just $ fromGregorian 2019 1 4) (Just $ fromGregorian 2019 1 5)-        ,ptdescription = ""-        ,ptcomment     = ""-        }--    ,test "Just date, no description + empty transaction comment" $ expectParse periodictransactionp-      "~ 2019-01-04\n  ;\n  a  1\n  b\n"--    ]--  ,tests "postingp" [-     test "basic" $ expectParseEq (postingp Nothing) -      "  expenses:food:dining  $10.00   ; a: a a \n   ; b: b b \n"-      posting{-        paccount="expenses:food:dining", -        pamount=Mixed [usd 10], -        pcomment="a: a a\nb: b b\n", -        ptags=[("a","a a"), ("b","b b")]-        }--    ,test "posting dates" $ expectParseEq (postingp Nothing) -      " a  1. ; date:2012/11/28, date2=2012/11/29,b:b\n"-      nullposting{-         paccount="a"-        ,pamount=Mixed [num 1]-        ,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"-        ,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily-        ,pdate=Just $ fromGregorian 2012 11 28-        ,pdate2=Nothing  -- Just $ fromGregorian 2012 11 29-        }--    ,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing) -      " a  1. ; [2012/11/28=2012/11/29]\n"-      nullposting{-         paccount="a"-        ,pamount=Mixed [num 1]-        ,pcomment="[2012/11/28=2012/11/29]\n"-        ,ptags=[]-        ,pdate= Just $ fromGregorian 2012 11 28 -        ,pdate2=Just $ fromGregorian 2012 11 29-        }--    ,test "quoted commodity symbol with digits" $ expectParse (postingp Nothing) "  a  1 \"DE123\"\n"--    ,test "balance assertion and fixed lot price" $ expectParse (postingp Nothing) "  a  1 \"DE123\" =$1 { =2.2 EUR} \n"--    ,test "balance assertion over entire contents of account" $ expectParse (postingp Nothing) "  a  $1 == $1\n"-    ]--  ,tests "transactionmodifierp" [--    test "basic" $ expectParseEq transactionmodifierp -      "= (some value expr)\n some:postings  1.\n"-      nulltransactionmodifier {-        tmquerytxt = "(some value expr)"-       ,tmpostingrules = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}]-      }-    ]--  ,tests "transactionp" [-  -     test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}-  -    ,test "more complex" $ expectParseEq transactionp -      (T.unlines [-        "2012/05/14=2012/05/15 (code) desc  ; tcomment1",-        "    ; tcomment2",-        "    ; ttag1: val1",-        "    * a         $1.00  ; pcomment1",-        "    ; pcomment2",-        "    ; ptag1: val1",-        "    ; ptag2: val2"-        ])-      nulltransaction{-        tsourcepos=JournalSourcePos "" (1,7),  -- XXX why 7 here ?-        tprecedingcomment="",-        tdate=fromGregorian 2012 5 14,-        tdate2=Just $ fromGregorian 2012 5 15,-        tstatus=Unmarked,-        tcode="code",-        tdescription="desc",-        tcomment="tcomment1\ntcomment2\nttag1: val1\n",-        ttags=[("ttag1","val1")],-        tpostings=[-          nullposting{-            pdate=Nothing,-            pstatus=Cleared,-            paccount="a",-            pamount=Mixed [usd 1],-            pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",-            ptype=RegularPosting,-            ptags=[("ptag1","val1"),("ptag2","val2")],-            ptransaction=Nothing-            }-          ]-      }-  -    ,test "parses a well-formed transaction" $-      expect $ isRight $ rjp transactionp $ T.unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries                   $47.18"-        ,"    assets:checking                          $-47.18"-        ,""-        ]-  -    ,test "does not parse a following comment as part of the description" $-      expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"-  -    ,test "transactionp parses a following whitespace line" $-      expect $ isRight $ rjp transactionp $ T.unlines-        ["2012/1/1"-        ,"  a  1"-        ,"  b"-        ," "-        ]--    ,test "transactionp parses an empty transaction comment following whitespace line" $-      expect $ isRight $ rjp transactionp $ T.unlines-        ["2012/1/1"-        ,"  ;"-        ,"  a  1"-        ,"  b"-        ," "-        ]--    ,test "comments everywhere, two postings parsed" $-      expectParseEqOn transactionp -        (T.unlines-          ["2009/1/1 x  ; transaction comment"-          ," a  1  ; posting 1 comment"-          ," ; posting 1 comment 2"-          ," b"-          ," ; posting 2 comment"-          ])-        (length . tpostings)-        2-  -    ]--  -- directives--  ,tests "directivep" [-    test "supports !" $ do -      expectParseE directivep "!account a\n"-      expectParseE directivep "!D 1.0\n"-    ]--  ,test "accountdirectivep" $ do-    test "with-comment"       $ expectParse accountdirectivep "account a:b  ; a comment\n"-    test "does-not-support-!" $ expectParseError accountdirectivep "!account a:b\n" ""-    test "account-type-code"  $ expectParse accountdirectivep "account a:b  A\n"-    test "account-type-tag"   $ expectParseStateOn accountdirectivep "account a:b  ; type:asset\n"-      jdeclaredaccounts-      [("a:b", AccountDeclarationInfo{adicomment          = "type:asset\n"-                                     ,aditags             = [("type","asset")]-                                     ,adideclarationorder = 1-                                     })-      ]--  ,test "commodityconversiondirectivep" $ do-     expectParse commodityconversiondirectivep "C 1h = $50.00\n"--  ,test "defaultcommoditydirectivep" $ do-     expectParse defaultcommoditydirectivep "D $1,000.0\n"-     expectParseError defaultcommoditydirectivep "D $1000\n" "please include a decimal separator"--  ,test "defaultyeardirectivep" $ do-    test "1000" $ expectParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others-    test "999" $ expectParseError defaultyeardirectivep "Y 999" "bad year number"-    test "12345" $ expectParse defaultyeardirectivep "Y 12345"--  ,test "ignoredpricecommoditydirectivep" $ do-     expectParse ignoredpricecommoditydirectivep "N $\n"--  ,test "includedirectivep" $ do-    test "include" $ expectParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"-    test "glob" $ expectParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"--  ,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep-    "P 2017/01/30 BTC $922.83\n"-    MarketPrice{-      mpdate      = fromGregorian 2017 1 30,-      mpcommodity = "BTC",-      mpamount    = usd 922.83-      }--  ,test "tagdirectivep" $ do-     expectParse tagdirectivep "tag foo \n"--  ,test "endtagdirectivep" $ do-     expectParse endtagdirectivep "end tag \n"-     expectParse endtagdirectivep "pop \n"---  ,tests "journalp" [-    test "empty file" $ expectParseEqE journalp "" nulljournal-    ]--   -- these are defined here rather than in Common so they can use journalp-  ,tests "parseAndFinaliseJournal" [-    test "basic" $ do-        ej <- io $ runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n"-        let Right j = ej-        expectEqPP [""] $ journalFilePaths j-   ]+--- * -*- outline-regexp:"--- *"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.+{-|++A reader for hledger's journal file format+(<http://hledger.org/hledger.html#the-journal-file>).  hledger's journal+format is a compatible subset of c++ ledger's+(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this+reader should handle many ledger files as well. Example:++@+2012\/3\/24 gift+    expenses:gifts  $10+    assets:cash+@++Journal format supports the include directive which can read files in+other formats, so the other file format readers need to be importable+and invocable here.++Some important parts of journal parsing are therefore kept in+Hledger.Read.Common, to avoid import cycles.++-}++--- ** language++{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE NoMonoLocalBinds    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}++--- ** exports+module Hledger.Read.JournalReader (++  -- * Reader-finding utils+  findReader,+  splitReaderPrefix,++  -- * Reader+  reader,++  -- * Parsing utils+  parseAndFinaliseJournal,+  runJournalParser,+  rjp,+  runErroringJournalParser,+  rejp,++  -- * Parsers used elsewhere+  getParentAccount,+  journalp,+  directivep,+  defaultyeardirectivep,+  marketpricedirectivep,+  datetimep,+  datep,+  modifiedaccountnamep,+  tmpostingrulep,+  statusp,+  emptyorcommentlinep,+  followingcommentp,+  accountaliasp++  -- * Tests+  ,tests_JournalReader+)+where++--- ** imports+import Control.Exception qualified as C+import Control.Monad (forM_, when, void, unless, filterM, forM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Except (ExceptT(..), runExceptT)+import Control.Monad.State.Strict (evalStateT,get,modify',put)+import Control.Monad.Trans.Class (lift)+import Data.Char (toLower)+import Data.Either (isRight, lefts)+import Data.Functor ((<&>))+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Data.String+import Data.List+import Data.Maybe+import Data.Text qualified as T+import Data.Time.Calendar+import Data.Time.LocalTime+import Safe+import Text.Megaparsec hiding (parse)+import Text.Megaparsec.Char+import Text.Printf+import System.Directory (canonicalizePath, doesFileExist, makeAbsolute)+import System.FilePath+import "Glob" System.FilePath.Glob hiding (match)+-- import "filepattern" System.FilePattern.Directory++import Hledger.Data+import Hledger.Read.Common+import Hledger.Utils++import Hledger.Read.CsvReader qualified as CsvReader (reader)+import Hledger.Read.RulesReader qualified as RulesReader (reader)+import Hledger.Read.TimeclockReader qualified as TimeclockReader (reader)+import Hledger.Read.TimedotReader qualified as TimedotReader (reader)+import Data.Function ((&))++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings+--+--- ** parsing utilities++-- | Run a journal parser in some monad. See also: parseWithState.+runJournalParser, rjp+  :: Monad m+  => JournalParser m a -> Text -> m (Either HledgerParseErrors a)+runJournalParser p = runParserT (evalStateT p nulljournal) ""+rjp = runJournalParser++-- | Run an erroring journal parser in some monad. See also: parseWithState.+runErroringJournalParser, rejp+  :: Monad m+  => ErroringJournalParser m a+  -> Text+  -> m (Either FinalParseError (Either HledgerParseErrors a))+runErroringJournalParser p t =+  runExceptT $ runParserT (evalStateT p nulljournal) "" t+rejp = runErroringJournalParser+++--- ** reader finding utilities+-- Defined here rather than Hledger.Read so that we can use them in includedirectivep below.++-- The available journal readers, each one handling a particular data format.+readers' :: MonadIO m => [Reader m]+readers' = [+  reader+ ,TimeclockReader.reader+ ,TimedotReader.reader+ ,RulesReader.reader+ ,CsvReader.reader Csv+ ,CsvReader.reader Tsv+ ,CsvReader.reader Ssv+--  ,LedgerReader.reader+ ]++readerNames :: [String]+readerNames = map (show . rFormat) (readers'::[Reader IO])++-- | @findReader mformat mpath@+--+-- Find the reader named by @mformat@, if provided.+-- ("ssv" and "tsv" are recognised as alternate names for the csv reader,+-- which also handles those formats.)+-- Or, if a file path is provided, find the first reader that handles+-- its file extension, if any.+findReader :: MonadIO m => Maybe StorageFormat -> Maybe FilePath -> Maybe (Reader m)+findReader Nothing Nothing     = Nothing+findReader (Just fmt) _        = headMay [r | r <- readers', let rname = rFormat r, rname == fmt]+findReader Nothing (Just path) =+  case prefix of+    Just fmt -> headMay [r | r <- readers', rFormat r == fmt]+    Nothing  -> headMay [r | r <- readers', ext `elem` rExtensions r]+  where+    (prefix,path') = splitReaderPrefix path+    ext            = map toLower $ drop 1 $ takeExtension path'++-- | Separate a file path and its reader prefix, if any.+--+-- >>> splitReaderPrefix "csv:-"+-- (Just csv,"-")+splitReaderPrefix :: PrefixedFilePath -> (Maybe StorageFormat, FilePath)+splitReaderPrefix f =+  let +    candidates = [(Just r, drop (length r + 1) f) | r <- readerNames ++ ["ssv","tsv"], (r++":") `isPrefixOf` f]+    (strPrefix, newF) = headDef (Nothing, f) candidates+  in case strPrefix of+    Just "csv" -> (Just (Sep Csv), newF)+    Just "tsv" -> (Just (Sep Tsv), newF)+    Just "ssv" -> (Just (Sep Ssv), newF)+    Just "journal" -> (Just Journal', newF)+    Just "timeclock" -> (Just Timeclock, newF)+    Just "timedot" -> (Just Timedot, newF)+    _ -> (Nothing, f)++-- -- | Does this file path have a reader prefix ?+-- hasReaderPrefix :: PrefixedFilePath -> Bool+-- hasReaderPrefix = isJust . fst. splitReaderPrefix++-- -- | Add a reader prefix to a file path, unless it already has one.+-- -- The argument should be a valid reader name.+-- --+-- -- >>> addReaderPrefix "csv" "a.txt"+-- -- >>> "csv:a.txt"+-- -- >>> addReaderPrefix "csv" "timedot:a.txt"+-- -- >>> "timedot:a.txt"+-- addReaderPrefix :: ReaderPrefix -> FilePath -> PrefixedFilePath+-- addReaderPrefix readername f+--   | hasReaderPrefix f = f+--   | otherwise = readername <> ":" <> f++--- ** reader++reader :: MonadIO m => Reader m+reader = Reader+  {rFormat     = Journal'+  ,rExtensions = ["journal", "j", "hledger", "ledger"]+  ,rReadFn     = handleReadFnToTextReadFn parse+  ,rParser    = journalp  -- no need to add command line aliases like journalp'+                           -- when called as a subparser I think+  }++-- | Parse and post-process a "Journal" from hledger's journal file+-- format, or give an error.+parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal+parse iopts f = parseAndFinaliseJournal journalp' iopts f+  where+    journalp' = do+      -- reverse parsed aliases to ensure that they are applied in order given on commandline+      mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)+      journalp iopts++--- ** parsers+--- *** journal++-- | A journal parser. Accumulates and returns a "ParsedJournal",+-- which should be finalised/validated before use.+--+-- >>> rejp (journalp definputopts <* eof) "2015/1/1\n a  0\n"+-- Right (Right Journal (unknown) with 1 transactions, 1 accounts)+--+journalp :: MonadIO m => InputOpts -> ErroringJournalParser m ParsedJournal+journalp iopts = do+  many $ addJournalItemP iopts+  eof+  get++-- | A side-effecting parser; parses any kind of journal item+-- and updates the parse state accordingly.+addJournalItemP :: MonadIO m => InputOpts -> ErroringJournalParser m ()+addJournalItemP iopts =+  -- all journal line types can be distinguished by the first+  -- character, can use choice without backtracking+  choice [+      directivep iopts+    , transactionp          >>= modify' . addTransaction+    , transactionmodifierp  >>= modify' . addTransactionModifier+    , periodictransactionp  >>= modify' . addPeriodicTransaction+    , marketpricedirectivep >>= modify' . addPriceDirective+    , void (lift emptyorcommentlinep)+    , void (lift multilinecommentp)+    ] <?> "transaction or directive"++--- *** directives++-- | Parse any journal directive and update the parse state accordingly.+-- Cf http://hledger.org/hledger.html#directives,+-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives+directivep :: MonadIO m => InputOpts -> ErroringJournalParser m ()+directivep iopts = (do+  optional $ oneOf ['!','@']+  choice [+    includedirectivep iopts+   ,aliasdirectivep+   ,endaliasesdirectivep+   ,accountdirectivep+   ,applyaccountdirectivep+   ,applyfixeddirectivep+   ,applytagdirectivep+   ,assertdirectivep+   ,bucketdirectivep+   ,capturedirectivep+   ,checkdirectivep+   ,commandlineflagdirectivep+   ,commoditydirectivep+   ,commodityconversiondirectivep+   ,decimalmarkdirectivep+   ,defaultyeardirectivep+   ,defaultcommoditydirectivep+   ,definedirectivep+   ,endapplyaccountdirectivep+   ,endapplyfixeddirectivep+   ,endapplytagdirectivep+   ,endapplyyeardirectivep+   ,endtagdirectivep+   ,evaldirectivep+   ,exprdirectivep+   ,ignoredpricecommoditydirectivep+   ,payeedirectivep+   ,pythondirectivep+   ,tagdirectivep+   ,valuedirectivep+   ]+  ) <?> "directive"++-- | Parse an include directive, and the file(s) it refers to, possibly recursively.+-- Input options are required since they may affect parsing (of timeclock files, specifically).+-- include's argument is a file path or glob pattern (see findMatchedFiles for details),+-- optionally with a file type prefix. Relative paths are relative to the current file.+includedirectivep :: MonadIO m => InputOpts -> ErroringJournalParser m ()+includedirectivep iopts = do+  -- save the position at start of include directive, for error messages+  eoff <- getOffset+  pos <- getSourcePos+  let errorNoArg = customFailure $ parseErrorAt eoff "include needs a file path or glob pattern argument"++  -- parse the directive+  string "include"+  -- notFollowedBy newline <?> "a file path or glob pattern argument"+  prefixedglob <- (do+    lift skipNonNewlineSpaces1+    prefixedglob <- rstrip . T.unpack <$> takeWhileP Nothing (`notElem` [';','\n'])+    lift followingcommentp+    return prefixedglob+    ) <|> errorNoArg++  let (mprefix,path) = splitReaderPrefix prefixedglob+  parentf <- sourcePosFilePath pos+  when (null $ dbg6 (parentf <> " include: path ") path) errorNoArg++  -- Find the file or glob-matched files (just the ones from this include directive), with some IO error checking.+  paths <- findMatchedFiles eoff parentf path+  -- Also report whether a glob pattern was used, and not just a literal file path.+  -- (paths, isglob) <- findMatchedFiles off pos glb++  -- XXX worth the trouble ? no+  -- Comprehensively exclude files already processed. Some complexities here:+  -- If this include directive uses a glob pattern, remove duplicates. +  -- Ie if this glob pattern matches any files we have already processed (or the current file),+  -- due to multiple includes in sequence or in a cycle, exclude those files so they're not processed again.+  -- If this include directive uses a literal file path, don't remove duplicates.+  -- Multiple includes in sequence will cause the included file to be processed multiple times.+  -- Multiple includes forming a cycle will be detected and reported as an error in parseIncludedFile.+  -- let paths' = if isglob then filter (...) paths else paths++  -- if there was a reader prefix, apply it to all the file paths+  let prefixedpaths = case mprefix of+        Nothing  -> paths+        Just fmt -> map ((show fmt++":")++) paths++  -- Parse each one, as if inlined here.+  forM_ prefixedpaths $ parseIncludedFile iopts eoff++  where++    -- | Find the files matched by a literal path or a glob pattern.+    -- Examples: foo.j, ../foo/bar.j, timedot:/foo/2020*, *.journal, **.journal.+    --+    -- Uses the current parse context for detecting the current directory and for error messages.+    -- Expands a leading tilde to the user's home directory.+    -- Converts ** without a slash to **/*, like zsh's GLOB_STAR_SHORT, so ** also matches file name parts.+    -- Checks if any matched paths are directories and excludes those.+    -- Converts all matched paths to their canonical form.+    -- Note * and ** mostly won't implicitly match dot files or dot directories,+    -- but ** will implicitly search non-top-level dot directories (see #2498, Glob#49).++    findMatchedFiles :: (MonadIO m) => Int -> FilePath -> FilePath -> JournalParser m [FilePath]+    findMatchedFiles off parentf path = do++      -- Some notes about the Glob library that we use (related: https://github.com/Deewiant/glob/issues/49):+      -- It does not expand tilde.+      -- It does not canonicalise paths.+      -- The results are not in any particular order.+      -- The results can include directories.+      -- DIRPAT/ is equivalent to DIRPAT, except results will end with // (double slash).+      -- A . or .. path component can match the current or parent directories (including them in the results).+      -- * matches zero or more characters in a file or directory name.+      -- * at the start of a file name ignores dot-named files and directories, by default.+      -- ** (or zero or more consecutive *'s) not followed by slash is equivalent to *.+      -- A **/ component matches any number of directory parts.+      -- A **/ does not implicitly search top-level dot directories or implicitly match do files,+      -- but it does search non-top-level dot directories. Eg ** will find the c file in a/.b/c.+      -- It tends to get attributes of all files in a directory.++      -- expand a tilde at the start of the glob pattern, or throw an error+      expandedpath <- lift $ expandHomePath path & handleIOError off "failed to expand ~"++      -- get the directory of the including file+      -- need to canonicalise a symlink parentf so takeDirectory works correctly [#2503]+      cwd <- fmap takeDirectory <$> liftIO $ canonicalizePath parentf++      -- Don't allow 3 or more stars.+      when ("***" `isInfixOf` expandedpath) $+        customFailure $ parseErrorAt off $ "Invalid glob pattern: too many stars, use * or **"++      -- Make ** also match file name parts like zsh's GLOB_STAR_SHORT.+      let+        finalpath =+          -- ** without a slash is equivalent to **/*+          case regexReplace (toRegex' $ T.pack "\\*\\*([^/\\])") "**/*\\1" expandedpath of+            Right s -> s+            Left  _ -> expandedpath   -- ignore any error, there should be none++      -- Compile as a Pattern. Can throw an error.+      pat <- case tryCompileWith compDefault{errorRecovery=False} finalpath of+        Left e  -> customFailure $ parseErrorAt off $ "Invalid glob pattern: " ++ e+        Right x -> pure x++      -- Find all paths matched by the glob pattern.+      -- If it is a literal (non-glob) path, don't use the Glob lib, because it gets attributes+      -- of all files in the directory, which confuses build systems like tup.+      paths <-+        if isLiteral pat+        then return $ if isAbsolute finalpath then [finalpath] else [cwd </> finalpath]+        else liftIO $ globDir1 pat cwd++      -- Exclude any directories or symlinks to directories, and canonicalise, and sort.+      files <- liftIO $+        filterM doesFileExist paths+        >>= mapM makeAbsolute+        <&> sort++      -- Throw an error if one of these files is among the grandparent files, forming a cycle.+      -- Though, ignore the immediate parent file for convenience. XXX inconsistent - should it ignore all cyclic includes ?+      -- Use canonical paths for cycle detection, show nominal absolute paths in error messages.+      parentj <- get+      let parentfiles = jincludefilestack parentj+          cparentfiles = map snd parentfiles+          cparentf = take 1 cparentfiles+      files2 <- forM files $ \f -> do+        cf <- liftIO $ canonicalizePath f+        if+          | [cf] == cparentf -> return cf  -- current file - return canonicalised, will be excluded later+          | cf `elem` drop 1 cparentfiles -> customFailure $ parseErrorAt off $ "This included file forms a cycle: " ++ f+          | otherwise -> return f++      -- Throw an error if no files were matched.+      when (null files2) $ customFailure $ parseErrorAt off $ "No files were matched by: " ++ path++      -- If the current file got included, ignore it (last, to avoid triggering the error above).+      let+        files3 =+          dbg6 (parentf <> " include: matched files (excluding current file)") $+          filter (not.(`elem` cparentf)) files2++      return files3++    -- Parse the given included file (and any deeper includes, recursively) as if it was inlined in the current (parent) file.+    -- The offset of the start of the include directive in the parent file is provided for error messages.+    parseIncludedFile :: MonadIO m => InputOpts -> Int -> PrefixedFilePath -> ErroringJournalParser m ()+    parseIncludedFile iopts1 off prefixedpath = do+      let (_mprefix,filepath) = splitReaderPrefix prefixedpath++      -- Read the file's content, or throw an error+      childInput <- lift $ readFilePortably filepath & handleIOError off "failed to read a file"+      cfilepath <- liftIO $ canonicalizePath filepath+      parentj <- get+      let initChildj = newJournalWithParseStateFrom filepath cfilepath parentj++      -- Choose a reader based on the file path prefix or file extension,+      -- defaulting to JournalReader. Duplicating readJournal a bit here.+      let r = fromMaybe reader $ findReader Nothing (Just prefixedpath)+          parser = (rParser r) iopts1+      dbg7IO "parseIncludedFile: trying reader" (rFormat r)++      -- Parse the file (and its own includes, if any) to a Journal+      -- with file path and source text attached. Or throw an error.+      updatedChildj <- journalAddFile (filepath, childInput) <$>+                        parseIncludeFile parser initChildj filepath childInput++      -- Child journal was parsed successfully; now merge it into the parent journal.+      -- Debug logging is provided for troubleshooting account display order (eg).+      -- The parent journal is the second argument to journalConcat; this means+      -- its parse state is kept, and its lists are appended to child's (which+      -- ultimately produces the right list order, because parent's and child's+      -- lists are in reverse order at this stage. Cf #1909)+      let+        parentj' =+          dbgJournalAcctDeclOrder ("parseChild: child " <> childfilename <> " acct decls: ") updatedChildj+          `journalConcat`+          dbgJournalAcctDeclOrder ("parseChild: parent " <> parentfilename <> " acct decls: ") parentj++          where+            childfilename = takeFileName filepath+            parentfilename = maybe "(unknown)" takeFileName $ fmap fst $ headMay $ jincludefilestack parentj  -- XXX more accurate than journalFilePath for some reason++      -- And update the current parse state.+      put parentj'++      where+        newJournalWithParseStateFrom :: FilePath -> FilePath -> Journal -> Journal+        newJournalWithParseStateFrom filepath cfilepath j = nulljournal{+          jparsedefaultyear      = jparsedefaultyear j+          ,jparsedefaultcommodity = jparsedefaultcommodity j+          ,jparseparentaccounts   = jparseparentaccounts j+          ,jparsedecimalmark      = jparsedecimalmark j+          ,jparsealiases          = jparsealiases j+          ,jdeclaredcommodities           = jdeclaredcommodities j+          -- ,jparsetransactioncount = jparsetransactioncount j+          ,jparsetimeclockentries = jparsetimeclockentries j+          ,jincludefilestack      = (filepath, cfilepath) : jincludefilestack j+          }++-- Get the absolute path of the file referenced by this parse position.+-- (Symbolic links will not be dereferenced.)+-- This probably will always succeed, since the parse file's path is probably always absolute.+sourcePosFilePath :: (MonadIO m) => SourcePos -> m FilePath+sourcePosFilePath = liftIO . makeAbsolute . sourceName++-- | Lift an IO action into the exception monad, converting any IO error+-- to a parse error message at the given offset.+handleIOError :: MonadIO m => Int -> String -> IO a -> TextParser m a+handleIOError off msg io = do+  eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)+  case eResult of+    Right res -> pure res+    Left errMsg -> setOffset off >> fail errMsg++-- Parse an account directive, adding its info to the journal's+-- list of account declarations.+accountdirectivep :: JournalParser m ()+accountdirectivep = do+  off <- getOffset -- XXX figure out a more precise position later+  pos <- getSourcePos++  string "account"+  lift skipNonNewlineSpaces1++  -- the account name, possibly modified by preceding alias or apply account directives+  acct <- (notFollowedBy (char '(' <|> char '[') <?> "account name without brackets") >>+          modifiedaccountnamep True++  -- maybe a comment, on this and/or following lines+  (cmt, tags) <- lift transactioncommentp++  -- maybe Ledger-style subdirectives (ignored)+  skipMany indentedlinep++  -- an account type may have been set by account type code or a tag;+  -- the latter takes precedence+  let+    metype = parseAccountTypeCode <$> lookup accountTypeTagName tags++  -- update the journal+  addAccountDeclaration (acct, cmt, tags, pos)+  unless (null tags) $ addDeclaredAccountTags acct tags+  case metype of+    Nothing         -> return ()+    Just (Right t)  -> addDeclaredAccountType acct t+    Just (Left err) -> customFailure $ parseErrorAt off err++-- The special tag used for declaring account type. XXX change to "class" ?+accountTypeTagName = "type"++parseAccountTypeCode :: Text -> Either String AccountType+parseAccountTypeCode s =+  case T.toLower s of+    "asset"            -> Right Asset+    "a"                -> Right Asset+    "liability"        -> Right Liability+    "l"                -> Right Liability+    "equity"           -> Right Equity+    "e"                -> Right Equity+    "revenue"          -> Right Revenue+    "r"                -> Right Revenue+    "expense"          -> Right Expense+    "x"                -> Right Expense+    "cash"             -> Right Cash+    "c"                -> Right Cash+    "conversion"       -> Right Conversion+    "v"                -> Right Conversion+    "gain"             -> Right Gain+    "g"                -> Right Gain+    "unrealisedgain"   -> Right UnrealisedGain+    "u"                -> Right UnrealisedGain+    _                  -> Left err+  where+    err = T.unpack $ "invalid account type code "<>s<>", should be one of " <>+            T.intercalate ", " ["A","L","E","R","X","C","V","G","U","Asset","Liability","Equity","Revenue","Expense","Cash","Conversion","Gain","UnrealisedGain"]++-- Add an account declaration to the journal, auto-numbering it.+addAccountDeclaration :: (AccountName,Text,[Tag],SourcePos) -> JournalParser m ()+addAccountDeclaration (a,cmt,tags,pos) = do+  modify' (\j ->+             let+               decls = jdeclaredaccounts j+               d     = (a, nullaccountdeclarationinfo{+                              adicomment          = cmt+                             ,aditags             = tags+                             ,adideclarationorder = length decls + 1  -- gets renumbered when Journals are finalised or merged+                             ,adisourcepos        = pos+                             })+             in+               j{jdeclaredaccounts = d:decls})++-- Add a payee declaration to the journal.+addPayeeDeclaration :: (Payee,Text,[Tag]) -> JournalParser m ()+addPayeeDeclaration (p, cmt, tags) =+  modify' (\j@Journal{jdeclaredpayees} -> j{jdeclaredpayees=d:jdeclaredpayees})+             where+               d = (p+                   ,nullpayeedeclarationinfo{+                     pdicomment = cmt+                    ,pditags    = tags+                    })++-- Add a tag declaration to the journal.+addTagDeclaration :: (TagName,Text) -> JournalParser m ()+addTagDeclaration (t, cmt) =+  modify' (\j@Journal{jdeclaredtags} -> j{jdeclaredtags=tagandinfo:jdeclaredtags})+  where+    tagandinfo = (t, nulltagdeclarationinfo{tdicomment=cmt})++indentedlinep :: JournalParser m String+indentedlinep = lift skipNonNewlineSpaces1 >> (rstrip <$> lift restofline)++-- | Parse a one-line or multi-line commodity directive.+--+-- >>> Right _ <- rjp commoditydirectivep "commodity $1.00"+-- >>> Right _ <- rjp commoditydirectivep "commodity $\n  format $1.00"+-- >>> Right _ <- rjp commoditydirectivep "commodity $\n\n" -- a commodity with no format+-- >>> Right _ <- rjp commoditydirectivep "commodity $1.00\n  format $1.00" -- both, what happens ?+commoditydirectivep :: JournalParser m ()+commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultilinep++-- | Parse a one-line commodity directive.+--+-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00"+-- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n"+commoditydirectiveonelinep :: JournalParser m ()+commoditydirectiveonelinep = do+  (off, Amount{acommodity,astyle}) <- try $ do+    string "commodity"+    lift skipNonNewlineSpaces1+    off <- getOffset+    amt <- amountp+    pure $ (off, amt)+  lift skipNonNewlineSpaces+  (comment, tags) <- lift transactioncommentp+  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg7 "style from commodity directive" astyle, ccomment=comment, ctags=tags}+  if isNothing $ asdecimalmark astyle+  then customFailure $ parseErrorAt off pleaseincludedecimalpoint+  else modify' (\j -> j{jdeclaredcommodities=M.insert acommodity comm $ jdeclaredcommodities j+                       ,jdeclaredcommoditytags=if null tags then jdeclaredcommoditytags j+                                               else M.insert acommodity tags $ jdeclaredcommoditytags j})++pleaseincludedecimalpoint :: String+pleaseincludedecimalpoint = chomp $ unlines [+   "Please include a decimal point or decimal comma in commodity directives,"+  ,"to help us parse correctly. It may be followed by zero or more decimal digits."+  ,"Examples:"+  ,"commodity $1000.            ; no thousands mark, decimal period, no decimals"+  ,"commodity 1.234,00 ARS      ; period at thousands, decimal comma, 2 decimals"+  ,"commodity EUR 1 000,000     ; space at thousands, decimal comma, 3 decimals"+  ,"commodity INR1,23,45,678.0  ; comma at thousands/lakhs/crores, decimal period, 1 decimal"+  ]++-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.+--+-- >>> Right _ <- rjp commoditydirectivemultilinep "commodity $ ; blah \n  format $1.00 ; blah"+commoditydirectivemultilinep :: JournalParser m ()+commoditydirectivemultilinep = do+  string "commodity"+  lift skipNonNewlineSpaces1+  sym <- lift commoditysymbolp+  (comment, tags) <- lift transactioncommentp+  -- read all subdirectives, saving format subdirectives as Lefts+  subdirectives <- many $ indented (eitherP (formatdirectivep sym) (lift restofline))+  let mfmt = lastMay $ lefts subdirectives+  let comm = Commodity{csymbol=sym, cformat=mfmt, ccomment=comment, ctags=tags}+  modify' (\j -> j{jdeclaredcommodities=M.insert sym comm $ jdeclaredcommodities j+                  ,jdeclaredcommoditytags=if null tags then jdeclaredcommoditytags j+                                          else M.insert sym tags $ jdeclaredcommoditytags j})+  where+    indented = (lift skipNonNewlineSpaces1 >>)++-- | Parse a format (sub)directive, throwing a parse error if its+-- symbol does not match the one given.+formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle+formatdirectivep expectedsym = do+  string "format"+  lift skipNonNewlineSpaces1+  off <- getOffset+  Amount{acommodity,astyle} <- amountp+  _ <- lift followingcommentp+  if acommodity==expectedsym+    then+      if isNothing $ asdecimalmark astyle+      then customFailure $ parseErrorAt off pleaseincludedecimalpoint+      else return $ dbg7 "style from format subdirective" astyle+    else customFailure $ parseErrorAt off $+         printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity++-- More Ledger directives, ignore for now:+-- apply fixed, apply tag, assert, bucket, A, capture, check, define, expr+applyfixeddirectivep, endapplyfixeddirectivep, applytagdirectivep, endapplytagdirectivep,+  assertdirectivep, bucketdirectivep, capturedirectivep, checkdirectivep, +  endapplyyeardirectivep, definedirectivep, exprdirectivep, valuedirectivep,+  evaldirectivep, pythondirectivep, commandlineflagdirectivep+  :: JournalParser m ()+applyfixeddirectivep    = do string "apply fixed" >> lift restofline >> return ()+endapplyfixeddirectivep = do string "end apply fixed" >> lift restofline >> return ()+applytagdirectivep      = do string "apply tag" >> lift restofline >> return ()+endapplytagdirectivep   = do string "end apply tag" >> lift restofline >> return ()+endapplyyeardirectivep  = do string "end apply year" >> lift restofline >> return ()+assertdirectivep        = do string "assert"  >> lift restofline >> return ()+bucketdirectivep        = do string "A " <|> string "bucket " >> lift restofline >> return ()+capturedirectivep       = do string "capture" >> lift restofline >> return ()+checkdirectivep         = do string "check"   >> lift restofline >> return ()+definedirectivep        = do string "define"  >> lift restofline >> return ()+exprdirectivep          = do string "expr"    >> lift restofline >> return ()+valuedirectivep         = do string "value"   >> lift restofline >> return ()+evaldirectivep          = do string "eval"   >> lift restofline >> return ()+commandlineflagdirectivep = do string "--" >> lift restofline >> return ()+pythondirectivep = do+  string "python" >> lift restofline+  many $ indentedline <|> blankline+  return ()+  where+    indentedline = lift skipNonNewlineSpaces1 >> lift restofline+    blankline = lift skipNonNewlineSpaces >> newline >> return "" <?> "blank line"++keywordp :: String -> JournalParser m ()+keywordp = void . string . fromString++spacesp :: JournalParser m ()+spacesp = void $ lift skipNonNewlineSpaces1++-- | Backtracking parser similar to string, but allows varying amount of space between words+keywordsp :: String -> JournalParser m ()+keywordsp = try . sequence_ . intersperse spacesp . map keywordp . words++applyaccountdirectivep :: JournalParser m ()+applyaccountdirectivep = do+  keywordsp "apply account" <?> "apply account directive"+  lift skipNonNewlineSpaces1+  parent <- lift accountnamep+  newline+  pushParentAccount parent++endapplyaccountdirectivep :: JournalParser m ()+endapplyaccountdirectivep = do+  keywordsp "end apply account" <?> "end apply account directive"+  popParentAccount++aliasdirectivep :: JournalParser m ()+aliasdirectivep = do+  string "alias"+  lift skipNonNewlineSpaces1+  alias <- lift accountaliasp+  addAccountAlias alias++endaliasesdirectivep :: JournalParser m ()+endaliasesdirectivep = do+  keywordsp "end aliases" <?> "end aliases directive"+  clearAccountAliases++tagdirectivep :: JournalParser m ()+tagdirectivep = do+  string "tag" <?> "tag directive"+  lift skipNonNewlineSpaces1+  tagname <- lift $ T.pack <$> some nonspace+  (comment, _) <- lift transactioncommentp+  skipMany indentedlinep+  addTagDeclaration (tagname,comment)+  return ()++-- end tag or end apply tag+endtagdirectivep :: JournalParser m ()+endtagdirectivep = (do+  string "end"+  lift skipNonNewlineSpaces1+  optional $ string "apply" >> lift skipNonNewlineSpaces1+  string "tag"+  lift skipNonNewlineSpaces+  eol+  return ()+  ) <?> "end tag or end apply tag directive"++payeedirectivep :: JournalParser m ()+payeedirectivep = do+  string "payee" <?> "payee directive"+  lift skipNonNewlineSpaces1+  payee <- lift $ T.strip <$> (try doublequotedtextp <|> noncommenttext1p)+  (comment, tags) <- lift transactioncommentp+  skipMany indentedlinep+  addPayeeDeclaration (payee, comment, tags)+  return ()++defaultyeardirectivep :: JournalParser m ()+defaultyeardirectivep = do+  (string "Y" <|> string "year" <|> string "apply year") <?> "default year"+  lift skipNonNewlineSpaces+  setYear =<< lift yearp++defaultcommoditydirectivep :: JournalParser m ()+defaultcommoditydirectivep = do+  char 'D' <?> "default commodity"+  lift skipNonNewlineSpaces1+  off <- getOffset+  Amount{acommodity,astyle} <- amountp+  lift restofline+  if isNothing $ asdecimalmark astyle+  then customFailure $ parseErrorAt off pleaseincludedecimalpoint+  else setDefaultCommodityAndStyle (acommodity, astyle)++marketpricedirectivep :: JournalParser m PriceDirective+marketpricedirectivep = do+  pos <- getSourcePos+  char 'P' <?> "market price"+  lift skipNonNewlineSpaces+  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored+  lift skipNonNewlineSpaces1+  symbol <- lift commoditysymbolp+  lift skipNonNewlineSpaces1+  price <- amountp+  lift restofline+  return $ PriceDirective pos date symbol price++ignoredpricecommoditydirectivep :: JournalParser m ()+ignoredpricecommoditydirectivep = do+  char 'N' <?> "ignored-price commodity"+  lift skipNonNewlineSpaces1+  lift commoditysymbolp+  lift restofline+  return ()++commodityconversiondirectivep :: JournalParser m ()+commodityconversiondirectivep = do+  char 'C' <?> "commodity conversion"+  lift skipNonNewlineSpaces1+  amountp+  lift skipNonNewlineSpaces+  char '='+  lift skipNonNewlineSpaces+  amountp+  lift restofline+  return ()++-- | Read a valid decimal mark from the decimal-mark directive e.g+--+-- decimal-mark ,+decimalmarkdirectivep :: JournalParser m ()+decimalmarkdirectivep = do+  string "decimal-mark" <?> "decimal mark"+  lift skipNonNewlineSpaces1+  mark <- satisfy isDecimalMark+  modify' $ \j -> j{jparsedecimalmark=Just mark}+  lift restofline+  return ()++--- *** transactions++-- | Parse a transaction modifier (auto postings) rule.+transactionmodifierp :: JournalParser m TransactionModifier+transactionmodifierp = do+  char '=' <?> "modifier transaction"+  lift skipNonNewlineSpaces+  querytxt <- lift $ T.strip <$> descriptionp+  (_comment, _tags) <- lift transactioncommentp   -- TODO apply these to modified txns ?+  postingrules <- tmpostingrulesp Nothing+  return $ TransactionModifier querytxt postingrules++-- | Parse a periodic transaction rule.+--+-- This reuses periodexprp which parses period expressions on the command line.+-- This is awkward because periodexprp supports relative and partial dates,+-- which we don't really need here, and it doesn't support the notion of a+-- default year set by a Y directive, which we do need to consider here.+-- We resolve it as follows: in periodic transactions' period expressions,+-- if there is a default year Y in effect, partial/relative dates are calculated+-- relative to Y/1/1. If not, they are calculated related to today as usual.+periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction+periodictransactionp = do+  startpos <- getSourcePos++  -- first line+  char '~' <?> "periodic transaction"+  lift $ skipNonNewlineSpaces++  -- if there's a default year in effect, use Y/1/1 as base for partial/relative dates+  today <- liftIO getCurrentDay+  mdefaultyear <- getYear+  let refdate = case mdefaultyear of+                  Nothing -> today+                  Just y  -> fromGregorian y 1 1+  periodExcerpt <- lift $ excerpt_ $+                    singlespacedtextsatisfying1p (\c -> c /= ';' && c /= '\n')+  let periodtxt = T.strip $ getExcerptText periodExcerpt++  -- first parsing with 'singlespacedtextp', then "re-parsing" with+  -- 'periodexprp' saves 'periodexprp' from having to respect the single-+  -- and double-space parsing rules+  (interval, spn) <- lift $ reparseExcerpt periodExcerpt $ do+    pexp <- periodexprp refdate+    (<|>) eof $ do+      offset1 <- getOffset+      void takeRest+      offset2 <- getOffset+      customFailure $ parseErrorAtRegion offset1 offset2 $+           "remainder of period expression cannot be parsed"+        <> "\nperhaps you need to terminate the period expression with a double space?"+        <> "\na double space is required between period expression and description/comment"+    pure pexp++  status <- lift statusp <?> "cleared status"+  code <- lift codep <?> "transaction code"+  description <- lift $ T.strip <$> descriptionp+  (comment, tags) <- lift transactioncommentp+  -- next lines; use same year determined above+  postings <- postingsp (Just $ first3 $ toGregorian refdate)++  endpos <- getSourcePos+  let sourcepos = (startpos, endpos)++  return $ nullperiodictransaction{+     ptperiodexpr=periodtxt+    ,ptinterval=interval+    ,ptspan=spn+    ,ptsourcepos=sourcepos+    ,ptstatus=status+    ,ptcode=code+    ,ptdescription=description+    ,ptcomment=comment+    ,pttags=tags+    ,ptpostings=postings+    }++-- | Parse a (possibly unbalanced) transaction.+transactionp :: JournalParser m Transaction+transactionp = do+  -- dbgparse 0 "transactionp"+  startpos <- getSourcePos+  date <- datep <?> "transaction"+  edate <- optional (lift $ secondarydatep date) <?> "secondary date"+  lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"+  status <- lift statusp <?> "cleared status"+  code <- lift codep <?> "transaction code"+  description <- lift $ T.strip <$> descriptionp+  (comment, tags) <- lift transactioncommentp+  let year = first3 $ toGregorian date+  postings <- postingsp (Just year)+  endpos <- getSourcePos+  let sourcepos = (startpos, endpos)+  return $ txnTieKnot $ Transaction 0 "" sourcepos date edate status code description comment tags postings++--- *** postings++-- Parse the following whitespace-beginning lines as postings, posting+-- tags, and/or comments (inferring year, if needed, from the given date).+postingsp :: Maybe Year -> JournalParser m [Posting]+postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"++-- linebeginningwithspaces :: JournalParser m String+-- linebeginningwithspaces = do+--   sp <- lift skipNonNewlineSpaces1+--   c <- nonspace+--   cs <- lift restofline+--   return $ sp ++ (c:cs) ++ "\n"++postingp :: Maybe Year -> JournalParser m Posting+postingp = fmap fst . postingphelper False++-- Parse the following whitespace-beginning lines as transaction posting rules, posting+-- tags, and/or comments (inferring year, if needed, from the given date).+tmpostingrulesp :: Maybe Year -> JournalParser m [TMPostingRule]+tmpostingrulesp mTransactionYear = many (tmpostingrulep mTransactionYear) <?> "posting rules"++tmpostingrulep :: Maybe Year -> JournalParser m TMPostingRule+tmpostingrulep = fmap (uncurry TMPostingRule) . postingphelper True++-- Parse a Posting, and return a flag with whether a multiplier has been detected.+-- The multiplier is used in TMPostingRules.+postingphelper :: Bool -> Maybe Year -> JournalParser m (Posting, Bool)+postingphelper isPostingRule mTransactionYear = do+    -- lift $ dbgparse 0 "postingp"+    (status, account) <- try $ do+      lift skipNonNewlineSpaces1+      status <- lift statusp+      lift skipNonNewlineSpaces+      account <- modifiedaccountnamep True+      return (status, account)+    let (ptype, account') = (accountNamePostingType account, textUnbracket account)+    lift skipNonNewlineSpaces+    mult <- if isPostingRule then multiplierp else pure False+    amt <- optional $ amountp' mult+    lift skipNonNewlineSpaces+    massertion <- optional balanceassertionp+    lift skipNonNewlineSpaces+    (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear+    let p = posting+            { pdate=mdate+            , pdate2=mdate2+            , pstatus=status+            , paccount=account'+            , pamount=maybe missingmixedamt mixedAmount amt+            , pcomment=comment+            , ptype=ptype+            , ptags=tags+            , pbalanceassertion=massertion+            }+    return (p, mult)+  where+    multiplierp = option False $ True <$ char '*'++--- ** tests++tests_JournalReader = testGroup "JournalReader" [++   let p = lift accountnamep :: JournalParser IO AccountName in+   testGroup "accountnamep" [+     testCase "basic" $ assertParse p "a:b:c"+    -- ,testCase "empty inner component" $ assertParseError p "a::c" ""  -- TODO+    -- ,testCase "empty leading component" $ assertParseError p ":b:c" "x"+    -- ,testCase "empty trailing component" $ assertParseError p "a:b:" "x"+    ]++  -- "Parse a date in YYYY/MM/DD format.+  -- Hyphen (-) and period (.) are also allowed as separators.+  -- The year may be omitted if a default year has been set.+  -- Leading zeroes may be omitted."+  ,testGroup "datep" [+     testCase "YYYY/MM/DD" $ assertParseEq datep "2018/01/01" (fromGregorian 2018 1 1)+    ,testCase "YYYY-MM-DD" $ assertParse datep "2018-01-01"+    ,testCase "YYYY.MM.DD" $ assertParse datep "2018.01.01"+    ,testCase "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown"+    ,testCase "yearless date with default year" $ do+      let s = "1/1"+      ep <- parseWithState nulljournal{jparsedefaultyear=Just 2018} datep s+      either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep+    ,testCase "no leading zero" $ assertParse datep "2018/1/1"+    ]+  ,testCase "datetimep" $ do+     let+       good  = assertParse datetimep+       bad t = assertParseError datetimep t ""+     good "2011/1/1 00:00"+     good "2011/1/1 23:59:59"+     bad "2011/1/1"+     bad "2011/1/1 24:00:00"+     bad "2011/1/1 00:60:00"+     bad "2011/1/1 00:00:60"+     bad "2011/1/1 3:5:7"+     -- timezone is parsed but ignored+     let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 0)+     assertParseEq datetimep "2018/1/1 00:00-0800" t+     assertParseEq datetimep "2018/1/1 00:00+1234" t++  ,testGroup "periodictransactionp" [++    testCase "more period text in comment after one space" $ assertParseEq periodictransactionp+      "~ monthly from 2018/6 ;In 2019 we will change this\n"+      nullperiodictransaction {+         ptperiodexpr  = "monthly from 2018/6"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan (Just $ Flex $ fromGregorian 2018 6 1) Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+        ,ptdescription = ""+        ,ptcomment     = "In 2019 we will change this\n"+        }++    ,testCase "more period text in description after two spaces" $ assertParseEq periodictransactionp+      "~ monthly from 2018/6   In 2019 we will change this\n"+      nullperiodictransaction {+         ptperiodexpr  = "monthly from 2018/6"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan (Just $ Flex $ fromGregorian 2018 6 1) Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+        ,ptdescription = "In 2019 we will change this"+        ,ptcomment     = ""+        }++    ,testCase "Next year in description" $ assertParseEq periodictransactionp+      "~ monthly  Next year blah blah\n"+      nullperiodictransaction {+         ptperiodexpr  = "monthly"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan Nothing Nothing+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+        ,ptdescription = "Next year blah blah"+        ,ptcomment     = ""+        }++    ,testCase "Just date, no description" $ assertParseEq periodictransactionp+      "~ 2019-01-04\n"+      nullperiodictransaction {+         ptperiodexpr  = "2019-01-04"+        ,ptinterval    = NoInterval+        ,ptspan        = DateSpan (Just $ Exact $ fromGregorian 2019 1 4) (Just $ Exact $ fromGregorian 2019 1 5)+        ,ptsourcepos   = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 2) (mkPos 1))+        ,ptdescription = ""+        ,ptcomment     = ""+        }++    ,testCase "Just date, no description + empty transaction comment" $ assertParse periodictransactionp+      "~ 2019-01-04\n  ;\n  a  1\n  b\n"++    ]++  ,testGroup "postingp" [+     testCase "basic" $ assertParseEq (postingp Nothing)+      "  expenses:food:dining  $10.00   ; a: a a \n   ; b: b b \n"+      posting{+        paccount="expenses:food:dining",+        pamount=mixedAmount (usd 10),+        pcomment="a: a a\nb: b b\n",+        ptags=[("a","a a"), ("b","b b")]+        }++    ,testCase "posting dates" $ assertParseEq (postingp Nothing)+      " a  1. ; date:2012/11/28, date2=2012/11/29,b:b\n"+      nullposting{+         paccount="a"+        ,pamount=mixedAmount (num 1)+        ,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"+        ,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily+        ,pdate=Just $ fromGregorian 2012 11 28+        ,pdate2=Nothing  -- Just $ fromGregorian 2012 11 29+        }++    ,testCase "posting dates bracket syntax" $ assertParseEq (postingp Nothing)+      " a  1. ; [2012/11/28=2012/11/29]\n"+      nullposting{+         paccount="a"+        ,pamount=mixedAmount (num 1)+        ,pcomment="[2012/11/28=2012/11/29]\n"+        ,ptags=[]+        ,pdate= Just $ fromGregorian 2012 11 28+        ,pdate2=Just $ fromGregorian 2012 11 29+        }++    ,testCase "quoted commodity symbol with digits" $ assertParse (postingp Nothing) "  a  1 \"DE123\"\n"++    ,testCase "only lot price" $ assertParse (postingp Nothing) "  a  1A {1B}\n"+    ,testCase "fixed lot price" $ assertParse (postingp Nothing) "  a  1A {=1B}\n"+    ,testCase "total lot price" $ assertParse (postingp Nothing) "  a  1A {{1B}}\n"+    ,testCase "fixed total lot price, and spaces" $ assertParse (postingp Nothing) "  a  1A {{  =  1B }}\n"+    ,testCase "lot price before transaction price" $ assertParse (postingp Nothing) "  a  1A {1B} @ 1B\n"+    ,testCase "lot price after transaction price" $ assertParse (postingp Nothing) "  a  1A @ 1B {1B}\n"+    ,testCase "lot price after balance assertion not allowed" $ assertParseError (postingp Nothing) "  a  1A @ 1B = 1A {1B}\n" "unexpected '{'"+    ,testCase "only lot date" $ assertParse (postingp Nothing) "  a  1A [2000-01-01]\n"+    ,testCase "transaction price, lot price, lot date" $ assertParse (postingp Nothing) "  a  1A @ 1B {1B} [2000-01-01]\n"+    ,testCase "lot date, lot price, transaction price" $ assertParse (postingp Nothing) "  a  1A [2000-01-01] {1B} @ 1B\n"++    ,testCase "balance assertion over entire contents of account" $ assertParse (postingp Nothing) "  a  $1 == $1\n"+    ]++  ,testGroup "transactionmodifierp" [++    testCase "basic" $ assertParseEq transactionmodifierp+      "= (some value expr)\n some:postings  1.\n"+      nulltransactionmodifier {+        tmquerytxt = "(some value expr)"+       ,tmpostingrules = [TMPostingRule nullposting{paccount="some:postings", pamount=mixedAmount (num 1)} False]+      }+    ]++  ,testGroup "transactionp" [++     testCase "just a date" $ assertParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}++    ,testCase "more complex" $ assertParseEq transactionp+      (T.unlines [+        "2012/05/14=2012/05/15 (code) desc  ; tcomment1",+        "    ; tcomment2",+        "    ; ttag1: val1",+        "    * a         $1.00  ; pcomment1",+        "    ; pcomment2",+        "    ; ptag1: val1",+        "    ; ptag2: val2"+        ])+      nulltransaction{+        tsourcepos=(SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 8) (mkPos 1)),  -- 8 because there are 7 lines+        tprecedingcomment="",+        tdate=fromGregorian 2012 5 14,+        tdate2=Just $ fromGregorian 2012 5 15,+        tstatus=Unmarked,+        tcode="code",+        tdescription="desc",+        tcomment="tcomment1\ntcomment2\nttag1: val1\n",+        ttags=[("ttag1","val1")],+        tpostings=[+          nullposting{+            pdate=Nothing,+            pstatus=Cleared,+            paccount="a",+            pamount=mixedAmount (usd 1),+            pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",+            ptype=RegularPosting,+            ptags=[("ptag1","val1"),("ptag2","val2")],+            ptransaction=Nothing+            }+          ]+      }++    ,testCase "parses a well-formed transaction" $+      assertBool "" $ isRight $ rjp transactionp $ T.unlines+        ["2007/01/28 coopportunity"+        ,"    expenses:food:groceries                   $47.18"+        ,"    assets:checking                          $-47.18"+        ,""+        ]++    ,testCase "does not parse a following comment as part of the description" $+      assertParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"++    ,testCase "parses a following whitespace line" $+      assertBool "" $ isRight $ rjp transactionp $ T.unlines+        ["2012/1/1"+        ,"  a  1"+        ,"  b"+        ," "+        ]++    ,testCase "parses an empty transaction comment following whitespace line" $+      assertBool "" $ isRight $ rjp transactionp $ T.unlines+        ["2012/1/1"+        ,"  ;"+        ,"  a  1"+        ,"  b"+        ," "+        ]++    ,testCase "comments everywhere, two postings parsed" $+      assertParseEqOn transactionp+        (T.unlines+          ["2009/1/1 x  ; transaction comment"+          ," a  1  ; posting 1 comment"+          ," ; posting 1 comment 2"+          ," b"+          ," ; posting 2 comment"+          ])+        (length . tpostings)+        2++    ]++  -- directives++  ,testGroup "directivep" [+    testCase "supports !" $ do+        assertParseE (directivep definputopts) "!account a\n"+        assertParseE (directivep definputopts) "!D 1.0\n"+     ]++  ,testGroup "accountdirectivep" [+       testCase "with-comment"       $ assertParse accountdirectivep "account a:b  ; a comment\n"+      ,testCase "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" ""+      ,testCase "account-type-code"  $ assertParse accountdirectivep "account a:b  ; type:A\n"+      ,testCase "account-type-tag"   $ assertParseStateOn accountdirectivep "account a:b  ; type:asset\n"+        jdeclaredaccounts+        [("a:b", AccountDeclarationInfo{adicomment          = "type:asset\n"+                                       ,aditags             = [("type","asset")]+                                       ,adideclarationorder = 1+                                       ,adisourcepos        = nullsourcepos+                                       })+        ]+      ]++  ,testCase "commodityconversiondirectivep" $ do+     assertParse commodityconversiondirectivep "C 1h = $50.00\n"++  ,testCase "defaultcommoditydirectivep" $ do+      assertParse defaultcommoditydirectivep "D $1,000.0\n"+      assertParseError defaultcommoditydirectivep "D $1000\n" "Please include a decimal point or decimal comma"++  ,testGroup "defaultyeardirectivep" [+      testCase "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others+     -- ,testCase "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number"+     ,testCase "12345" $ assertParse defaultyeardirectivep "Y 12345"+     ]++  ,testCase "ignoredpricecommoditydirectivep" $ do+     assertParse ignoredpricecommoditydirectivep "N $\n"++  ,testGroup "includedirectivep" [+      testCase "include" $ assertParseErrorE (includedirectivep definputopts) "include nosuchfile\n" "No files were matched by: nosuchfile"+     ,testCase "glob" $ assertParseErrorE (includedirectivep definputopts) "include nosuchfile*\n" "No files were matched by: nosuchfile*"+     ]++  ,testCase "marketpricedirectivep" $ assertParseEq marketpricedirectivep+    "P 2017/01/30 BTC $922.83\n"+    PriceDirective{+      pdsourcepos = nullsourcepos,+      pddate      = fromGregorian 2017 1 30,+      pdcommodity = "BTC",+      pdamount    = usd 922.83+      }++  ,testGroup "payeedirectivep" [+        testCase "simple"             $ assertParse payeedirectivep "payee foo\n"+       ,testCase "with-comment"       $ assertParse payeedirectivep "payee foo ; comment\n"+       ,testCase "double-quoted"      $ assertParse payeedirectivep "payee \"a b\"\n"+       ,testCase "empty        "      $ assertParse payeedirectivep "payee \"\"\n"+       ]++  ,testCase "tagdirectivep" $ do+     assertParse tagdirectivep "tag foo \n"++  ,testCase "endtagdirectivep" $ do+      assertParse endtagdirectivep "end tag \n"+      assertParse endtagdirectivep "end apply tag \n"++  ,testGroup "journalp" [+    testCase "empty file" $ assertParseEqE (journalp definputopts) "" nulljournal+    ]++   -- these are defined here rather than in Common so they can use journalp+  ,testCase "parseAndFinaliseJournal" $ do+      ej <- runExceptT $ parseAndFinaliseJournal (journalp definputopts) definputopts "" "2019-1-1\n"+      let Right j = ej+      assertEqual "" [""] $ journalFilePaths j    ]
+ Hledger/Read/RulesReader.hs view
@@ -0,0 +1,1926 @@+--- * module+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.+{-|++A reader for a CSV rules file. +This reads the actual data from a file specified by a `source` rule+or from a similarly-named file in the same directory.++Most of the code for reading rules files and csv files is in this module.+-}+-- Lots of haddocks in this file are for non-exported types.+-- Here's a command that will render them:+-- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open++--- ** language+{-# LANGUAGE CPP    #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++--- ** exports+module Hledger.Read.RulesReader (+  -- * Reader+  reader,+  -- * Misc.+  dataFileFor,+  rulesFileFor,+  getRulesFile,+  readRules,+  rulesEncoding,+  readJournalFromCsv,+  parseBalanceAssertionType,+  -- * Tests+  tests_RulesReader,+)+where++--- ** imports+import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..))+import Control.Concurrent (forkIO)+import Control.DeepSeq (deepseq)+import Control.Monad (unless, void, when)+import Control.Monad.Except       (ExceptT(..), liftEither, throwError)+import Control.Monad.Fail qualified as Fail+import Control.Monad.IO.Class     (MonadIO, liftIO)+import Control.Monad.State.Strict (StateT, get, modify', evalStateT)+import Control.Monad.Trans.Class  (lift)+import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord)+import Data.Bifunctor             (first)+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL+import Data.Csv qualified as Cassava+import Data.Csv.Parser.Megaparsec qualified as CassavaMegaparsec+import Data.Encoding (encodingFromStringExplicit, DynEncoding)+import Data.Either (fromRight)+import Data.Functor ((<&>))+import Data.List (elemIndex, mapAccumL, nub, sortOn)+-- import Data.List (elemIndex, mapAccumL, nub, sortOn, isPrefixOf, sortBy)+-- import Data.Ord (Down(..), comparing)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.List.Extra (groupOn)+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.MemoUgly (memo)+import Data.Set qualified as S+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.IO qualified as T+import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime),+  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC, utctDay)+import Safe (atMay, headMay, lastMay, readMay)+import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory, getModificationTime, removeFile)+-- import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory, getModificationTime, listDirectory, renameFile, doesDirectoryExist)+import System.Exit      (ExitCode(..))+import System.FilePath (stripExtension, takeBaseName, takeDirectory, takeExtension, takeFileName, (<.>), (</>))+import System.IO       (Handle, hClose, hPutStrLn, stderr, hGetContents')+import System.Process  (CreateProcess(..), StdStream(CreatePipe), shell, waitForProcess, withCreateProcess)+import Data.Foldable (asum, toList)+import Text.Megaparsec hiding (match, parse)+import Text.Megaparsec.Char (char, newline, string, digitChar)+import Text.Printf (printf)++import Hledger.Data+import Hledger.Utils+import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, transactioncommentp, postingcommentp )+import Hledger.Write.Csv++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++--- ** reader+_READER__________________________________________ = undefined  -- VSCode outline separator+++reader :: MonadIO m => Reader m+reader = Reader+  {rFormat     = Rules+  ,rExtensions = ["rules"]+  ,rReadFn     = parse+  ,rParser     = const $ fail "sorry, rules files can't be included yet"+  }++isFileName f = takeFileName f == f++getDownloadDir = do+  home <- getHomeDirectory+  return $ home </> "Downloads"  -- XXX++-- | Read, parse and post-process a "Journal" from the given rules file, or give an error.+-- This particular reader also provides some extra features like data cleaning/generating commands and data archiving.+--+-- The provided input file handle, and the --rules option, are ignored by this reader.+-- Instead, a data file (or data-generating command) is usually specified by the @source@ rule.+-- If there's no source rule, the data file is assumed to be named like the rules file without .rules, in the same directory.+--+-- The source rule supports ~ for home directory: @source ~/Downloads/foo.csv@.+-- If the argument is a bare filename, its directory is assumed to be ~/Downloads: @source foo.csv@.+-- Otherwise if it is a relative path, it is assumed to be relative to the rules file's directory: @source new/foo.csv@.+--+-- The source rule can specify a glob pattern: @source foo*.csv@.+-- If the glob pattern matches multiple files, the newest (last modified) file is used (with one exception, described below).+--+-- The source rule can specify a data-cleaning command, after a @|@ separator: @source foo*.csv | sed -e 's/USD/$/g'@.+-- This command is executed by the user's default shell, receives the data file's content on stdin,+-- and should output CSV data suitable for the conversion rules.+-- A # character can be used to comment out the data-cleaning command: @source foo*.csv  # | ...@.+--+-- Or the source rule can specify just a data-generating command, with no file pattern: @source | foo-csv.sh@.+-- In this case the command receives no input; it should output CSV data suitable for the conversion rules.+--+-- If the archive rule is present:+-- After successfully reading the data file or data command and converting to a journal, while doing a non-dry-run import:+-- the data will be archived in an auto-created data/ directory next to the rules file,+-- with a name based on the rules file and the data file's modification date and extension+-- (or for a data-generating command, the current date and the ".csv" extension).+-- And import will prefer the oldest file matched by a glob pattern (not the newest).+--+-- Balance assertions are not checked by this reader.+--+parse :: InputOpts -> FilePath -> Handle -> ExceptT String IO Journal+parse iopts rulesfile h = do+  lift $ hClose h -- We don't need it (XXX why ?)++  -- The rules reader does a lot; we must be organised.++  -- 1. gather contextual info+  --  gives: import flag, dryrun flag, rulesdir++  let+    args     = progArgs+    import_  = dbg2 "import" $ any (`elem` args) ["import", "imp"]+    dryrun   = dbg2 "dryrun" $ any (`elem` args) ["--dry-run", "--dry"]+    rulesdir = takeDirectory rulesfile++  -- 2. parse the source and archive rules+  --  needs: rules file+  --  gives: file pattern, data cleaning/generating command, archive flag++  -- XXX higher-than usual logging priority for file reading (normally 6 or 7), to bypass excessive noise from elsewhere+  rules <- readRules $ dbg1 "reading rules file" rulesfile+  let+    msourcearg = getDirective "source" rules+      -- Nothing -> error' $ rulesfile ++ " source rule must specify a file pattern or a command"+    -- Surrounding whitespace is removed from the whole source argument and from each part of it.+    -- A # before | makes the rest of line a comment.+    -- A # after | is left for the shell to interpret; it could be part of the command or the start of a comment.+    stripspaces = T.strip+    stripcommentandspaces = stripspaces . T.takeWhile (/= '#')+    mpatandcmd = T.breakOn "|" . stripspaces <$> msourcearg+    mpat = dbg2 "file pattern" $  -- a non-empty file pattern, or nothing+      case T.unpack . stripcommentandspaces . fst <$> mpatandcmd of+        Just s | not $ null s -> Just s+        _ -> Nothing+    mcmd = dbg2 "data command" $  -- a non-empty command, or nothing+      mpatandcmd >>= \sc ->+        let c = T.unpack . stripspaces . T.drop 1 . snd $ sc+        in if null c then Nothing else Just c++    archive = isJust (getDirective "archive" rules)++  -- 3. find the file to be read, if any+  --  needs: file pattern, data command, import flag, archive flag, downloads dir+  --  gives: data file, data file description++  (mdatafile, datafiledesc) <- dbg2 "data file found ?" <$> case (mpat, mcmd) of+    (Nothing, Nothing) -> error' $ "to make " ++ rulesfile ++ " readable,\n please add a 'source' rule with a non-empty file pattern or command"+    (Nothing, Just _) -> return (Nothing, "")+    (Just pat, _) -> do+      dldir <- liftIO getDownloadDir  -- look here for the data file if it's specified without a directory+      let+        (startdir, dirdesc)+          | isFileName pat = (dldir,    " in download directory")+          | otherwise      = (rulesdir, "")+      fs <- liftIO $+        expandGlob startdir pat+        >>= sortByModTime+        <&> dbg2 ("matched files"<>dirdesc<>", oldest first")+      return $+        if import_ && archive+        then (headMay fs, " oldest file")+        else (lastMay fs, " newest file")+    +  -- 4. log which file we are reading/importing/cleaning/generating+  --  needs: data file, data file description, import flag++  case (mdatafile, datafiledesc) of+    (Just f, desc) -> dbg1IO ("trying to " ++ (if import_ then "import" else "read") ++ desc) f+    (Nothing, _)   -> return ()++  -- 5. read raw, cleaned or generated data+  --  needs: file pattern, data file, optional data file encoding, data command+  --  gives: clean data (possibly empty)++  mexistingdatafile <- maybe (return Nothing) (\f -> liftIO $ do+    exists <- doesFileExist f+    return $ if exists then Just f else Nothing+    ) $ mdatafile+  cleandata <- dbg1With (\t -> "read "++(show $ length $ T.lines t)++" lines") <$> case (mpat, mexistingdatafile, mcmd) of++    -- file pattern, but no file found+    (Just _, Nothing, _) -> -- trace "file pattern, but no file found" $+      return ""++    -- file found, and maybe a data cleaning command+    (_, Just f,  mc) -> do  -- trace "file found" $+      mencoding <- rulesEncoding rules+      liftIO $ do+        raw <- openFileOrStdin f >>= hGetContentsPortably mencoding+        maybe (return raw) (\c -> runCommandAsFilter rulesfile (dbg0Msg ("running: "++c) c) raw) mc++    -- no file pattern, but a data generating command+    (Nothing, _, Just cmd) -> -- trace "data generating command" $+      liftIO $ runCommand rulesfile $ dbg0Msg ("running: " ++ cmd) cmd++    -- neither a file pattern nor a data generating command+    (Nothing, _, Nothing) -> -- trace "no file pattern or data generating command" $+      error' $ rulesfile ++ " source rule must specify a file pattern or a command"++  -- 6. convert the clean data to a (possibly empty) journal+  --  needs: clean data, rules, data file if any+  --  gives: journal++  j <- do+    readJournalFromCsv rules (fromMaybe "(cmd)" mdatafile) cleandata Nothing+    -- apply any command line account aliases. Can fail with a bad replacement pattern.+    >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+        -- journalFinalise assumes the journal's items are+        -- reversed, as produced by JournalReader's parser.+        -- But here they are already properly ordered. So we'd+        -- better preemptively reverse them once more. XXX inefficient+        . journalReverse+    >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} rulesfile ""++  -- 7. if non-empty, successfully read and converted, and we're doing a non-dry-run archiving import: archive the data+  --  needs: import/archive/dryrun flags, rules directory, rules file, data file if any, clean data++  when (not (T.null cleandata) && import_ && archive && not dryrun) $+    liftIO $ saveToArchive (rulesdir </> "data") rulesfile mdatafile cleandata++  return j++-- | For the given rules file, run the given shell command, in the rules file's directory.+-- If the command fails, raise an error and show its error output;+-- otherwise return its output, and show any error output as a warning.+runCommand :: FilePath -> String -> IO Text+runCommand rulesfile cmd = do+  let process = (shell cmd) { cwd = Just $ takeDirectory rulesfile, std_out = CreatePipe, std_err = CreatePipe }+  withCreateProcess process $ \_ mhout mherr phandle -> do+    case (mhout, mherr) of+      (Just hout, Just herr) -> do+        out <- T.hGetContents hout+        err <- hGetContents' herr+        exitCode <- waitForProcess phandle+        case exitCode of+          ExitSuccess -> do+            unless (null err) $ warnIO err+            return out+          ExitFailure code ->+            error' $ "in " ++ rulesfile ++ ": command \"" ++ cmd ++ "\" failed with exit code " ++ show code+              ++ (if null err then "" else ":\n" ++ err)+      _ -> error' $ "in " ++ rulesfile ++ ": failed to create pipes for command execution"++-- | For the given rules file, run the given shell command, in the rules file's directory, passing the given text as input.+-- Return the output, or if the command fails, raise an informative error.+runCommandAsFilter :: FilePath -> String -> Text -> IO Text+runCommandAsFilter rulesfile cmd input = do+  let process = (shell cmd) { cwd = Just $ takeDirectory rulesfile, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+  withCreateProcess process $ \mhin mhout mherr phandle -> do+    case (mhin, mhout, mherr) of+      (Just hin, Just hout, Just herr) -> do+        forkIO $ T.hPutStr hin input >> hClose hin+        out <- T.hGetContents hout+        err <- hGetContents' herr+        exitCode <- waitForProcess phandle+        case exitCode of+          ExitSuccess -> return out+          ExitFailure code ->+            error' $ "in " ++ rulesfile ++ ": command \"" ++ cmd ++ "\" failed with exit code " ++ show code+              ++ (if null err then "" else ":\n" ++ err)+      _ -> error' $ "in " ++ rulesfile ++ ": failed to create pipes for command execution"++type DirPath = FilePath++-- | Save some successfully imported data+-- (more precisely: data that was successfully read and maybe cleaned, or that was generated, during an import)+-- to the given archive directory, autocreating that if needed, and show informational output on stderr.+-- The arguments are:+-- the archive directory,+-- the rules file (for naming),+-- the data file name, if any,+-- the data that was read, cleaned, or generated.+-- The archive file name will be RULESFILEBASENAME.DATAFILEMODDATEORCURRENTDATE.DATAFILEEXTORCSV.+-- Note for a data generating command, where there's no data file, we use the current date+-- and a .csv file extension (meaning "character-separated values" in this case).+saveToArchive :: DirPath -> FilePath -> Maybe FilePath -> Text -> IO ()+saveToArchive archivedir rulesfile mdatafile cleandata = do+  createDirectoryIfMissing True archivedir+  (_, cleanname) <- archiveFileName rulesfile mdatafile+  let cleanarchive = archivedir </> cleanname+  hPutStrLn stderr $ "archiving " <> cleanarchive+  T.writeFile cleanarchive cleandata+  maybe (return ()) removeFile mdatafile++-- | Figure out the file names to use when archiving, for the given rules file and the given data file if any.+-- The second name is for the final (possibly cleaned) data; the first name has ".orig" added,+-- and is used if both original and cleaned data are being archived. They will be like this:+-- ("RULESFILEBASENAME.orig.DATAFILEMODDATE.DATAFILEEXT", "RULESFILEBASENAME.DATAFILEMODDATE.DATAFILEEXT")+archiveFileName :: FilePath -> Maybe FilePath -> IO (String, String)+archiveFileName rulesfile mdatafile = do+  let base = takeBaseName rulesfile+  case mdatafile of+    Just datafile -> do+      moddate <- (show . utctDay) <$> getModificationTime datafile+      let ext = takeExtension datafile+      return (+         base <.> "orig" <.> moddate <.> ext+        ,base            <.> moddate <.> ext+        )+    Nothing -> do+      let ext = "csv"+      curdate <- show <$> getCurrentDay+      return (+         base <.> "orig" <.> curdate <.> ext+        ,base            <.> curdate <.> ext+        )++-- -- | In the given archive directory, if it exists, find the paths of data files saved for the given rules file.+-- -- They will be reverse sorted by name, ie newest first, assuming normal archive file names.+-- --+-- -- We don't know which extension the data files use, but we look for file names beginning with+-- -- the rules file's base name followed by .YYYY-MM-DD, which will normally be good enough.+-- --+-- archivesFor :: FilePath -> FilePath -> IO [FilePath]+-- archivesFor archivedir rulesfile = do+--   exists <- doesDirectoryExist archivedir+--   if not exists then return []+--   else do+--     let prefix = takeBaseName rulesfile <> "."+--     fs <- listDirectory archivedir+--     return $ map (archivedir </>) $ sortBy (comparing Down)+--       [f | f <- fs,+--         prefix `isPrefixOf` f,+--         let nextpart = takeWhile (/= '.') $ drop (length prefix) f,+--         isJust $ parsedate nextpart+--         ]++--- ** reading rules files+--- *** rules utilities+_RULES_READING__________________________________________ = undefined++-- | Given a rules file path, what would be the corresponding data file ?+-- (Remove a .rules extension.)+dataFileFor :: FilePath -> Maybe FilePath+dataFileFor = stripExtension "rules"++-- | Given a csv file path, what would be the corresponding rules file ?+-- (Add a .rules extension.)+rulesFileFor :: FilePath -> FilePath+rulesFileFor = (++ ".rules")++-- | Return the given rules file path, or if none is given,+-- the default rules file for the given csv file;+-- or if the csv file is "-", raise an error.+getRulesFile :: FilePath -> Maybe FilePath -> FilePath+getRulesFile csvfile mrulesfile =+  case mrulesfile of+    Nothing | csvfile == "-" ->+      error' "please use --rules when reading CSV from stdin"  -- PARTIAL+        -- XXX is this bad ? everything else here uses ExceptT+    Nothing -> rulesFileFor csvfile+    Just f -> f++-- | An exception-throwing IO action that reads and validates+-- the specified CSV rules file (which may include other rules files).+readRules :: FilePath -> ExceptT String IO CsvRules+readRules f =+  liftIO (do+    dbg6IO "using conversion rules file" f+    readFilePortably f >>= expandIncludes (takeDirectory f)+  ) >>= either throwError return . parseAndValidateCsvRules f++-- | Read the encoding specified by the @encoding@ rule, if any.+-- Or throw an error if an unrecognised encoding is specified.+rulesEncoding :: CsvRules -> ExceptT String IO (Maybe DynEncoding)+rulesEncoding rules = do+  case T.unpack <$> getDirective "encoding" rules of+    Nothing     -> return Nothing+    Just encstr -> case encodingFromStringExplicit $ dbg4 "encoding name" encstr of+      Nothing  -> throwError $ "Invalid encoding: " <> encstr+      Just enc -> return . Just $ dbg4 "encoding" enc++-- | Inline all files referenced by include directives in this hledger CSV rules text, recursively.+-- Included file paths may be relative to the directory of the provided file path.+-- Unlike with journal files, this is done as a pre-parse step to simplify the CSV rules parser.+-- Unfortunately this means that the parser won't see accurate file paths and positions with included files.+expandIncludes :: FilePath -> Text -> IO Text+expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines+  where+    expandLine dir1 line =+      case line of+        (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f'+          where+            f' = dir1 </> T.unpack (T.dropWhile isSpace f)+            dir2 = takeDirectory f'+        _ -> return line++-- defaultRulesText :: FilePath -> Text+-- defaultRulesText _csvfile = T.pack $ unlines+--   ["# hledger csv conversion rules" --  for " ++ csvFileFor (takeFileName csvfile)+--   ,"# cf http://hledger.org/hledger.html#csv"+--   ,""+--   ,"account1 assets:bank:checking"+--   ,""+--   ,"fields date, description, amount1"+--   ,""+--   ,"#skip 1"+--   ,"#newest-first"+--   ,""+--   ,"#date-format %-d/%-m/%Y"+--   ,"#date-format %-m/%-d/%Y"+--   ,"#date-format %Y-%h-%d"+--   ,""+--   ,"#currency $"+--   ,""+--   ,"if ITUNES"+--   ," account2 expenses:entertainment"+--   ,""+--   ,"if (TO|FROM) SAVINGS"+--   ," account2 assets:bank:savings\n"+--   ]++-- | An error-throwing IO action that parses this text as CSV conversion rules+-- and runs some extra validation checks. The file path is used in error messages.+parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules+parseAndValidateCsvRules rulesfile s =+  case parseCsvRules rulesfile s of+    Left err    -> Left $ customErrorBundlePretty err+    Right rules -> first makeFancyParseError $ validateCsvRules rules+  where+    makeFancyParseError :: String -> String+    makeFancyParseError errorString =+      parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)++instance ShowErrorComponent String where+  showErrorComponent = id++-- | Parse this text as CSV conversion rules. The file path is for error messages.+parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules+-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s+parseCsvRules = runParser (evalStateT rulesp defrules)++-- | Return the validated rules, or an error.+validateCsvRules :: CsvRules -> Either String CsvRules+validateCsvRules rules = do+  unless (isAssigned "date")   $ Left "Please specify (at top level) the date field. Eg: date %1"+  Right rules+  where+    isAssigned f = isJust $ hledgerField rules [] f++--- *** rules types+_RULES_TYPES__________________________________________ = undefined++-- | A set of data definitions and account-matching patterns sufficient to+-- convert a particular CSV data file into meaningful journal transactions.+data CsvRules' a = CsvRules' {+  rdirectives        :: [(DirectiveName,Text)],+    -- ^ top-level rules, as (keyword, value) pairs+  rcsvfieldindexes   :: [(CsvFieldName, CsvFieldIndex)],+    -- ^ csv field names and their column number, if declared by a fields list+  rassignments       :: [(HledgerFieldName, FieldTemplate)],+    -- ^ top-level assignments to hledger fields, as (field name, value template) pairs+  rconditionalblocks :: [ConditionalBlock],+    -- ^ conditional blocks, which containing additional assignments/rules to apply to matched csv records+  rblocksassigning :: a -- (String -> [ConditionalBlock])+    -- ^ all conditional blocks which can potentially assign field with a given name (memoized)+}++-- | Type used by parsers. Directives, assignments and conditional blocks+-- are in the reverse order compared to what is in the file and rblocksassigning is non-functional,+-- could not be used for processing CSV records yet+type CsvRulesParsed = CsvRules' ()++-- | Type used after parsing is done. Directives, assignments and conditional blocks+-- are in the same order as they were in the input file and rblocksassigning is functional.+-- Ready to be used for CSV record processing+type CsvRules = CsvRules' (Text -> [ConditionalBlock])  -- XXX simplify++instance Eq CsvRules where+  r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==+             (rdirectives r2, rcsvfieldindexes r2, rassignments r2)++-- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable.+instance Show CsvRules where+  show r = "CsvRules { rdirectives = " ++ show (rdirectives r) +++           ", rcsvfieldindexes = "     ++ show (rcsvfieldindexes r) +++           ", rassignments = "         ++ show (rassignments r) +++           ", rconditionalblocks = "   ++ show (rconditionalblocks r) +++           " }"++type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a++-- | The keyword of a CSV rule - "fields", "skip", "if", etc.+type DirectiveName    = Text++-- | CSV field name.+type CsvFieldName     = Text++-- | 1-based CSV column number.+type CsvFieldIndex    = Int++-- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1.+type CsvFieldReference = Text++-- | One of the standard hledger fields or pseudo-fields that can be assigned to.+-- Eg date, account1, amount, amount1-in, date-format.+type HledgerFieldName = Text++-- | A text value to be assigned to a hledger field, possibly+-- containing csv field references to be interpolated.+type FieldTemplate    = Text++-- | A reference to a regular expression match group. Eg \1.+type MatchGroupReference = Text++-- | A strptime date parsing pattern, as supported by Data.Time.Format.+type DateFormat       = Text++-- | A representation of a matcher's prefix, which indicates how it should be+-- interpreted or combined with other matchers.+data MatcherPrefix =+    Or      -- ^ no prefix+  | And     -- ^ &&+  | Not     -- ^ !+  | AndNot  -- ^ && !+  deriving (Show, Eq)++dbgShowMatcherPrefix Or = ""+dbgShowMatcherPrefix And = "&&"+dbgShowMatcherPrefix Not = "&&"+dbgShowMatcherPrefix AndNot = "&& !"++-- | A single test for matching a CSV record, in one way or another.+data Matcher =+    RecordMatcher MatcherPrefix Regexp                          -- ^ match if this regexp matches the overall CSV record+  | FieldMatcher MatcherPrefix CsvFieldReference Regexp         -- ^ match if this regexp matches the referenced CSV field's value+  deriving (Show, Eq)++matcherPrefix :: Matcher -> MatcherPrefix+matcherPrefix (RecordMatcher prefix _) = prefix+matcherPrefix (FieldMatcher prefix _ _) = prefix++matcherSetPrefix :: MatcherPrefix -> Matcher -> Matcher+matcherSetPrefix p (RecordMatcher _ r)  = RecordMatcher p r+matcherSetPrefix p (FieldMatcher _ f r) = FieldMatcher p f r++dbgShowMatcher (RecordMatcher Or r)  = show $ reString r+dbgShowMatcher (RecordMatcher p r)  = unwords [dbgShowMatcherPrefix p, show $ reString r]+dbgShowMatcher (FieldMatcher Or f r) = unwords [T.unpack f, show $ reString r]+dbgShowMatcher (FieldMatcher p f r) = unwords [dbgShowMatcherPrefix p, T.unpack f, show $ reString r]++-- | A conditional block: a set of CSV record matchers, and a sequence+-- of rules which will be enabled only if one or more of the matchers+-- succeeds.+--+-- Three types of rule are allowed inside conditional blocks: field+-- assignments, skip, end. (A skip or end rule is stored as if it was+-- a field assignment, and executed in validateCsv. XXX)+data ConditionalBlock = CB {+   cbMatchers    :: [Matcher]+  ,cbAssignments :: [(HledgerFieldName, FieldTemplate)]+  } deriving (Show, Eq)++dbgShowConditionalBlock :: ConditionalBlock -> String+dbgShowConditionalBlock = unwords . map dbgShowMatcher . cbMatchers++defrules :: CsvRulesParsed+defrules = CsvRules' {+  rdirectives=[],+  rcsvfieldindexes=[],+  rassignments=[],+  rconditionalblocks=[],+  rblocksassigning = ()+  }++-- | Create CsvRules from the content parsed out of the rules file+mkrules :: CsvRulesParsed -> CsvRules+mkrules rules =+  let conditionalblocks = reverse $ rconditionalblocks rules+      maybeMemo = if length conditionalblocks >= 15 then memo else id+  in+    CsvRules' {+    rdirectives=reverse $ rdirectives rules,+    rcsvfieldindexes=rcsvfieldindexes rules,+    rassignments=reverse $ rassignments rules,+    rconditionalblocks=conditionalblocks,+    rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks)+    }++--- *** rules parsers+_RULES_PARSING__________________________________________ = undefined++{-+Grammar for the CSV conversion rules, more or less:++RULES: RULE*++RULE: ( SOURCE | ARCHIVE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE++SOURCE: source SPACE FILEPATH++ARCHIVE: archive++FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )*++FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME++QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ "++BARE-FIELD-NAME: (any CHAR except space, tab, #, ;)+++FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE++JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD++JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency++ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? )++FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs and REGEX-MATCHGROUP-REFERENCEs)++CSV-FIELD-REFERENCE: % CSV-FIELD++REGEX-MATCHGROUP-REFERENCE: \ DIGIT+++CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field)++FIELD-NUMBER: DIGIT+++CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK++FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS++MATCHOP: ~++PATTERNS: ( NEWLINE REGEXP )* REGEXP++INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+++REGEXP: ( NONSPACE CHAR* ) SPACE?++VALUE: SPACE? ( CHAR* ) SPACE?++COMMENT: SPACE? COMMENT-CHAR VALUE++COMMENT-CHAR: # | ; | *++NONSPACE: any CHAR not a SPACE-CHAR++BLANK: SPACE?++SPACE: SPACE-CHAR+++SPACE-CHAR: space | tab++CHAR: any character except newline++DIGIT: 0-9++-}++addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed+addDirective d r = r{rdirectives=d:rdirectives r}++addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed+addAssignment a r = r{rassignments=a:rassignments r}++setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs+  where+    setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+    setCsvFieldIndexesFromList fs' r = r{rcsvfieldindexes=zip fs' [1..]}++    addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed+    addAssignmentsFromList fs' r = foldl' maybeAddAssignment r journalfieldnames+      where+        maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs') rules+          where+            addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1))++addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed+addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}++addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed+addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r}++rulesp :: CsvRulesParser CsvRules+rulesp = do+  _ <- many $ choice+    [blankorcommentlinep                                                <?> "blank or comment line"+    ,(directivep        >>= modify' . addDirective)                     <?> "directive"+    ,(fieldnamelistp    >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"+    ,(fieldassignmentp  >>= modify' . addAssignment)                    <?> "field assignment"+    -- conditionalblockp backtracks because it shares "if" prefix with conditionaltablep.+    ,try (conditionalblockp >>= modify' . addConditionalBlock)          <?> "conditional block"+    -- 'reverse' is there to ensure that conditions are added in the order they listed in the file+    ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse)   <?> "conditional table"+    ]+  eof+  mkrules <$> get++blankorcommentlinep :: CsvRulesParser ()+blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]++blanklinep :: CsvRulesParser ()+blanklinep = lift skipNonNewlineSpaces >> newline >> return () <?> "blank line"++commentlinep :: CsvRulesParser ()+commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () <?> "comment line"++commentcharp :: CsvRulesParser Char+commentcharp = oneOf (";#*" :: [Char])++directivep :: CsvRulesParser (DirectiveName, Text)+directivep = (do+  lift $ dbgparse 8 "trying directive"+  d <- choiceInState $ map (lift . string) directives+  v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)+       <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")+  return (d, v)+  ) <?> "directive"++directives :: [Text]+directives =+  ["source"+  ,"archive"+  ,"encoding"+  ,"date-format"+  ,"decimal-mark"+  ,"separator"+  -- ,"default-account"+  -- ,"default-currency"+  ,"skip"+  ,"timezone"+  ,"newest-first"+  ,"intra-day-reversed"+  , "balance-type"+  ]++directivevalp :: CsvRulesParser Text+directivevalp = T.pack <$> anySingle `manyTill` lift eolof++fieldnamelistp :: CsvRulesParser [CsvFieldName]+fieldnamelistp = (do+  lift $ dbgparse 8 "trying fieldnamelist"+  string "fields"+  optional $ char ':'+  lift skipNonNewlineSpaces1+  let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces+  f <- fromMaybe "" <$> optional fieldnamep+  fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)+  lift restofline+  return . map T.toLower $ f:fs+  ) <?> "field name list"++fieldnamep :: CsvRulesParser Text+fieldnamep = quotedfieldnamep <|> barefieldnamep++quotedfieldnamep :: CsvRulesParser Text+quotedfieldnamep =+    char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"'++barefieldnamep :: CsvRulesParser Text+barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char]))++fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)+fieldassignmentp = do+  lift $ dbgparse 8 "trying fieldassignmentp"+  f <- journalfieldnamep+  v <- choiceInState [ assignmentseparatorp >> fieldvalp+                     , lift eolof >> return ""+                     ]+  return (f,v)+  <?> "field assignment"++journalfieldnamep :: CsvRulesParser Text+journalfieldnamep = do+  lift (dbgparse 8 "trying journalfieldnamep")+  choiceInState $ map (lift . string) journalfieldnames++maxpostings = 99++-- Transaction fields and pseudo fields for CSV conversion.+-- Names must precede any other name they contain, for the parser+-- (amount-in before amount; date2 before date). TODO: fix+journalfieldnames =+  concat [[ "account" <> i+          ,"amount" <> i <> "-in"+          ,"amount" <> i <> "-out"+          ,"amount" <> i+          ,"balance" <> i+          ,"comment" <> i+          ,"currency" <> i+          ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x]+  +++  ["amount-in"+  ,"amount-out"+  ,"amount"+  ,"balance"+  ,"code"+  ,"comment"+  ,"currency"+  ,"date2"+  ,"date"+  ,"description"+  ,"status"+  ,"skip" -- skip and end are not really fields, but we list it here to allow conditional rules that skip records+  ,"end"+  ]++assignmentseparatorp :: CsvRulesParser ()+assignmentseparatorp = do+  lift $ dbgparse 8 "trying assignmentseparatorp"+  _ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces+                     , lift skipNonNewlineSpaces1+                     ]+  return ()++fieldvalp :: CsvRulesParser Text+fieldvalp = do+  lift $ dbgparse 8 "trying fieldvalp"+  T.pack <$> anySingle `manyTill` lift eolof++-- A conditional block: one or more matchers, one per line, followed by one or more indented rules.+conditionalblockp :: CsvRulesParser ConditionalBlock+conditionalblockp = do+  lift $ dbgparse 8 "trying conditionalblockp"+  -- "if\nMATCHER" or "if    \nMATCHER" or "if MATCHER"+  start <- getOffset+  string "if" >> ( (newline >> return Nothing)+                  <|> (lift skipNonNewlineSpaces1 >> optional newline))+  ms <- some matcherp+  as <- catMaybes <$>+    many (lift skipNonNewlineSpaces1 >>+          choice [ lift eolof >> return Nothing+                 , fmap Just fieldassignmentp+                 ])+  when (null as) $+    customFailure $ parseErrorAt start $  "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)"+  return $ CB{cbMatchers=ms, cbAssignments=as}+  <?> "conditional block"++-- A conditional table: "if" followed by separator, followed by some field names,+-- followed by many lines, each of which is either:+-- a comment line, or ...+-- one matcher, followed by field assignments (as many as there were fields in the header)+conditionaltablep :: CsvRulesParser [ConditionalBlock]+conditionaltablep = do+  lift $ dbgparse 8 "trying conditionaltablep"+  start <- getOffset+  string "if"+  sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))+  fields <- journalfieldnamep `sepBy1` (char sep)+  newline+  body <- catMaybes <$> (flip manyTill (lift eolof) $+          choice [ commentlinep >> return Nothing+                 , fmap Just $ bodylinep sep fields+                 ])+  when (null body) $+    customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward"+  return $ flip map body $ \(ms,vs) ->+    CB{cbMatchers=ms, cbAssignments=zip fields vs}+  <?> "conditional table"+  where+    bodylinep :: Char -> [Text] -> CsvRulesParser ([Matcher],[FieldTemplate])+    bodylinep sep fields = do+      off <- getOffset+      ms <- matcherp' (lookAhead . void . char $ sep) `manyTill` char sep+      vs <- T.split (==sep) . T.pack <$> lift restofline+      if (length vs /= length fields)+        then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String)+        else return (ms,vs)+++-- A single matcher, on one line.+-- This tries to parse first as a field matcher, then if that fails, as a whole-record matcher;+-- the goal was to not break legacy whole-record patterns that happened to look a bit like a field matcher+-- (eg, beginning with %, possibly preceded by & or !), or at least not to raise an error.+matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher+matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end++matcherp :: CsvRulesParser Matcher+matcherp = matcherp' (lift eolof)++-- A single whole-record matcher.+-- A pattern on the whole line, not beginning with a csv field reference.+recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher+recordmatcherp end = do+  lift $ dbgparse 8 "trying recordmatcherp"+  -- pos <- currentPos+  -- _  <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline)+  p <- matcherprefixp+  r <- regexp end+  return $ RecordMatcher p r+  -- when (null ps) $+  --   Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)"+  <?> "record matcher"++-- | A single matcher for a specific field. A csv field reference+-- (like %date or %1), and a pattern on the rest of the line,+-- optionally space-separated. Eg:+-- %description chez jacques+fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher+fieldmatcherp end = do+  lift $ dbgparse 8 "trying fieldmatcher"+  -- An optional fieldname (default: "all")+  -- f <- fromMaybe "all" `fmap` (optional $ do+  --        f' <- fieldnamep+  --        lift skipNonNewlineSpaces+  --        return f')+  p <- matcherprefixp+  f <- csvfieldreferencep <* lift skipNonNewlineSpaces+  -- optional operator.. just ~ (case insensitive infix regex) for now+  -- _op <- fromMaybe "~" <$> optional matchoperatorp+  lift skipNonNewlineSpaces+  r <- regexp end+  return $ FieldMatcher p f r+  <?> "field matcher"++matcherprefixp :: CsvRulesParser MatcherPrefix+matcherprefixp = do+  lift $ dbgparse 8 "trying matcherprefixp"+  (do+    char '&' >> optional (char '&') >> lift skipNonNewlineSpaces+    fromMaybe And <$> optional (char '!' >> lift skipNonNewlineSpaces >> return AndNot))+  <|> (char '!' >> lift skipNonNewlineSpaces >> return Not)+  <|> return Or++csvfieldreferencep :: CsvRulesParser CsvFieldReference+csvfieldreferencep = do+  lift $ dbgparse 8 "trying csvfieldreferencep"+  char '%'+  T.cons '%' . textQuoteIfNeeded <$> fieldnamep+    -- XXX this parses any generic field name, which may not actually be a valid CSV field name [#2289]++-- A single regular expression+regexp :: CsvRulesParser () -> CsvRulesParser Regexp+regexp end = do+  lift $ dbgparse 8 "trying regexp"+  -- notFollowedBy matchoperatorp+  c <- lift nonspace+  cs <- anySingle `manyTill` (double_ampersand <|> end)+  case toRegexCI . T.strip . T.pack $ c:cs of+       Left x -> Fail.fail $ "CSV parser: " ++ x+       Right x -> return x+  where+    double_ampersand = lookAhead . void $ string "&&"++-- -- A match operator, indicating the type of match to perform.+-- -- Currently just ~ meaning case insensitive infix regex match.+-- matchoperatorp :: CsvRulesParser String+-- matchoperatorp = fmap T.unpack $ choiceInState $ map string+--   ["~"+--   -- ,"!~"+--   -- ,"="+--   -- ,"!="+--   ]++_RULES_LOOKUP__________________________________________ = undefined++getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate+getDirective directivename = lookup directivename . rdirectives++-- | Look up the value (template) of a csv rule by rule keyword.+csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate+csvRule rules = (`getDirective` rules)++-- | Look up the value template assigned to a hledger field by field+-- list/field assignment rules, taking into account the current record and+-- conditional rules.+hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate+hledgerField rules record f = fmap+  (either id (lastCBAssignmentTemplate f))+  (getEffectiveAssignment rules record f)++-- | Look up the final value assigned to a hledger field, with csv field+-- references and regular expression match group references interpolated.+hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text+hledgerFieldValue rules record f = (flip fmap) (getEffectiveAssignment rules record f)+  $ either (renderTemplate rules record)+  $ \cb -> let+      t = lastCBAssignmentTemplate f cb+      r = rules { rconditionalblocks = [cb] } -- XXX handle rblocksassigning+      in renderTemplate r record t++lastCBAssignmentTemplate :: HledgerFieldName -> ConditionalBlock -> FieldTemplate+lastCBAssignmentTemplate f = snd . last . filter ((==f).fst) . cbAssignments++maybeNegate :: MatcherPrefix -> Bool -> Bool+maybeNegate Not origbool = not origbool+maybeNegate _   origbool = origbool++-- | Given the conversion rules, a CSV record and a hledger field name, find+-- either the last applicable `ConditionalBlock`, or the final value template+-- assigned to this field by a top-level field assignment, if any exist.+--+-- Note conditional blocks' patterns are matched against an approximation of the+-- CSV record: all the field values, without enclosing quotes, comma-separated.+--+getEffectiveAssignment+  :: CsvRules+     -> CsvRecord+     -> HledgerFieldName+     -> Maybe (Either FieldTemplate ConditionalBlock)+getEffectiveAssignment rules record f = lastMay assignments+  where+    -- all active assignments to field f, in order+    assignments = toplevelassignments ++ conditionalassignments+    -- all top level field assignments+    toplevelassignments    = map (Left . snd) $ filter ((==f).fst) $ rassignments rules+    -- all conditional blocks assigning to field f and active for the current csv record+    conditionalassignments = map Right+                           $ filter (any (==f) . map fst . cbAssignments)+                           $ dbg'+                           $ filter (isBlockActive rules record)+                           $ (rblocksassigning rules) f++    dbg' [] = []+    dbg' ms = dbg2Msg (+      " for the " ++ T.unpack f ++ " field, these if rules matched:"+      ++ concatMap (("\n  " ++) . dbgShowConditionalBlock) ms+      ) ms++-- does this conditional block match the current csv record ?+isBlockActive :: CsvRules -> CsvRecord -> ConditionalBlock -> Bool+isBlockActive rules record CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers+  where+    -- Does this individual matcher match the current csv record ?+    -- A matcher's target can be a specific CSV field, or the "whole record".+    --+    -- In the former case, note that the field reference must be either numeric or+    -- a csv field name declared by a `fields` rule; anything else will emit a warning to stderr+    -- (to reduce confusion when a hledger field name doesn't work; not an error, to avoid breaking legacy rules; see #2289).+    --+    -- In the latter case, the matched value will be a synthetic CSV record.+    -- Note this will not necessarily be the same as the original CSV record:+    -- the field separator will be comma, and quotes enclosing field values,+    -- and any whitespace outside those quotes, will be removed.+    -- (This means that a field containing a comma will now look like two fields.)+    --+    matcherMatches :: Matcher -> Bool+    matcherMatches = \case+      RecordMatcher prefix             pat -> maybeNegate prefix $ match pat $ recordAsApproximateText record+      FieldMatcher  prefix csvfieldref pat -> maybeNegate prefix $ match pat $+        fromMaybe "" $ replaceCsvFieldReference rules record csvfieldref+        -- (warn msg "") where msg = "if "<>T.unpack csvfieldref<>": this should be a name declared with 'fields', or %NUM"+        --  #2289: we'd like to warn the user when an unknown CSV field is being referenced,+        --  but it's useful to ignore it for easier reuse of rules files.+      where match p v = regexMatchText (dbg7 "regex" p) (dbg7 "value" v)++    -- | Group matchers into associative pairs based on prefix, e.g.:+    --   A+    --   & B+    --   C+    --   D+    --   & E+    --   => [[A, B], [C], [D, E]]+    --  & ! M (and not M) are converted to ! M (not M) within the and groups.+    groupedMatchers :: [Matcher] -> [[Matcher]]+    groupedMatchers [] = []+    groupedMatchers (m:ms) = (m:ands) : groupedMatchers rest+      where+        (andandnots, rest) = span (\a -> matcherPrefix a `elem` [And, AndNot]) ms+        ands = [matcherSetPrefix p a | a <- andandnots, let p = if matcherPrefix a == AndNot then Not else And]++-- | Convert a CSV record to text, for whole-record matching.+-- This will be only an approximation of the original record;+-- values will always be comma-separated,+-- and any enclosing quotes and whitespace outside those quotes will be removed.+recordAsApproximateText :: CsvRecord -> Text+recordAsApproximateText = T.intercalate ","++-- | Render a field assignment's template, possibly interpolating referenced+-- CSV field values or match groups. Outer whitespace is removed from interpolated values.+renderTemplate ::  CsvRules -> CsvRecord -> FieldTemplate -> Text+renderTemplate rules record t =+  maybe t mconcat $ parseMaybe+    (many+      (   literaltextp+      <|> (matchrefp <&> replaceRegexGroupReference rules record)+      <|> (fieldrefp <&> replaceCsvFieldReference   rules record <&> fromMaybe "")+      )+    )+    t+  where+    literaltextp :: SimpleTextParser Text+    literaltextp = some (nonBackslashOrPercent <|> nonRefBackslash <|> nonRefPercent) <&> T.pack+      where+        nonBackslashOrPercent = noneOf ['\\', '%'] <?> "character other than backslash or percent"+        nonRefBackslash = try (char '\\' <* notFollowedBy digitChar) <?> "backslash that does not begin a match group reference"+        nonRefPercent   = try (char '%'  <* notFollowedBy (satisfy isFieldNameChar)) <?> "percent that does not begin a field reference"+    matchrefp    = liftA2 T.cons (char '\\') (takeWhile1P (Just "matchref")  isDigit)+    fieldrefp    = liftA2 T.cons (char '%')  (takeWhile1P (Just "reference") isFieldNameChar)+    isFieldNameChar c = isAlphaNum c || c == '_' || c == '-'++-- | Replace something that looks like a Regex match group reference with the+-- resulting match group value after applying the Regex.+replaceRegexGroupReference :: CsvRules -> CsvRecord -> MatchGroupReference -> Text+replaceRegexGroupReference rules record s = case T.uncons s of+    Just ('\\', group) -> fromMaybe "" $ regexMatchValue rules record group+    _                  -> s++regexMatchValue :: CsvRules -> CsvRecord -> Text -> Maybe Text+regexMatchValue rules record sgroup = let+  matchgroups  = concatMap (getMatchGroups rules record)+               $ concatMap cbMatchers+               $ filter (isBlockActive rules record)+               $ rconditionalblocks rules+               -- XXX adjusted to not use memoized field as caller might be sending a subset of rules with just one CB (hacky)+  group = (read (T.unpack sgroup) :: Int) - 1 -- adjust to 0-indexing+  in atMay matchgroups group++getMatchGroups :: CsvRules -> CsvRecord -> Matcher -> [Text]+getMatchGroups _ record (RecordMatcher _ regex) =+  regexMatchTextGroups regex $ recordAsApproximateText record  -- groups might be wrong+getMatchGroups rules record (FieldMatcher _ fieldref regex) =+  regexMatchTextGroups regex $ fromMaybe "" $ replaceCsvFieldReference rules record fieldref++-- | Replace something that looks like a reference to a csv field ("%date" or "%1)+-- with that field's value. If it doesn't look like a field reference, or if we+-- can't find a csv field with that name, return nothing.+replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Maybe Text+replaceCsvFieldReference rules record s = case T.uncons s of+    Just ('%', fieldname) -> csvFieldValue rules record fieldname+    _                     -> Nothing++-- | Get the (whitespace-stripped) value of a CSV field, identified by its name or+-- column number, ("date" or "1"), from the given CSV record, if such a field exists.+csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text+csvFieldValue rules record fieldname = do+  fieldindex <-+    if T.all isDigit fieldname+    then readMay $ T.unpack fieldname+    else lookup (T.toLower fieldname) $ rcsvfieldindexes rules+  T.strip <$> atMay record (fieldindex-1)++_CSV_READING__________________________________________ = undefined++-- | Read a Journal from the given CSV data (and filename, used for error+-- messages), or return an error. Proceed as follows:+--+-- 1. Conversion rules are provided, or they are parsed from the specified+--    rules file, or from the default rules file for the CSV data file.+--    If rules parsing fails, or the required rules file does not exist, throw an error.+--+-- 2. Parse the CSV data using the rules, or throw an error.+--+-- 3. Convert the CSV records to hledger transactions using the rules.+--+-- 4. Return the transactions as a Journal.+--+readJournalFromCsv :: CsvRules -> FilePath -> Text -> Maybe SepFormat -> ExceptT String IO Journal+readJournalFromCsv rules csvfile csvtext sep = do+    -- for now, correctness is the priority here, efficiency not so much++    dbg6IO "csv rules" rules++    -- convert the csv data to lines and remove all empty/blank lines+    let csvlines1 = dbg9 "csvlines1" $ filter (not . T.null . T.strip) $ dbg9 "csvlines0" $ T.lines csvtext++    -- if there is a top-level skip rule, skip the specified number of non-empty lines+    skiplines <- case getDirective "skip" rules of+                      Nothing -> return 0+                      Just "" -> return 1+                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ T.unpack s) return . readMay $ T.unpack s+    let csvlines2 = dbg9 "csvlines2" $ drop skiplines csvlines1++    -- convert back to text and parse as csv records+    let+      csvtext1 = T.unlines csvlines2+      -- The separator in the rules file takes precedence over the extension or prefix+      separator = case getDirective "separator" rules >>= parseSeparator of+        Just c           -> c+        _ | ext == "ssv" -> ';'+        _ | ext == "tsv" -> '\t'+        _                -> +          case sep of+            Just Csv -> ','+            Just Ssv -> ';'+            Just Tsv -> '\t'+            Nothing -> ','+        where+          ext = map toLower $ drop 1 $ takeExtension csvfile+      -- parsec seemed to fail if you pass it "-" here   -- TODO: try again with megaparsec+      parsecfilename = if csvfile == "-" then "(stdin)" else csvfile+    dbg6IO "using separator" separator+    -- parse csv records+    csvrecords0 <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvtext1+    -- remove any records skipped by conditional skip or end rules+    let csvrecords1 = applyConditionalSkips rules csvrecords0+    -- and check the remaining records for any obvious problems+    csvrecords <- liftEither $ dbg7 "validateCsv" <$> validateCsv csvrecords1+    dbg6IO "first 3 csv records" $ take 3 csvrecords++    -- XXX identify header lines some day ?+    -- let (headerlines, datalines) = identifyHeaderLines csvrecords'+    --     mfieldnames = lastMay headerlines++    tzout <- liftIO getCurrentTimeZone+    mtzin <- case getDirective "timezone" rules of+              Nothing -> return Nothing+              Just s  ->+                maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $+                parseTimeM False defaultTimeLocale "%Z" $ T.unpack s+    let+      -- convert CSV records to transactions, saving the CSV line numbers for error positions+      txns = dbg7 "csv txns" $ snd $ mapAccumL+                     (\pos r ->+                        let+                          SourcePos name line col = pos+                          line' = (mkPos . (+1) . unPos) line+                          pos' = SourcePos name line' col+                        in+                          (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r)+                     )+                     (initialPos parsecfilename) csvrecords+        where+          timesarezoned =+            case csvRule rules "date-format" of+              Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True+              _ -> False++      -- Do our best to ensure transactions will be ordered chronologically,+      -- from oldest to newest. This is done in several steps:+      -- 1. Intra-day order: if there's an "intra-day-reversed" rule,+      -- assume each day's CSV records were ordered in reverse of the overall date order,+      -- so reverse each day's txns.+      intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules+      txns1 = dbg7 "txns1" $+        (if intradayreversed then concatMap reverse . groupOn tdate else id) txns+      -- 2. Overall date order: now if there's a "newest-first" rule,+      -- or if there's multiple dates and the first is more recent than the last,+      -- assume CSV records were ordered newest dates first,+      -- so reverse all txns.+      newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules+      mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $+        case nub $ map tdate txns of+          ds@(d:_) -> Just $ d > last ds+          []       -> Nothing+      txns2 = dbg7 "txns2" $+        (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1+      -- 3. Disordered dates: in case the CSV records were ordered by chaos,+      -- do a final sort by date. If it was only a few records out of order,+      -- this will hopefully refine any good ordering done by steps 1 and 2.+      txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2++    return nulljournal{jtxns=txns3}++-- | Parse special separator names TAB and SPACE, or return the first+-- character. Return Nothing on empty string+parseSeparator :: Text -> Maybe Char+parseSeparator = specials . T.toLower+  where specials "space" = Just ' '+        specials "tab"   = Just '\t'+        specials xs      = fst <$> T.uncons xs++-- Call parseCassava on a file or stdin, converting the result to ExceptT.+parseCsv :: Char -> FilePath -> Text -> ExceptT String IO [CsvRecord]+parseCsv separator filePath csvtext = ExceptT $+  case filePath of+    "-" -> parseCassava separator "(stdin)" <$> T.getContents+    _   -> return $ if T.null csvtext then Right mempty else parseCassava separator filePath csvtext++-- Parse text into CSV records, using Cassava and the given field separator.+parseCassava :: Char -> FilePath -> Text -> Either String [CsvRecord]+parseCassava separator path content =+  -- XXX we now remove all blank lines before parsing; will Cassava will still produce [""] records ?+  -- filter (/=[""])+  either (Left . errorBundlePretty) (Right . parseResultToCsv) <$>+  CassavaMegaparsec.decodeWith decodeOptions Cassava.NoHeader path $+  BL.fromStrict $ T.encodeUtf8 content+  where+    decodeOptions = Cassava.defaultDecodeOptions {+                      Cassava.decDelimiter = fromIntegral (ord separator)+                    }+    parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> [CsvRecord]+    parseResultToCsv = toListList . unpackFields+      where+        toListList = toList . fmap toList+        unpackFields  = (fmap . fmap) T.decodeUtf8++-- | Scan for csv records where a conditional `skip` or `end` rule applies,+-- and apply that rule, removing one or more following records.+applyConditionalSkips :: CsvRules -> [CsvRecord] -> [CsvRecord]+applyConditionalSkips _ [] = []+applyConditionalSkips rules (r:rest) =+  case skipnum r of+    Nothing -> r : applyConditionalSkips rules rest+    Just cnt -> applyConditionalSkips rules $ drop (cnt-1) rest+  where+    skipnum r1 =+      case (hledgerField rules r1 "end", hledgerField rules r1 "skip") of+        (Nothing, Nothing) -> Nothing+        (Just _, _) -> Just maxBound+        (Nothing, Just "") -> Just 1+        (Nothing, Just x) -> Just (read $ T.unpack x)++-- | Do some validation on the parsed CSV records:+-- check that they all have at least two fields.+validateCsv :: [CsvRecord] -> Either String [CsvRecord]+validateCsv [] = Right []+validateCsv rs@(_first:_) =+  case lessthan2 of+    Just r  -> Left $ printf "CSV record %s has less than two fields" (show r)+    Nothing -> Right rs+  where+    lessthan2 = headMay $ filter ((<2).length) rs++-- -- | The highest (0-based) field index referenced in the field+-- -- definitions, or -1 if no fields are defined.+-- maxFieldIndex :: CsvRules -> Int+-- maxFieldIndex r = maximumDef (-1) $ catMaybes [+--                    dateField r+--                   ,statusField r+--                   ,codeField r+--                   ,amountField r+--                   ,amountInField r+--                   ,amountOutField r+--                   ,currencyField r+--                   ,accountField r+--                   ,account2Field r+--                   ,date2Field r+--                   ]++--- ** converting csv records to transactions++transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction+transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record =+  -- log the record and all the transaction fields from this record+  -- XXX avoid possibly-pessimising deepseq if not needed for debug output ?+  dbg2Msg (T.unpack $ showRecord record) $ deepseq t+  t+  where++    ----------------------------------------------------------------------+    -- 1. Define some helpers:++    rule     = csvRule           rules        :: DirectiveName    -> Maybe FieldTemplate+    -- ruleval  = csvRuleValue      rules record :: DirectiveName    -> Maybe String+    field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate+    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text+    mdateformat = rule "date-format"+    parseDate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat+    mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines+      ["could not parse \""<>datevalue<>"\" as a date using date format "+        <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat'+      ,showRecord record+      ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield)+      ,"the date-format is: "<>fromMaybe "unspecified" mdateformat'+      ,"you may need to "+        <>"change your "<>datefield<>" rule, "+        <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, "+        <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"+      ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"+      ]+      where+        mskip = rule "skip"++    ----------------------------------------------------------------------+    -- 2. Gather values needed for the transaction itself, by evaluating the+    -- field assignment rules using the CSV record's data, and parsing a bit+    -- more where needed (dates, status).++    date        = fromMaybe "" $ fieldval "date"+    -- PARTIAL:+    date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parseDate date+    mdate2      = fieldval "date2"+    mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parseDate) =<< mdate2+    status      =+      case fieldval "status" of+        Nothing -> Unmarked+        Just s  -> either statuserror id $ runParser (statusp <* eof) "" s+          where+            statuserror err = error' . T.unpack $ T.unlines+              ["could not parse status value \""<>s<>"\" (should be *, ! or empty)"+              ,"the parse error is:      "<>T.pack (customErrorBundlePretty err)+              ]+    code        = maybe "" singleline' $ fieldval "code"+    description = maybe "" singleline' $ fieldval "description"+    comment     = maybe "" unescapeNewlines $ fieldval "comment"++    -- Convert some parsed comment text back into following comment syntax,+    -- with the semicolons and indents, so it can be parsed again for tags.+    textToFollowingComment :: Text -> Text+    textToFollowingComment = T.stripStart . T.unlines . map (" ;"<>) . T.lines++    ttags       = fromRight [] $ fmap snd $ rtp transactioncommentp $ textToFollowingComment comment+    precomment  = maybe "" unescapeNewlines $ fieldval "precomment"++    singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines+    unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n"++    ----------------------------------------------------------------------+    -- 3. Generate the postings for which an account has been assigned+    -- (possibly indirectly due to an amount or balance assignment)++    p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting+    ps = [p | n <- [1..maxpostings]+         ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n))+          -- Tags in the comment will be parsed and attached to the posting.+          -- A posting date, in the date: tag or in brackets, will also be parsed and applied to the posting.+          -- But it must have a year, or it will be ignored.+          -- A secondary posting date will also be ignored.+         ,let (tags,mdate) =+                fromRight ([],Nothing) $+                fmap (\(_,ts,md,_)->(ts,md)) $+                rtp (postingcommentp Nothing) $+                textToFollowingComment cmt+         ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")+         ,let mamount  = getAmount rules record currency p1IsVirtual n+         ,let mbalance = getBalance rules record currency n+         ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n]  -- skips Nothings+         ,let acct' | not isfinal && acct==unknownExpenseAccount &&+                      fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount+                    | otherwise = acct+         ,let p = nullposting{pdate             = mdate+                             ,paccount          = accountNameWithoutPostingType acct'+                             ,pamount           = fromMaybe missingmixedamt mamount+                             ,ptransaction      = Just t+                             ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance+                             ,pcomment          = cmt+                             ,ptags             = tags+                             ,ptype             = accountNamePostingType acct+                             }+         ]++    ----------------------------------------------------------------------+    -- 4. Build the transaction (and name it, so the postings can reference it).++    t = nulltransaction{+           tsourcepos        = (sourcepos, sourcepos)  -- the CSV line number+          ,tdate             = date'+          ,tdate2            = mdate2'+          ,tstatus           = status+          ,tcode             = code+          ,tdescription      = description+          ,tcomment          = comment+          ,ttags             = ttags+          ,tprecedingcomment = precomment+          ,tpostings         = ps+          }++-- | Parse the date string using the specified date-format, or if unspecified+-- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading+-- zeroes optional). If a timezone is provided, we assume the DateFormat+-- produces a zoned time and we localise that to the given timezone.+parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day+parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime+  -- this time code can probably be simpler, I'm just happy to get out alive+  where+    localdate :: UTCTime -> Day =+      localDay .+      dbg7 ("time in output timezone "++show tzout) .+      utcToLocalTime tzout+    mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats++    parseWithFormat :: String -> Maybe UTCTime+    parseWithFormat fmt =+      if timesarezoned+      then+        dbg7 "zoned CSV time, expressed as UTC" $+        parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime+      else+        -- parse as a local day and time; then if an input timezone is provided,+        -- assume it's in that, otherwise assume it's in the output timezone;+        -- then convert to UTC like the above+        let+          mlocaltime =+            fmap (dbg7 "unzoned CSV time") $+            parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime+          localTimeAsZonedTime tz lt =  ZonedTime lt tz+        in+          case mtzin of+            Just tzin ->+              (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") .+              localTimeToUTC tzin)+              <$> mlocaltime+            Nothing ->+              (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") .+                zonedTimeToUTC .+                localTimeAsZonedTime tzout)+              <$> mlocaltime++    formats = map T.unpack $ maybe+               ["%Y/%-m/%-d"+               ,"%Y-%-m-%-d"+               ,"%Y.%-m.%-d"+               -- ,"%-m/%-d/%Y"+                -- ,parseTimeM TruedefaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)+                -- ,parseTimeM TruedefaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)+                -- ,parseTimeM TruedefaultTimeLocale "%m/%e/%Y" ('0':s)+                -- ,parseTimeM TruedefaultTimeLocale "%m-%e-%Y" ('0':s)+               ]+               (:[])+                mformat++-- | Figure out the amount specified for posting N, if any.+-- A currency symbol to prepend to the amount, if any, is provided,+-- and whether posting 1 requires balancing or not.+-- This looks for a non-empty amount value assigned to "amountN", "amountN-in", or "amountN-out".+-- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out".+-- If more than one of these has a value, it looks for one that is non-zero.+-- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error.+getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount+getAmount rules record currency p1IsVirtual n =+  -- Warning! Many tricky corner cases here.+  -- Keep synced with:+  -- hledger_csv.m4.md -> CSV FORMAT -> "amount", "Setting amounts",+  -- hledger/test/csv.test -> 13, 31-34+  let+    unnumberedfieldnames = ["amount","amount-in","amount-out"]++    -- amount field names which can affect this posting+    fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"]+                 -- For posting 1, also recognise the old amount/amount-in/amount-out names.+                 -- For posting 2, the same but only if posting 1 needs balancing.+                 ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []++    -- assignments to any of these field names with non-empty values+    assignments = [(f,a') | f <- fieldnames+                          , Just v <- [T.strip <$> hledgerFieldValue rules record f]+                          , not $ T.null v+                          -- XXX maybe ignore rule-generated values like "", "-", "$", "-$", "$-" ? cf CSV FORMAT -> "amount", "Setting amounts",+                          , let a = parseAmount rules record currency v+                          -- With amount/amount-in/amount-out, in posting 2,+                          -- flip the sign and convert to cost, as they did before 1.17+                          , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a+                          ]++    -- if any of the numbered field names are present, discard all the unnumbered ones+    discardUnnumbered xs = if null numbered then xs else numbered+      where+        numbered = filter (T.any isDigit . fst) xs++    -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first+    discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros+      where+        nonzeros = filter (not . mixedAmountLooksZero . snd) xs++    -- for -out fields, flip the sign  XXX unless it's already negative ? back compat issues / too confusing ?+    negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id++  in case discardExcessZeros $ discardUnnumbered assignments of+      []      -> Nothing+      [(f,a)] -> Just $ negateIfOut f a+      fs      -> error' . T.unpack . textChomp . T.unlines $+        ["in CSV rules:"+        ,"While processing " <> showRecord record+        ,"while calculating amount for posting " <> T.pack (show n)+        ] +++        ["rule \"" <> f <> " " <>+          fromMaybe "" (hledgerField rules record f) <>+          "\" assigned value \"" <> wbToText (showMixedAmountB defaultFmt a) <> "\"" -- XXX not sure this is showing all the right info+          | (f,a) <- fs+        ] +++        [""+        ,"Multiple non-zero amounts were assigned for an amount field."+        ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule."+        ,"See also: https://hledger.org/hledger.html#setting-amounts"+        ,"(hledger manual -> CSV format -> Tips -> Setting amounts)"+        ]+-- | Figure out the expected balance (assertion or assignment) specified for posting N,+-- if any (and its parse position).+getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos)+getBalance rules record currency n = do+  v <- (fieldval ("balance"<> T.pack (show n))+        -- for posting 1, also recognise the old field name+        <|> if n==1 then fieldval "balance" else Nothing)+  case v of+    "" -> Nothing+    s  -> Just (+            parseBalanceAmount rules record currency n s+           ,initialPos ""  -- parse position to show when assertion fails,+           )               -- XXX the csv record's line number would be good+  where+    fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text++-- | Given a non-empty amount string (from CSV) to parse, along with a+-- possibly non-empty currency symbol to prepend,+-- parse as a hledger MixedAmount (as in journal format), or raise an error.+-- The whole CSV record is provided for the error message.+parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount+parseAmount rules record currency s =+    either mkerror mixedAmount $+    runParser (evalStateT (amountp <* eof) journalparsestate) "" $+    currency <> simplifySign s+  where+    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}+    mkerror e = error' . T.unpack $ T.unlines+      ["could not parse \"" <> s <> "\" as an amount"+      ,showRecord record+      ,showRules rules record+      -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)+      ,"the parse error is:      " <> T.pack (customErrorBundlePretty e)+      ,"you may need to change your amount*, balance*, or currency* rules, or add or change your skip rule"+      ]++-- | Show the values assigned to each journal field.+showRules rules record = T.unlines $ catMaybes+  [ (("the "<>fld<>" rule is: ")<>) <$>+    hledgerField rules record fld | fld <- journalfieldnames ]++-- XXX unify these ^v++-- | Almost but not quite the same as parseAmount.+-- Given a non-empty amount string (from CSV) to parse, along with a+-- possibly non-empty currency symbol to prepend,+-- parse as a hledger Amount (as in journal format), or raise an error.+-- The CSV record and the field's numeric suffix are provided for the error message.+parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount+parseBalanceAmount rules record currency n s =+  either (mkerror n s) id $+    runParser (evalStateT (amountp <* eof) journalparsestate) "" $+    currency <> simplifySign s+                  -- the csv record's line number would be good+  where+    journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}+    mkerror n' s' e = error' . T.unpack $ T.unlines+      ["could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount"+      ,showRecord record+      ,showRules rules record+      -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency+      ,"the parse error is:      "<> T.pack (customErrorBundlePretty e)+      ]++-- | Show the approximation of the original CSV record, labelled, for debug output.+showRecord :: CsvRecord -> Text+showRecord = ("record: "<>) . recordAsApproximateText++-- Read a valid decimal mark from the decimal-mark rule, if any.+-- If the rule is present with an invalid argument, raise an error.+parseDecimalMark :: CsvRules -> Maybe DecimalMark+parseDecimalMark rules = do+    s <- rules `csvRule` "decimal-mark"+    case T.uncons s of+        Just (c, rest) | T.null rest && isDecimalMark c -> return c+        _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")"++-- | Make a balance assertion for the given amount, with the given parse+-- position (to be shown in assertion failures), with the assertion type+-- possibly set by a balance-type rule.+-- The CSV rules and current record are also provided, to be shown in case+-- balance-type's argument is bad (XXX refactor).+mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion+mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}+  where+    assrt =+      case getDirective "balance-type" rules of+        Nothing -> nullassertion+        Just x  ->+          case parseBalanceAssertionType $ T.unpack x of+            Just (total, inclusive) -> nullassertion{batotal=total, bainclusive=inclusive}+            Nothing -> error' . T.unpack $ T.unlines  -- PARTIAL:+              [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*."+              , showRecord record+              , showRules rules record+              ]++-- | Detect from a balance assertion's syntax (=, ==, =*, ==*)+-- whether it is (a) total (multi-commodity) and (b) subaccount-inclusive.+-- Returns nothing if invalid syntax was provided.+parseBalanceAssertionType :: String -> Maybe (Bool, Bool)+parseBalanceAssertionType = \case+  "="   -> Just (False, False)+  "=="  -> Just (True,  False)+  "=*"  -> Just (False, True )+  "==*" -> Just (True,  True )+  _     -> Nothing++-- | Figure out the account name specified for posting N, if any.+-- And whether it is the default unknown account (which may be+-- improved later) or an explicitly set account (which may not).+getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool)+getAccount rules record mamount mbalance n =+  let+    fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text+    maccount = T.strip <$> fieldval ("account"<> T.pack (show n))+  in case maccount of+    -- accountN is set to the empty string - no posting will be generated+    Just "" -> Nothing+    -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final+    Just a  ->+      -- Check it and reject if invalid.. sometimes people try+      -- to set an amount or comment along with the account name.+      case parsewith (accountnamep >> eof) a of+        Left e  -> usageError $ errorBundlePretty e+        Right _ -> Just (a, True)+    -- accountN is unset+    Nothing ->+      case (mamount, mbalance) of+        -- amountN is set, or implied by balanceN - set accountN to+        -- the default unknown account ("expenses:unknown") and+        -- allow it to be improved later+        (Just _, _) -> Just (unknownExpenseAccount, False)+        (_, Just _) -> Just (unknownExpenseAccount, False)+        -- amountN is also unset - no posting will be generated+        (Nothing, Nothing) -> Nothing++-- | Default account names to use when needed.+unknownExpenseAccount = "expenses:unknown"+unknownIncomeAccount  = "income:unknown"++type CsvAmountString = Text++-- | Canonicalise the sign in a CSV amount string.+-- Such strings can have a minus sign, parentheses (equivalent to minus),+-- or any two of these (which cancel out),+-- or a plus sign (which is removed),+-- or any sign by itself with no following number (which is removed).+-- See hledger > CSV FORMAT > Tips > Setting amounts.+--+-- These are supported (note, not every possibile combination):+--+-- >>> simplifySign "1"+-- "1"+-- >>> simplifySign "+1"+-- "1"+-- >>> simplifySign "-1"+-- "-1"+-- >>> simplifySign "(1)"+-- "-1"+-- >>> simplifySign "--1"+-- "1"+-- >>> simplifySign "-(1)"+-- "1"+-- >>> simplifySign "-+1"+-- "-1"+-- >>> simplifySign "(-1)"+-- "1"+-- >>> simplifySign "((1))"+-- "1"+-- >>> simplifySign "-"+-- ""+-- >>> simplifySign "()"+-- ""+-- >>> simplifySign "+"+-- ""+simplifySign :: CsvAmountString -> CsvAmountString+simplifySign amtstr+  | Just (' ',t) <- T.uncons amtstr = simplifySign t+  | Just (t,' ') <- T.unsnoc amtstr = simplifySign t+  | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt+  | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt+  | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt+  | Just ('-',m) <- T.uncons amtstr, Just ('+',amt) <- T.uncons m = negateStr amt+  | amtstr `elem` ["-","+","()"] = ""+  | Just ('+',amt) <- T.uncons amtstr = simplifySign amt+  | otherwise = amtstr++negateStr :: Text -> Text+negateStr amtstr = case T.uncons amtstr of+    Just ('-',s) -> s+    _            -> T.cons '-' amtstr++--- ** tests+_TESTS__________________________________________ = undefined++tests_RulesReader = testGroup "RulesReader" [+   testGroup "parseCsvRules" [+     testCase "empty file" $+      parseCsvRules "unknown" "" @?= Right (mkrules defrules)+   ]+  ,testGroup "rulesp" [+     testCase "trailing comments" $+      parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]})++    ,testCase "trailing blank lines" $+      parseWithState' defrules rulesp "skip\n\n  \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]}))++    ,testCase "no final newline" $+      parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]}))++    ,testCase "assignment with empty value" $+      parseWithState' defrules rulesp "account1 \nif foo\n  account2 foo\n" @?=+        (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher Or (toRegex' "foo")],cbAssignments=[("account2","foo")]}]}))+   ]+  ,testGroup "conditionalblockp" [+    testCase "space after conditional" $+      parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=+        (Right $ CB{cbMatchers=[RecordMatcher Or $ toRegexCI' "a"],cbAssignments=[("account2","b")]})+  ],++  testGroup "csvfieldreferencep" [+    testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")+   ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date")+   ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"")+   ]++  ,testGroup "recordmatcherp" [++    testCase "recordmatcherp" $+      parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "A A")++   ,testCase "recordmatcherp.starts-with-&" $+      parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")++   ,testCase "recordmatcherp.starts-with-&&" $+      parseWithState' defrules matcherp "&& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")++   ,testCase "recordmatcherp.starts-with-&&-!" $+      parseWithState' defrules matcherp "&& ! A A\n" @?= (Right $ RecordMatcher AndNot $ toRegexCI' "A A")++   ,testCase "recordmatcherp.does-not-start-with-%" $+      parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher Or $ toRegexCI' "description A A")+   ]++  ,testGroup "fieldmatcherp" [+    testCase "fieldmatcherp" $+      parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher Or "%description" $ toRegexCI' "A A")++   ,testCase "fieldmatcherp.starts-with-&" $+      parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")++   ,testCase "fieldmatcherp.starts-with-&&" $+      parseWithState' defrules matcherp "&& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")++   ,testCase "fieldmatcherp.starts-with-&&-!" $+      parseWithState' defrules matcherp "&& ! %description A A\n" @?= (Right $ FieldMatcher AndNot "%description" $ toRegexCI' "A A")++   -- ,testCase "fieldmatcherp with operator" $+   --    parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")+   ]+++  ,testGroup "regexp" [+    testCase "regexp.ends-before-&&" $+      parseWithState' defrules (regexp eof) "A A && xxx" @?= (Right $ toRegexCI' "A A")+   ,testCase "regexp contains &" $+      parseWithState' defrules (regexp eof) "A & B" @?= (Right $ toRegexCI' "A & B")+   ]++  , let matchers = [RecordMatcher Or (toRegexCI' "A"), RecordMatcher And (toRegexCI' "B")]+        assignments = [("account2", "foo"), ("comment2", "bar")]+        block = CB matchers assignments+    in+   testGroup "Combine multiple matchers on the same line" [+    testCase "conditionalblockp" $+      parseWithState' defrules conditionalblockp "if A && B\n account2 foo\n comment2 bar" @?= (Right block)+   ,testCase "conditionaltablep" $+      parseWithState' defrules conditionaltablep "if,account2,comment2\nA && B,foo,bar" @?= (Right [block])+   ]++ ,testGroup "hledgerField" [+    let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}++    in testCase "toplevel" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}+    in testCase "conditional" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}+    in testCase "negated-conditional-false" $ hledgerField rules ["a","b"] "date" @?= (Nothing)+  +   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "negated-conditional-true" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher Or "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional-with-or-a" $ hledgerField rules ["a"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher Or "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional-with-or-b" $ hledgerField rules ["_", "b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}+    in testCase "conditional.with-and" $ hledgerField rules ["a", "b"] "date" @?= (Just "%csvdate")++   ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher Or "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher Or "%description" $ toRegex' "c"] [("date","%csvdate")]]}+    in testCase "conditional.with-and-or" $ hledgerField rules ["_", "c"] "date" @?= (Just "%csvdate")++   ]++ -- testing match groups (#2158)+ ,testGroup "hledgerFieldValue" $+    let rules = mkrules $ defrules+          { rcsvfieldindexes=[ ("date",1), ("description",2) ]+          , rassignments=[ ("account2","equity"), ("amount1","1") ]+          -- ConditionalBlocks here are in reverse order: mkrules reverses the list+          , rconditionalblocks=[ CB { cbMatchers=[FieldMatcher Or "%description" (toRegex' "PREFIX (.*) - (.*)")]+                                    , cbAssignments=[("account1","account:\\1:\\2")] }+                               , CB { cbMatchers=[FieldMatcher Or "%description" (toRegex' "PREFIX (.*)")]+                                    , cbAssignments=[("account1","account:\\1"), ("comment1","\\1")] }+                               ]+          }+        record = ["2019-02-01","PREFIX Text 1 - Text 2"]+    in [ testCase "scoped match groups forwards" $ hledgerFieldValue rules record "account1" @?= (Just "account:Text 1:Text 2")+       , testCase "scoped match groups backwards" $ hledgerFieldValue rules record "comment1" @?= (Just "Text 1 - Text 2")+       ]+ ]
Hledger/Read/TimeclockReader.hs view
@@ -1,14 +1,14 @@-{-|+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections. -A reader for the timeclock file format generated by timeclock.el-(<http://www.emacswiki.org/emacs/TimeClock>). Example:+-- Keep relevant parts synced with manual:+{-| -@-i 2007\/03\/10 12:26:00 hledger-o 2007\/03\/10 17:26:02-@+A reader for the timeclock file format. -From timeclock.el 2.6:+What exactly is this format ? It was introduced in timeclock.el (<http://www.emacswiki.org/emacs/TimeClock>).+The old specification in timeclock.el 2.6 was:  @ A timeclock contains data in the form of a single entry per line.@@ -38,10 +38,98 @@      now finished.  Useful for creating summary reports. @ +Ledger's timeclock format is different, and hledger's timeclock format is different again.+For example: in a clock-in entry, after the time,++- timeclock.el's timeclock has 0-1 fields: [COMMENT]+- Ledger's timeclock has 0-2 fields:       [ACCOUNT[  PAYEE]]+- hledger's timeclock has 1-3 fields:      ACCOUNT[  DESCRIPTION[;COMMENT]]++hledger's timeclock format is:++@+# Comment lines like these, and blank lines, are ignored:+# comment line+; comment line+* comment line++# Lines beginning with b, h, or capital O are also ignored, for compatibility:+b SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]+h SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]+O SIMPLEDATE HH:MM[:SS][+-ZZZZ][ TEXT]++# Lines beginning with i or o are are clock-in / clock-out entries:+i SIMPLEDATE HH:MM[:SS][+-ZZZZ] ACCOUNT[  DESCRIPTION][;COMMENT]]+o SIMPLEDATE HH:MM[:SS][+-ZZZZ][ ACCOUNT][;COMMENT]+@++The date is a hledger [simple date](#simple-dates) (YYYY-MM-DD or similar).+The time parts must use two digits.+The seconds are optional.+A + or - four-digit time zone is accepted for compatibility, but currently ignored; times are always interpreted as a local time.++In clock-in entries (`i`), the account name is required.+A transaction description, separated from the account name by 2+ spaces, is optional.+A transaction comment, beginning with `;`, is also optional.++In clock-out entries (`o`) have no description, but can have a comment if you wish.+A clock-in and clock-out pair form a "transaction" posting some number of hours to an account - also known as a session.+Eg:++```timeclock+i 2015/03/30 09:00:00 session1+o 2015/03/30 10:00:00+```++```cli+$ hledger -f a.timeclock print+2015-03-30 * 09:00-10:00+    (session1)           1.00h+```++Clock-ins and clock-outs are matched by their account/session name.+If a clock-outs does not specify a name, the most recent unclosed clock-in is closed.+Also, sessions spanning more than one day are automatically split at day boundaries.+Eg, the following time log:++```timeclock+i 2015/03/30 09:00:00 some account  optional description after 2 spaces ; optional comment, tags:+o 2015/03/30 09:20:00+i 2015/03/31 22:21:45 another:account+o 2015/04/01 02:00:34+i 2015/04/02 12:00:00 another:account  ; this demonstrates multple sessions being clocked in+i 2015/04/02 13:00:00 some account+o 2015/04/02 14:00:00+o 2015/04/02 15:00:00 another:account+```++generates these transactions:++```cli+$ hledger -f t.timeclock print+2015-03-30 * optional description after 2 spaces   ; optional comment, tags:+    (some account)           0.33h++2015-03-31 * 22:21-23:59+    (another:account)           1.64h++2015-04-01 * 00:00-02:00+    (another:account)           2.01h++2015-04-02 * 12:00-15:00  ; this demonstrates multiple sessions being clocked in+    (another:account)           3.00h++2015-04-02 * 13:00-14:00+    (some account)           1.00h++```+ -} -{-# LANGUAGE OverloadedStrings, PackageImports #-}+--- ** language+{-# LANGUAGE OverloadedStrings #-} +--- ** exports module Hledger.Read.TimeclockReader (   -- * Reader   reader,@@ -49,67 +137,114 @@   timeclockfilep, ) where-import           Prelude ()-import "base-compat-batteries" Prelude.Compat++--- ** imports import           Control.Monad-import           Control.Monad.Except (ExceptT)+import           Control.Monad.Except (ExceptT, liftEither) import           Control.Monad.State.Strict import           Data.Maybe (fromMaybe) import           Data.Text (Text)-import qualified Data.Text as T import           Text.Megaparsec hiding (parse)  import           Hledger.Data -- XXX too much reuse ? import           Hledger.Read.Common import           Hledger.Utils+import Data.Text as T (strip)+import Data.Functor ((<&>)) +--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings -reader :: Reader+--- ** reader++reader :: MonadIO m => Reader m reader = Reader-  {rFormat     = "timeclock"+  {rFormat     = Timeclock   ,rExtensions = ["timeclock"]-  ,rParser     = parse-  ,rExperimental = False+  ,rReadFn     = handleReadFnToTextReadFn parse+  ,rParser     = timeclockfilep   }  -- | Parse and post-process a "Journal" from timeclock.el's timeclock -- format, saving the provided file path and the current time, or give an -- error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse = parseAndFinaliseJournal' timeclockfilep+parse iopts fp t = initialiseAndParseJournal (timeclockfilep iopts) iopts fp t+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+                   >>= journalFinalise iopts fp t -timeclockfilep :: MonadIO m => JournalParser m ParsedJournal-timeclockfilep = do many timeclockitemp-                    eof-                    j@Journal{jparsetimeclockentries=es} <- get-                    -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.-                    -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,-                    -- but it simplifies code above.-                    now <- liftIO getCurrentLocalTime-                    -- entries have been parsed in reverse order. timeclockEntriesToTransactions-                    -- expects them to be in normal order, then we must reverse again since-                    -- journalFinalise expects them in reverse order-                    let j' = j{jtxns = reverse $ timeclockEntriesToTransactions now $ reverse es, jparsetimeclockentries = []}-                    return j'-    where-      -- As all ledger line types can be distinguished by the first-      -- character, excepting transactions versus empty (blank or-      -- comment-only) lines, can use choice w/o try-      timeclockitemp = choice [ -                            void (lift emptyorcommentlinep)-                          , timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})-                          ] <?> "timeclock entry, or default year or historical price directive"+--- ** parsers --- | Parse a timeclock entry.-timeclockentryp :: JournalParser m TimeclockEntry-timeclockentryp = do-  sourcepos <- genericSourcePos <$> lift getSourcePos+-- timeclockfilepspecial :: InputOpts -> JournalParser m ParsedJournal+-- timeclockfilepspecial args = +-- timeclockfilep args++timeclockfilep :: MonadIO m => InputOpts -> JournalParser m ParsedJournal+timeclockfilep iopts = do+  many timeclockitemp+  eof+  j@Journal{jparsetimeclockentries=es} <- get+  -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.+  -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,+  -- but it simplifies code above.+  now <- liftIO getCurrentLocalTime+  -- journalFinalise expects the transactions in reverse order, so reverse the output in either case+  let+    j' = if _oldtimeclock iopts+      then+        -- timeclockToTransactionsOld expects the entries to be in normal order, +        -- but they have been parsed in reverse order, so reverse them before calling+        j{jtxns = reverse $ timeclockToTransactionsOld now $ reverse es, jparsetimeclockentries = []}+      else+        -- We don't need to reverse these transactions +        -- since they are sorted inside of timeclockToTransactions+        j{jtxns = reverse $ timeclockToTransactions now es, jparsetimeclockentries = []}+  return j'+  where+    -- As all ledger line types can be distinguished by the first+    -- character, excepting transactions versus empty (blank or+    -- comment-only) lines, can use choice w/o try+    timeclockitemp = choice [+       void (lift emptyorcommentlinep)+      ,entryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})+      ] <?> "timeclock entry, comment line, or empty line"+      where entryp = if _oldtimeclock iopts then oldtimeclockentryp else timeclockentryp++-- | Parse a timeclock entry (loose pre-1.50 format).+oldtimeclockentryp :: JournalParser m TimeclockEntry+oldtimeclockentryp = do+  pos <- getSourcePos   code <- oneOf ("bhioO" :: [Char])-  lift (skipSome spacenonewline)+  lift skipNonNewlineSpaces1   datetime <- datetimep-  account <- fromMaybe "" <$> optional (lift (skipSome spacenonewline) >> modifiedaccountnamep)-  description <- T.pack . fromMaybe "" <$> lift (optional (skipSome spacenonewline >> restofline))-  return $ TimeclockEntry sourcepos (read [code]) datetime account description-+  account     <- fmap (fromMaybe "") $ optional $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep True+  description <- fmap (maybe "" T.strip) $ optional $ lift $ skipNonNewlineSpaces1 >> descriptionp+  (comment, tags) <- lift transactioncommentp+  return $ TimeclockEntry pos (read [code]) datetime account description comment tags +-- | Parse a timeclock entry (more robust post-1.50 format).+timeclockentryp :: JournalParser m TimeclockEntry+timeclockentryp = do+  pos <- getSourcePos+  code <- oneOf ("iobhO" :: [Char])+  lift skipNonNewlineSpaces1+  datetime <- datetimep+  (account, description) <- case code of+    'i' -> do+      lift skipNonNewlineSpaces1+      a <- modifiedaccountnamep False+      d <- optional (lift $ skipNonNewlineSpaces1 >> descriptionp) <&> maybe "" T.strip+      return (a, d)+    'o' -> do+      -- Notice the try needed here to avoid a parse error if there's trailing spaces.+      -- Unlike descriptionp above, modifiedaccountnamep requires nonempty text.+      -- And when a parser in an optional fails after consuming input, optional doesn't backtrack,+      -- it propagates the failure.+      a <- optional (try $ lift skipNonNewlineSpaces1 >> modifiedaccountnamep False) <&> fromMaybe ""+      return (a, "")+    _ -> return ("", "")+  lift skipNonNewlineSpaces+  (comment, tags) <- lift $ optional transactioncommentp <&> fromMaybe ("",[])+  return $ TimeclockEntry pos (read [code]) datetime account description comment tags
Hledger/Read/TimedotReader.hs view
@@ -1,15 +1,18 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections. {-|  A reader for the "timedot" file format. Example:  @-#DATE-#ACCT  DOTS  # Each dot represents 15m, spaces are ignored-#ACCT  8    # numbers with or without a following h represent hours-#ACCT  5m   # numbers followed by m represent minutes+;DATE+;ACCT  DOTS  # Each dot represents 15m, spaces are ignored+;ACCT  8    # numbers with or without a following h represent hours+;ACCT  5m   # numbers followed by m represent minutes -# on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc.+; on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc. 2/1 fos.haskell   .... .. biz.research  .@@ -23,8 +26,10 @@  -} -{-# LANGUAGE OverloadedStrings, PackageImports #-}+--- ** language+{-# LANGUAGE OverloadedStrings #-} +--- ** exports module Hledger.Read.TimedotReader (   -- * Reader   reader,@@ -32,102 +37,181 @@   timedotfilep, ) where-import Prelude ()-import "base-compat-batteries" Prelude.Compat++--- ** imports import Control.Monad-import Control.Monad.Except (ExceptT)+import Control.Monad.Except (ExceptT, liftEither) import Control.Monad.State.Strict import Data.Char (isSpace)-import Data.List (foldl')-import Data.Maybe import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (Day) import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char  import Hledger.Data import Hledger.Read.Common-import Hledger.Utils hiding (traceParse)+import Hledger.Utils+import Data.Decimal (roundTo)+import Data.Functor ((<&>))+import Data.List (sort)+import Data.List (group)+-- import Text.Megaparsec.Debug (dbg) --- easier to toggle this here sometimes--- import qualified Hledger.Utils (parsertrace)--- parsertrace = Hledger.Utils.parsertrace-traceParse :: Monad m => a -> m a-traceParse = return+--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings -reader :: Reader+--- ** reader++reader :: MonadIO m => Reader m reader = Reader-  {rFormat     = "timedot"+  {rFormat     = Timedot   ,rExtensions = ["timedot"]-  ,rParser     = parse-  ,rExperimental = False+  ,rReadFn     = handleReadFnToTextReadFn parse+  ,rParser    = timedotp   }  -- | Parse and post-process a "Journal" from the timedot format, or give an error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal-parse = parseAndFinaliseJournal' timedotfilep+parse iopts fp t = initialiseAndParseJournal (timedotp iopts) iopts fp t+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+                   >>= journalFinalise iopts fp t -timedotfilep :: JournalParser m ParsedJournal-timedotfilep = do many timedotfileitemp-                  eof-                  get-    where-      timedotfileitemp :: JournalParser m ()-      timedotfileitemp = do-        traceParse "timedotfileitemp"-        choice [-          void $ lift emptyorcommentlinep-         ,timedotdayp >>= \ts -> modify' (addTransactions ts)-         ] <?> "timedot day entry, or default year or comment line or blank line"+--- ** utilities -addTransactions :: [Transaction] -> Journal -> Journal-addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)+-- Trace parser state above a certain --debug level ?+tracelevel = 9+dp :: String -> JournalParser m ()+dp = if tracelevel >= 0 then lift . dbgparse tracelevel else const $ return () --- | Parse timedot day entries to zero or more time transactions for that day.+--- ** parsers+{-+Rough grammar for timedot format:++timedot:           preamble day*+preamble:          (emptyline | commentline | orgheading)*+orgheading:        orgheadingprefix restofline+day:               dateline entry* (emptyline | commentline)*+dateline:          orgheadingprefix? date description?+orgheadingprefix:  star+ space++description:       restofline  ; till semicolon?+entry:          orgheadingprefix? space* singlespaced (doublespace quantity?)?+doublespace:       space space++quantity:          (dot (dot | space)* | number | number unit)++Date lines and item lines can begin with an org heading prefix, which is ignored.+Org headings before the first date line are ignored, regardless of content.+-}++timedotfilep = timedotp -- XXX rename export above++timedotp :: InputOpts -> JournalParser m ParsedJournal+timedotp _ = preamblep >> many dayp >> eof >> get++preamblep :: JournalParser m ()+preamblep = do+  dp "preamblep"+  void $ many $ notFollowedBy datelinep >> (lift $ emptyorcommentlinep2 "#;*")++-- | Parse timedot day entries to multi-posting time transactions for that day. -- @--- 2/1+-- 2020/2/1 optional day description -- fos.haskell  .... .. -- biz.research . -- inc.client1  .... .... .... .... .... .... -- @-timedotdayp :: JournalParser m [Transaction]-timedotdayp = do-  traceParse " timedotdayp"-  d <- datep <* lift eolof-  es <- catMaybes <$> many (const Nothing <$> try (lift emptyorcommentlinep) <|>-                            Just <$> (notFollowedBy datep >> timedotentryp))-  return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp+dayp :: JournalParser m ()+dayp = label "timedot day entry" $ do+  dp "dayp"+  pos <- getSourcePos+  (date,desc,comment,tags) <- datelinep+  dp "dayp1"+  commentlinesp+  dp "dayp2"+  ps <- (many $ dp "dayp3" >> timedotentryp <* commentlinesp) <&> concat+  endpos <- getSourcePos+  let t = txnTieKnot $ nulltransaction{+    tsourcepos   = (pos, endpos),+    tdate        = date,+    tstatus      = Cleared,+    tdescription = desc,+    tcomment     = comment,+    ttags        = tags,+    tpostings    = ps+    }+  modify' $ addTransaction t +datelinep :: JournalParser m (Day,Text,Text,[Tag])+datelinep = do+  dp "datelinep"+  lift $ optional orgheadingprefixp+  date <- datep+  desc <- T.strip <$> lift descriptionp+  (comment, tags) <- lift transactioncommentp+  return (date, desc, comment, tags)++-- | Zero or more empty lines or hash/semicolon comment lines+-- or org headlines which do not start a new day.+commentlinesp :: JournalParser m ()+commentlinesp = do+  dp "commentlinesp"+  void $ many $ try $ lift $ emptyorcommentlinep2 "#;"++-- orgnondatelinep :: JournalParser m ()+-- orgnondatelinep = do+--   dp "orgnondatelinep"+--   lift orgheadingprefixp+--   notFollowedBy datelinep+--   void $ lift restofline++orgheadingprefixp = skipSome (char '*') >> skipNonNewlineSpaces1+ -- | Parse a single timedot entry to one (dateless) transaction. -- @ -- fos.haskell  .... .. -- @-timedotentryp :: JournalParser m Transaction+timedotentryp :: JournalParser m [Posting] timedotentryp = do-  traceParse "  timedotentryp"-  pos <- genericSourcePos <$> getSourcePos-  lift (skipMany spacenonewline)-  a <- modifiedaccountnamep-  lift (skipMany spacenonewline)-  hours <--    try (lift followingcommentp >> return 0)-    <|> (timedotdurationp <*-         (try (lift followingcommentp) <|> (newline >> return "")))-  let t = nulltransaction{-        tsourcepos = pos,-        tstatus    = Cleared,-        tpostings  = [-          nullposting{paccount=a-                     ,pamount=Mixed [setAmountPrecision 2 $ num hours]  -- don't assume hours; do set precision to 2-                     ,ptype=VirtualPosting-                     ,ptransaction=Just t-                     }-          ]-        }-  return t+  dp "timedotentryp"+  notFollowedBy datelinep+  lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]+  a <- modifiedaccountnamep False+  lift skipNonNewlineSpaces+  taggedhours <- lift durationsp+  (comment0, tags0) <-+         lift transactioncommentp    -- not postingp, don't bother with date: tags here+     <|> (newline >> return ("",[]))+  mcs <- getDefaultCommodityAndStyle+  let +    (c,s) = case mcs of+      Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Precision 2)})+      _ -> ("", amountstyle{asprecision=Precision 2})+    ps = [+      nullposting{paccount=a+                ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s}+                ,ptype=VirtualPosting+                ,pcomment=comment+                ,ptags=tags+                }+      | (hours,tagval) <- taggedhours+      , let tag = ("t",tagval)+      , let tags    = if T.null tagval then tags0    else tags0 ++ [tag]+      , let comment = if T.null tagval then comment0 else comment0 `commentAddTagUnspaced` tag+      ]+  return ps -timedotdurationp :: JournalParser m Quantity-timedotdurationp = try timedotnumericp <|> timedotdotsp+type Hours = Quantity +-- | Parse one or more durations in hours, each with an optional tag value+-- (or empty string for none).+durationsp :: TextParser m [(Hours,TagValue)]+durationsp =+      (try numericquantityp <&> \h -> [(h,"")])  -- try needed because numbers can begin with .+  <|> (dotquantityp     <&> \h -> [(h,"")])+  <|> letterquantitiesp+  <|> pure [(0,"")]+ -- | Parse a duration of seconds, minutes, hours, days, weeks, months or years, -- written as a decimal number followed by s, m, h, d, w, mo or y, assuming h -- if there is no unit. Returns the duration as hours, assuming@@ -137,21 +221,22 @@ -- 1.5h -- 90m -- @-timedotnumericp :: JournalParser m Quantity-timedotnumericp = do-  (q, _, _, _) <- lift $ numberp Nothing+numericquantityp :: TextParser m Hours+numericquantityp = do+  -- dp "numericquantityp"+  (q, _, _, _) <- numberp Nothing   msymbol <- optional $ choice $ map (string . fst) timeUnits-  lift (skipMany spacenonewline)-  let q' = +  skipNonNewlineSpaces+  let q' =         case msymbol of           Nothing  -> q-          Just sym ->+          Just sym -> roundTo 2 $             case lookup sym timeUnits of-              Just mult -> q * mult  +              Just mult -> q * mult               Nothing   -> q  -- shouldn't happen.. ignore   return q' --- (symbol, equivalent in hours). +-- (symbol, equivalent in hours). timeUnits =   [("s",2.777777777777778e-4)   ,("mo",5040) -- before "m"@@ -162,11 +247,30 @@   ,("y",61320)   ] --- | Parse a quantity written as a line of dots, each representing 0.25.+-- | Parse a quantity written as a line of one or more dots,+-- each representing 0.25, ignoring any interspersed spaces+-- after the first dot. -- @ -- .... .. -- @-timedotdotsp :: JournalParser m Quantity-timedotdotsp = do-  dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))-  return $ (/4) $ fromIntegral $ length dots+dotquantityp :: TextParser m Hours+dotquantityp = do+  -- dp "dotquantityp"+  char '.'+  dots <- many (oneOf ['.', ' ']) <&> filter (not.isSpace)+  return $ fromIntegral (1 + length dots) / 4++-- | Parse a quantity written as a line of one or more letters,+-- each representing 0.25 with a tag "t" whose value is the letter,+-- ignoring any interspersed spaces after the first letter.+letterquantitiesp :: TextParser m [(Hours, TagValue)]+letterquantitiesp =+  -- dp "letterquantitiesp"+  do+    letter1 <- letterChar+    letters <- many (letterChar <|> spacenonewline) <&> filter (not.isSpace)+    let groups =+          [ (fromIntegral (length t) / 4, T.singleton c)+          | t@(c:_) <- group $ sort $ letter1:letters+          ]+    return groups
Hledger/Reports.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+ {-|  Generate several common kinds of report from a journal, as \"*Report\" -@@ -13,33 +15,30 @@   module Hledger.Reports.ReportTypes,   module Hledger.Reports.EntriesReport,   module Hledger.Reports.PostingsReport,-  module Hledger.Reports.TransactionsReports,+  module Hledger.Reports.AccountTransactionsReport,   module Hledger.Reports.BalanceReport,-  module Hledger.Reports.MultiBalanceReports,+  module Hledger.Reports.MultiBalanceReport,   module Hledger.Reports.BudgetReport,---   module Hledger.Reports.BalanceHistoryReport,   -- * Tests   tests_Reports ) where +import Test.Tasty (testGroup) import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes+import Hledger.Reports.AccountTransactionsReport import Hledger.Reports.EntriesReport import Hledger.Reports.PostingsReport-import Hledger.Reports.TransactionsReports import Hledger.Reports.BalanceReport-import Hledger.Reports.MultiBalanceReports+import Hledger.Reports.MultiBalanceReport import Hledger.Reports.BudgetReport--- import Hledger.Reports.BalanceHistoryReport-import Hledger.Utils.Test -tests_Reports = tests "Reports" [+tests_Reports = testGroup "Reports" [    tests_BalanceReport   ,tests_BudgetReport+  ,tests_AccountTransactionsReport   ,tests_EntriesReport-  ,tests_MultiBalanceReports+  ,tests_MultiBalanceReport   ,tests_PostingsReport-  ,tests_ReportOptions-  ,tests_TransactionsReports   ]
+ Hledger/Reports/AccountTransactionsReport.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-|++An account-centric transactions report.++-}++module Hledger.Reports.AccountTransactionsReport (+  AccountTransactionsReport,+  AccountTransactionsReportItem,+  accountTransactionsReport,+  accountTransactionsReportItems,+  transactionRegisterDate,+  triOrigTransaction,+  triDate,+  triAmount,+  triBalance,+  triCommodityAmount,+  triCommodityBalance,+  accountTransactionsReportByCommodity,+  tests_AccountTransactionsReport+)+where++import Data.List (mapAccumR, nub, partition, sortBy)+import Data.List.Extra (nubSort)+import Data.Maybe (catMaybes)+import Data.Ord (Down(..), comparing)+import Data.Text qualified as T+import Data.Time.Calendar (Day)++import Hledger.Data+import Hledger.Query+import Hledger.Reports.ReportOptions+import Hledger.Utils+++-- | An account transactions report represents transactions affecting+-- a particular account (or possibly several accounts, but we don't+-- use that). It is used eg by hledger-ui's and hledger-web's register+-- view, and hledger's aregister report, where we want to show one row+-- per transaction, in the context of the current account. Report+-- items consist of:+--+-- - the transaction, unmodified+--+-- - the transaction as seen in the context of the current account and query,+--   which means:+--+--   - the transaction date is set to the "transaction context date":+--     the earliest of the transaction date and any other posting dates+--     of postings to the current account (matched by the report query).+--+--   - the transaction's postings are filtered, excluding any which are not+--     matched by the report query+--+-- - a text description of the other account(s) posted to/from+--+-- - a flag indicating whether there's more than one other account involved+--+-- - the total increase/decrease to the current account+--+-- - the report transactions' running total after this transaction;+--   or if historical balance is requested (-H), the historical running total.+--   The historical running total includes transactions from before the+--   report start date if one is specified, filtered by the report query.+--   The historical running total may or may not be the account's historical+--   running balance, depending on the report query.+--+-- Items are sorted by transaction register date (the earliest date the transaction+-- posts to the current account), most recent first.+-- Reporting intervals are currently ignored.+--+type AccountTransactionsReport = [AccountTransactionsReportItem] -- line items, one per transaction++type AccountTransactionsReportItem =+  (+   Transaction -- the transaction, unmodified+  ,Transaction -- the transaction, as seen from the current account+  ,Bool        -- is this a split (more than one posting to other accounts) ?+  ,[AccountName] -- the other account(s), if any+  ,MixedAmount -- the amount posted to the current account(s) (or total amount posted)+  ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction+  )++instance HasAmounts AccountTransactionsReportItem where+  styleAmounts styles (torig,tacct,b,c,a1,a2) =+    (styleAmounts styles torig,styleAmounts styles tacct,b,c,styleAmounts styles a1,styleAmounts styles a2)++triOrigTransaction (torig,_,_,_,_,_) = torig+triDate (_,tacct,_,_,_,_) = tdate tacct+triAmount (_,_,_,_,a,_) = a+triBalance (_,_,_,_,_,a) = a+triCommodityAmount c = filterMixedAmountByCommodity c  . triAmount+triCommodityBalance c = filterMixedAmountByCommodity c  . triBalance++accountTransactionsReport :: ReportSpec -> Journal -> Query -> AccountTransactionsReport+accountTransactionsReport rspec@ReportSpec{_rsReportOpts=ropts} j thisacctq = items+  where+    -- A depth limit should not affect the account transactions report; it should show all transactions in/below this account.+    -- Queries on currency or amount are also ignored at this stage; they are handled earlier, before valuation.+    reportq = simplifyQuery $ And [aregisterq, periodq]+      where+        aregisterq = filterQuery (not . queryIsCurOrAmt) . filterQuery (not . queryIsDepth) $ _rsQuery rspec+        periodq = Date . periodAsDateSpan $ period_ ropts+    amtq = filterQuery queryIsCurOrAmt $ _rsQuery rspec+    queryIsCurOrAmt q = queryIsSym q || queryIsAmt q+    wd = whichDate ropts++    -- Note that within this function, we are only allowed limited+    -- transformation of the transaction postings: this is due to the need to+    -- pass the original transactions into accountTransactionsReportItem.+    -- Generally, we either include a transaction in full, or not at all.+    -- Do some limited filtering and valuing of the journal's transactions:+    -- - filter them by the account query if any,+    -- - discard amounts not matched by the currency and amount query if any,+    -- - then apply valuation if any.+    -- Additional reportq filtering, such as date filtering, happens down in +    -- accountTransactionsReportItem, which discards transactions with no matched postings.+    acctJournal =+        -- With most calls we will not require transaction prices past this point, and can get a big+        -- speed improvement by stripping them early. In some cases, such as in hledger-ui, we still+        -- want to keep prices around, so we can toggle between cost and no cost quickly. We can use+        -- the show_costs_ flag to be efficient when we can, and detailed when we have to.+          (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripCosts)+        . dbg5With (("ts3:\n"++).pshowTransactions.jtxns)+        -- maybe convert these transactions to cost or value+        . journalApplyValuationFromOpts rspec+        . dbg5With (("ts2:\n"++).pshowTransactions.jtxns)+        -- apply any cur: or amt: filters in reportq+        . (if queryIsNull amtq then id else filterJournalAmounts amtq)+        -- only consider transactions which match thisacctq (possibly excluding postings+        -- which are not real or have the wrong status)+        . dbg3Msg ("thisacctq: "++show thisacctq)+        $ dbg5With (("ts1:\n"++).pshowTransactions.jtxns)+          j{jtxns = filter (matchesTransaction thisacctq . relevantPostings) $ jtxns j}+      where+        relevantPostings+          | queryIsNull realq && queryIsNull statusq = id+          | otherwise = filterTransactionPostings . simplifyQuery $ And [realq, statusq]+        realq   = filterQuery queryIsReal reportq+        statusq = filterQuery queryIsStatus reportq++    startbal+      | balanceaccum_ ropts == Historical = sumPostings priorps+      | otherwise                         = nullmixedamt+      where+        priorps = dbg5 "priorps" . filter hasAmount . journalPostings $ filterJournalPostings priorq acctJournal+        priorq = dbg5 "priorq" $ And [thisacctq, tostartdateq, datelessreportq]+        tostartdateq =+          case mstartdate of+            Just _  -> Date (DateSpan Nothing (Exact <$> mstartdate))+            Nothing -> None  -- no start date specified, there are no prior postings+        mstartdate = queryStartDate (date2_ ropts) reportq+        datelessreportq = filterQuery (not . queryIsDateOrDate2) reportq++    items =+        accountTransactionsReportItems reportq thisacctq startbal maNegate (journalAccountType j)+      -- sort by the transaction's register date, then index, for accurate starting balance+      . dbg5With (("ts4:\n"++).pshowTransactions.map snd)+      . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd))+      . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t))+      . map (if invert_ ropts then (\t -> t{tpostings = map postingNegateMainAmount $ tpostings t}) else id)+      $ jtxns acctJournal++pshowTransactions :: [Transaction] -> String+pshowTransactions = pshow . map (\t -> unwords [show $ tdate t, T.unpack $ tdescription t])++-- | Generate transactions report items from a list of transactions,+-- using the provided user-specified report query, a query specifying+-- which account to use as the focus, a starting balance, and a sign-setting+-- function.+-- Each transaction is accompanied by the date that should be shown for it+-- in the report. This is not necessarily the transaction date - see+-- transactionRegisterDate.+accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount)+                               -> (AccountName -> Maybe AccountType) -> [(Day, Transaction)]+                               -> [AccountTransactionsReportItem]+accountTransactionsReportItems reportq thisacctq bal signfn accttypefn =+    catMaybes . snd . mapAccumR (accountTransactionsReportItem reportq thisacctq signfn accttypefn) bal++accountTransactionsReportItem :: Query -> Query -> (MixedAmount -> MixedAmount)+                              -> (AccountName -> Maybe AccountType) -> MixedAmount -> (Day, Transaction)+                              -> (MixedAmount, Maybe AccountTransactionsReportItem)+accountTransactionsReportItem reportq thisacctq signfn accttypefn bal (d, t)+    -- 201407: I've lost my grip on this, let's just hope for the best+    -- 201606: we now calculate change and balance from filtered postings, check this still works well for all callers XXX+    | null reportps = (bal, Nothing)  -- no matched postings in this transaction, skip it+    | otherwise     = (bal', Just (t, tacct{tdate=d}, numotheraccts > 1, otheraccts, amt, bal'))+    where+      tacct@Transaction{tpostings=reportps} = filterTransactionPostingsExtra accttypefn reportq t  -- TODO needs to consider --date2, #1731+      (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps+      numotheraccts = length $ nub $ map paccount otheracctps+      otheraccts | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings+                 | numotheraccts == 0 = summarisePostingAccounts thisacctps   -- only postings to current account ? summarise those+                 | otherwise          = summarisePostingAccounts otheracctps  -- summarise matched postings to other account(s)+      -- 202302: Impact of t on thisacct - normally the sum of thisacctps,+      -- but if they are null it probably means reportq is an account filter+      -- and we should sum otheracctps instead.+      -- This fixes hledger areg ACCT ACCT2 (#2007), hopefully it's correct in general.+      amt+        | null thisacctps = signfn $ sumPostings otheracctps+        | otherwise       = signfn . maNegate $ sumPostings thisacctps+      bal' = bal `maPlus` amt++-- TODO needs checking, cf #1731+-- | What date should be shown for a transaction in an account register report ?+-- This will be in context of a particular account (the "this account" query)+-- and any additional report query. It could be:+--+-- - if postings are matched by both thisacctq and reportq, the earliest of those+--   matched postings' dates (or their secondary dates if --date2 was used)+--+-- - the transaction date, or its secondary date if --date2 was used.+--+transactionRegisterDate :: WhichDate -> Query -> Query -> Transaction -> Day+transactionRegisterDate wd reportq thisacctq t+  | not $ null thisacctps = minimum $ map (postingDateOrDate2 wd) thisacctps+  | otherwise             = transactionDateOrDate2 wd t+  where+    reportps   = tpostings $ filterTransactionPostings reportq t+    thisacctps = filter (matchesPosting thisacctq) reportps++-- -- | Generate a short readable summary of some postings, like+-- -- "from (negatives) to (positives)".+-- summarisePostings :: [Posting] -> String+-- summarisePostings ps =+--     case (summarisePostingAccounts froms, summarisePostingAccounts tos) of+--        ("",t) -> "to "++t+--        (f,"") -> "from "++f+--        (f,t)  -> "from "++f++" to "++t+--     where+--       (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps++-- | Generate a simplified summary of some postings' accounts.+-- To reduce noise, if there are both real and virtual postings, show only the real ones.+summarisePostingAccounts :: [Posting] -> [AccountName]+summarisePostingAccounts ps = map paccount displayps+  where+    realps = filter isReal ps+    displayps | null realps = ps+              | otherwise   = realps++-- | Split an  account transactions report whose items may involve several commodities,+-- into one or more single-commodity account transactions reports.+accountTransactionsReportByCommodity :: AccountTransactionsReport -> [(CommoditySymbol, AccountTransactionsReport)]+accountTransactionsReportByCommodity tr =+  [(c, filterAccountTransactionsReportByCommodity c tr) | c <- commodities tr]+  where+    commodities = nubSort . map acommodity . concatMap (amounts . triAmount)++-- | Remove account transaction report items and item amount (and running+-- balance amount) components that don't involve the specified+-- commodity. Other item fields such as the transaction are left unchanged.+filterAccountTransactionsReportByCommodity :: CommoditySymbol -> AccountTransactionsReport -> AccountTransactionsReport+filterAccountTransactionsReportByCommodity comm =+    fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity comm)+  where+    filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal)+      | c `elem` cs = [item']+      | otherwise   = []+      where+        cs = map acommodity $ amounts a+        item' = (t,t2,s,o,a',bal)+        a' = filterMixedAmountByCommodity c a++    fixTransactionsReportItemBalances [] = []+    fixTransactionsReportItemBalances [i] = [i]+    fixTransactionsReportItemBalances items = reverse $ i:(go startbal is)+      where+        i:is = reverse items+        startbal = filterMixedAmountByCommodity comm $ triBalance i+        go _ [] = []+        go bal ((t,t2,s,o,amt,_):is') = (t,t2,s,o,amt,bal'):go bal' is'+          where bal' = bal `maPlus` amt++-- tests++tests_AccountTransactionsReport = testGroup "AccountTransactionsReport" [+ ]
− Hledger/Reports/BalanceHistoryReport.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}-{-|--Account balance history report.---}--- XXX not used--module Hledger.Reports.BalanceHistoryReport (-  accountBalanceHistory-)-where--import Data.Time.Calendar--import Hledger.Data-import Hledger.Query-import Hledger.Reports.ReportOptions-import Hledger.Reports.TransactionsReports----- | Get the historical running inclusive balance of a particular account,--- from earliest to latest posting date.-accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)]-accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items]-  where-    (_,items) = journalTransactionsReport ropts j acctquery-    inclusivebal = True-    acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a-    getdate = if date2_ ropts then transactionDate2 else tdate-
Hledger/Reports/BalanceReport.hs view
@@ -4,43 +4,29 @@  -} --------{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Hledger.Reports.BalanceReport (   BalanceReport,   BalanceReportItem,   balanceReport,   flatShowsExclusiveBalance,-  sortAccountItemsLike,     -- * Tests   tests_BalanceReport ) where -import Data.List-import Data.Ord-import Data.Maybe import Data.Time.Calendar  import Hledger.Data-import Hledger.Read (mamountp') import Hledger.Query-import Hledger.Utils +import Hledger.Utils+import Hledger.Reports.MultiBalanceReport (multiBalanceReport) import Hledger.Reports.ReportOptions------+import Hledger.Reports.ReportTypes   -- | A simple balance report. It has:@@ -63,6 +49,9 @@ type BalanceReport = ([BalanceReportItem], MixedAmount) type BalanceReportItem = (AccountName, AccountName, Int, MixedAmount) +instance HasAmounts BalanceReportItem where+  styleAmounts styles (a,b,c,d) = (a,b,c,styleAmounts styles d)+ -- | When true (the default), this makes balance --flat reports and their implementation clearer. -- Single/multi-col balance reports currently aren't all correct if this is false. flatShowsExclusiveBalance    = True@@ -74,128 +63,38 @@  -- | Generate a simple balance report, containing the matched accounts and -- their balances (change of balance) during the specified period.--- This is like PeriodChangeReport with a single column (but more mature,--- eg this can do hierarchical display).-balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport-balanceReport opts q j = -  (if invert_ opts then brNegate else id) $ -  (sorteditems, total)-    where-      -- dbg1 = const id -- exclude from debug output-      dbg1 s = let p = "balanceReport" in Hledger.Utils.dbg1 (p++" "++s)  -- add prefix in debug output--      accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j-      accts' :: [Account]-          | queryDepth q == 0 =-                         dbg1 "accts" $-                         take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts-          | flat_ opts = dbg1 "accts" $-                         filterzeros $-                         filterempty $-                         drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts-          | otherwise  = dbg1 "accts" $-                         filter (not.aboring) $-                         drop 1 $ flattenAccounts $-                         markboring $-                         prunezeros $-                         sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) $-                         clipAccounts (queryDepth q) accts-          where-            balance   = if flat_ opts then aebalance else aibalance-            filterzeros = if empty_ opts then id else filter (not . isZeroMixedAmount . balance)-            filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a)))-            prunezeros  = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance)-            markboring  = if no_elide_ opts then id else markBoringParentAccounts--      items = dbg1 "items" $ map (balanceReportItem opts q) accts'--      -- now sort items like MultiBalanceReport, except -      -- sorting a tree by amount was more easily done above-      sorteditems -        | sort_amount_ opts && tree_ opts = items-        | sort_amount_ opts               = sortFlatBRByAmount items-        | otherwise                       = sortBRByAccountDeclaration items-      -        where    -          -- Sort the report rows, representing a flat account list, by row total. -          sortFlatBRByAmount :: [BalanceReportItem] -> [BalanceReportItem]-          sortFlatBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fourth4))-            where-              maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip-    -          -- Sort the report rows by account declaration order then account name. -          sortBRByAccountDeclaration :: [BalanceReportItem] -> [BalanceReportItem]-          sortBRByAccountDeclaration rows = sortedrows-            where -              anamesandrows = [(first4 r, r) | r <- rows]-              anames = map fst anamesandrows-              sortedanames = sortAccountNamesByDeclaration j (tree_ opts) anames-              sortedrows = sortAccountItemsLike sortedanames anamesandrows --      total | not (flat_ opts) = dbg1 "total" $ sum [amt | (_,_,indent,amt) <- items, indent == 0]-            | otherwise        = dbg1 "total" $-                                 if flatShowsExclusiveBalance-                                 then sum $ map fourth4 items-                                 else sum $ map aebalance $ clipAccountsAndAggregate 1 accts'---- | A sorting helper: sort a list of things (eg report rows) keyed by account name--- to match the provided ordering of those same account names.-sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b] -sortAccountItemsLike sortedas items =-  concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas---- | In an account tree with zero-balance leaves removed, mark the--- elidable parent accounts (those with one subaccount and no balance--- of their own).-markBoringParentAccounts :: Account -> Account-markBoringParentAccounts = tieAccountParents . mapAccounts mark+-- If the normalbalance_ option is set, it adjusts the sorting and sign of+-- amounts (see ReportOpts and CompoundBalanceCommand).+balanceReport :: ReportSpec -> Journal -> BalanceReport+balanceReport rspec j = (rows, total)   where-    mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True}-           | otherwise = a+    report = multiBalanceReport rspec j+    rows = [( prrFullName row+            , prrDisplayName row+            , prrIndent row+            , prrTotal row+            ) | row <- prRows report]+    total = prrTotal $ prTotals report -balanceReportItem :: ReportOpts -> Query -> Account -> BalanceReportItem-balanceReportItem opts q a-  | flat_ opts = (name, name,       0,      (if flatShowsExclusiveBalance then aebalance else aibalance) a)-  | otherwise  = (name, elidedname, indent, aibalance a)-  where-    name | queryDepth q > 0 = aname a-         | otherwise        = "..."-    elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name])-    adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring parents-    indent = length $ filter (not.aboring) parents-    -- parents exclude the tree's root node-    parents = case parentAccounts a of [] -> []-                                       as -> init as --- -- the above using the newer multi balance report code:--- balanceReport' opts q j = (items, total)---   where---     MultiBalanceReport (_,mbrrows,mbrtotals) = PeriodChangeReport opts q j---     items = [(a,a',n, headDef 0 bs) | ((a,a',n), bs) <- mbrrows]---     total = headDef 0 mbrtotals---- | Flip the sign of all amounts in a BalanceReport.-brNegate :: BalanceReport -> BalanceReport-brNegate (is, tot) = (map brItemNegate is, -tot) -  where-    brItemNegate (a, a', d, amt) = (a, a', d, -amt)+-- tests  Right samplejournal2 =-  journalBalanceTransactions False+  journalBalanceTransactions defbalancingopts     nulljournal{       jtxns = [         txnTieKnot Transaction{           tindex=0,-          tsourcepos=nullsourcepos,-          tdate=parsedate "2008/01/01",-          tdate2=Just $ parsedate "2009/01/01",+          tsourcepos=nullsourcepospair,+          tdate=fromGregorian 2008 01 01,+          tdate2=Just $ fromGregorian 2009 01 01,           tstatus=Unmarked,           tcode="",           tdescription="income",           tcomment="",           ttags=[],           tpostings=-            [posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]}+            [posting {paccount="assets:bank:checking", pamount=mixedAmount (usd 1)}             ,posting {paccount="income:salary", pamount=missingmixedamt}             ],           tprecedingcomment=""@@ -203,106 +102,116 @@       ]     } --- tests+tests_BalanceReport = testGroup "BalanceReport" [ -tests_BalanceReport = tests "BalanceReport" [-  tests "balanceReport" $-    let-      (opts,journal) `gives` r = do-        let (eitems, etotal) = r-            (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal-            showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt)-        (map showw eitems) `is` (map showw aitems)-        (showMixedAmountDebug etotal) `is` (showMixedAmountDebug atotal)-      usd0 = usd 0-    in [-  -     test "balanceReport with no args on null journal" $-     (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])-  -    ,test "balanceReport with no args on sample journal" $-     (defreportopts, samplejournal) `gives`+  let+    (rspec,journal) `gives` r = do+      let opts' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]}+          (eitems, etotal) = r+          (aitems, atotal) = balanceReport opts' journal+          showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt)+      (map showw aitems) @?= (map showw eitems)+      (showMixedAmountDebug atotal) @?= (showMixedAmountDebug etotal)+  in+    testGroup "balanceReport" [++     testCase "no args, null journal" $+     (defreportspec, nulljournal) `gives` ([], nullmixedamt)++    ,testCase "no args, sample journal" $+     (defreportspec, samplejournal) `gives`       ([-        ("assets","assets",0, mamountp' "$0.00")-       ,("assets:bank","bank",1, mamountp' "$2.00")-       ,("assets:bank:checking","checking",2, mamountp' "$1.00")-       ,("assets:bank:saving","saving",2, mamountp' "$1.00")-       ,("assets:cash","cash",1, mamountp' "$-2.00")-       ,("expenses","expenses",0, mamountp' "$2.00")-       ,("expenses:food","food",1, mamountp' "$1.00")-       ,("expenses:supplies","supplies",1, mamountp' "$1.00")-       ,("income","income",0, mamountp' "$-2.00")-       ,("income:gifts","gifts",1, mamountp' "$-1.00")-       ,("income:salary","salary",1, mamountp' "$-1.00")+        ("assets:bank:checking","assets:bank:checking",0, mixedAmount (usd 1))+       ,("assets:bank:saving","assets:bank:saving",0, mixedAmount (usd 1))+       ,("assets:cash","assets:cash",0, mixedAmount (usd (-2)))+       ,("expenses:food","expenses:food",0, mixedAmount (usd 1))+       ,("expenses:supplies","expenses:supplies",0, mixedAmount (usd 1))+       ,("income:gifts","income:gifts",0, mixedAmount (usd (-1)))+       ,("income:salary","income:salary",0, mixedAmount (usd (-1)))        ],-       Mixed [usd0])-  -    ,test "balanceReport with --depth=N" $-     (defreportopts{depth_=Just 1}, samplejournal) `gives`+       mixedAmount (usd 0))++    ,testCase "with --tree" $+     (defreportspec{_rsReportOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives`       ([-       ("expenses",    "expenses",    0, mamountp'  "$2.00")-       ,("income",      "income",      0, mamountp' "$-2.00")+        ("assets","assets",0, mixedAmount (usd 0))+       ,("assets:bank","bank",1, mixedAmount (usd 2))+       ,("assets:bank:checking","checking",2, mixedAmount (usd 1))+       ,("assets:bank:saving","saving",2, mixedAmount (usd 1))+       ,("assets:cash","cash",1, mixedAmount (usd (-2)))+       ,("expenses","expenses",0, mixedAmount (usd 2))+       ,("expenses:food","food",1, mixedAmount (usd 1))+       ,("expenses:supplies","supplies",1, mixedAmount (usd 1))+       ,("income","income",0, mixedAmount (usd (-2)))+       ,("income:gifts","gifts",1, mixedAmount (usd (-1)))+       ,("income:salary","salary",1, mixedAmount (usd (-1)))        ],-       Mixed [usd0])-  -    ,test "balanceReport with depth:N" $-     (defreportopts{query_="depth:1"}, samplejournal) `gives`+       mixedAmount (usd 0))++    ,testCase "with --depth=N" $+     (defreportspec{_rsReportOpts=defreportopts{depth_=DepthSpec (Just 1) []}}, samplejournal) `gives`       ([-       ("expenses",    "expenses",    0, mamountp'  "$2.00")-       ,("income",      "income",      0, mamountp' "$-2.00")+       ("expenses",    "expenses",     0, mixedAmount (usd 2))+       ,("income",      "income",      0, mixedAmount (usd (-2)))        ],-       Mixed [usd0])-  -    ,tests "balanceReport with a date or secondary date span" [-     (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`-      ([],-       Mixed [nullamt])-     ,(defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`+       mixedAmount (usd 0))++    ,testCase "with depth:N" $+     (defreportspec{_rsQuery=Depth 1}, samplejournal) `gives`       ([-        ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")-       ,("income:salary","income:salary",0,mamountp' "$-1.00")+       ("expenses",    "expenses",     0, mixedAmount (usd 2))+       ,("income",      "income",      0, mixedAmount (usd (-2)))        ],-       Mixed [usd0])-     ]+       mixedAmount (usd 0)) -    ,test "balanceReport with desc:" $-     (defreportopts{query_="desc:income"}, samplejournal) `gives`+    ,testCase "with date:" $+     (defreportspec{_rsQuery=Date $ DateSpan (Just $ Exact $ fromGregorian 2009 01 01) (Just $ Exact $ fromGregorian 2010 01 01)}, samplejournal2) `gives`+      ([], nullmixedamt)++    ,testCase "with date2:" $+     (defreportspec{_rsQuery=Date2 $ DateSpan (Just $ Exact $ fromGregorian 2009 01 01) (Just $ Exact $ fromGregorian 2010 01 01)}, samplejournal2) `gives`       ([-        ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")-       ,("income:salary","income:salary",0, mamountp' "$-1.00")+        ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1))+       ,("income:salary","income:salary",0,mixedAmount (usd (-1)))        ],-       Mixed [usd0])-  -    ,test "balanceReport with not:desc:" $-     (defreportopts{query_="not:desc:income"}, samplejournal) `gives`+       mixedAmount (usd 0))++    ,testCase "with desc:" $+     (defreportspec{_rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives`       ([-        ("assets","assets",0, mamountp' "$-1.00")-       ,("assets:bank:saving","bank:saving",1, mamountp' "$1.00")-       ,("assets:cash","cash",1, mamountp' "$-2.00")-       ,("expenses","expenses",0, mamountp' "$2.00")-       ,("expenses:food","food",1, mamountp' "$1.00")-       ,("expenses:supplies","supplies",1, mamountp' "$1.00")-       ,("income:gifts","income:gifts",0, mamountp' "$-1.00")+        ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1))+       ,("income:salary","income:salary",0, mixedAmount (usd (-1)))        ],-       Mixed [usd0])-  -    ,test "balanceReport with period on a populated period" $-      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives`+       mixedAmount (usd 0))++    ,testCase "with not:desc:" $+     (defreportspec{_rsQuery=Not . Desc $ toRegexCI' "income"}, samplejournal) `gives`+      ([+        ("assets:bank:saving","assets:bank:saving",0, mixedAmount (usd 1))+       ,("assets:cash","assets:cash",0, mixedAmount (usd (-2)))+       ,("expenses:food","expenses:food",0, mixedAmount (usd 1))+       ,("expenses:supplies","expenses:supplies",0, mixedAmount (usd 1))+       ,("income:gifts","income:gifts",0, mixedAmount (usd (-1)))+       ],+       mixedAmount (usd 0))++    ,testCase "with period on a populated period" $+      (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}}, samplejournal) `gives`        (         [-         ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00")-        ,("income:salary","income:salary",0, mamountp' "$-1.00")+         ("assets:bank:checking","assets:bank:checking",0, mixedAmount (usd 1))+        ,("income:salary","income:salary",0, mixedAmount (usd (-1)))         ],-        Mixed [usd0])-  -     ,test "balanceReport with period on an unpopulated period" $-      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`-       ([],Mixed [nullamt])-  -  -  +        mixedAmount (usd 0))++     ,testCase "with period on an unpopulated period" $+      (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}}, samplejournal) `gives`+       ([], nullmixedamt)+++   {--      ,test "accounts report with account pattern o" ~:+      ,testCase "accounts report with account pattern o" ~:        defreportopts{patterns_=["o"]} `gives`        ["                  $1  expenses:food"        ,"                 $-2  income"@@ -311,16 +220,16 @@        ,"--------------------"        ,"                 $-1"        ]-  -      ,test "accounts report with account pattern o and --depth 1" ~:-       defreportopts{patterns_=["o"],depth_=Just 1} `gives`++      ,testCase "accounts report with account pattern o and --depth 1" ~:+       defreportopts{patterns_=["o"],depth_=(Just 1, [])} `gives`        ["                  $1  expenses"        ,"                 $-2  income"        ,"--------------------"        ,"                 $-1"        ]-  -      ,test "accounts report with account pattern a" ~:++      ,testCase "accounts report with account pattern a" ~:        defreportopts{patterns_=["a"]} `gives`        ["                 $-1  assets"        ,"                  $1    bank:saving"@@ -330,8 +239,8 @@        ,"--------------------"        ,"                 $-1"        ]-  -      ,test "accounts report with account pattern e" ~:++      ,testCase "accounts report with account pattern e" ~:        defreportopts{patterns_=["e"]} `gives`        ["                 $-1  assets"        ,"                  $1    bank:saving"@@ -346,8 +255,8 @@        ,"--------------------"        ,"                   0"        ]-  -      ,test "accounts report with unmatched parent of two matched subaccounts" ~:++      ,testCase "accounts report with unmatched parent of two matched subaccounts" ~:        defreportopts{patterns_=["cash","saving"]} `gives`        ["                 $-1  assets"        ,"                  $1    bank:saving"@@ -355,15 +264,15 @@        ,"--------------------"        ,"                 $-1"        ]-  -      ,test "accounts report with multi-part account name" ~:++      ,testCase "accounts report with multi-part account name" ~:        defreportopts{patterns_=["expenses:food"]} `gives`        ["                  $1  expenses:food"        ,"--------------------"        ,"                  $1"        ]-  -      ,test "accounts report with negative account pattern" ~:++      ,testCase "accounts report with negative account pattern" ~:        defreportopts{patterns_=["not:assets"]} `gives`        ["                  $2  expenses"        ,"                  $1    food"@@ -375,21 +284,21 @@        ,"--------------------"        ,"                  $1"        ]-  -      ,test "accounts report negative account pattern always matches full name" ~:++      ,testCase "accounts report negative account pattern always matches full name" ~:        defreportopts{patterns_=["not:e"]} `gives`        ["--------------------"        ,"                   0"        ]-  -      ,test "accounts report negative patterns affect totals" ~:++      ,testCase "accounts report negative patterns affect totals" ~:        defreportopts{patterns_=["expenses","not:food"]} `gives`        ["                  $1  expenses:supplies"        ,"--------------------"        ,"                  $1"        ]-  -      ,test "accounts report with -E shows zero-balance accounts" ~:++      ,testCase "accounts report with -E shows zero-balance accounts" ~:        defreportopts{patterns_=["assets"],empty_=True} `gives`        ["                 $-1  assets"        ,"                  $1    bank"@@ -399,15 +308,15 @@        ,"--------------------"        ,"                 $-1"        ]-  -      ,test "accounts report with cost basis" $++      ,testCase "accounts report with cost basis" $          j <- (readJournal def Nothing $ unlines                 [""                 ,"2008/1/1 test           "                 ,"  a:b          10h @ $50"                 ,"  c:d                   "                 ]) >>= either error' return-         let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment+         let j' = journalCanonicaliseAmounts $ journalToCost ToCost j -- enable cost basis adjustment          balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is`            ["                $500  a:b"            ,"               $-500  c:d"@@ -415,7 +324,7 @@            ,"                   0"            ]   -}-   ]+     ]   ]
Hledger/Reports/BudgetReport.hs view
@@ -1,368 +1,223 @@-{- |--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} -module Hledger.Reports.BudgetReport+module Hledger.Reports.BudgetReport (+  BudgetGoal,+  BudgetTotal,+  BudgetAverage,+  BudgetCell,+  BudgetReportRow,+  BudgetReport,+  budgetReport,+  -- * Tests+  tests_BudgetReport+) where -import Data.Decimal-import Data.List-import Data.Maybe-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import Data.Ord-import Data.Time.Calendar-import Safe---import Data.List---import Data.Maybe-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Text as T---import qualified Data.Text.Lazy as TL---import System.Console.CmdArgs.Explicit as C---import Lucid as L-import Text.Printf (printf)-import Text.Tabular as T---import Text.Tabular.AsciiWide+import Control.Applicative ((<|>))+import Control.Monad ((>=>))+import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.List (find, maximumBy, intercalate)+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Ord (comparing)+import Data.Set qualified as S+import Data.Text qualified as T+import Data.These (These(..), these)+import Safe (minimumDef)  import Hledger.Data---import Hledger.Query import Hledger.Utils---import Hledger.Read (mamountp') import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes-import Hledger.Reports.BalanceReport (sortAccountItemsLike)-import Hledger.Reports.MultiBalanceReports----- for reference:------type MultiBalanceReportRow    = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount)---type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals)------type PeriodicReportRow a =---  ( AccountName  -- ^ A full account name.---  , [a]          -- ^ The data value for each subperiod.---  , a            -- ^ The total of this row's values.---  , a            -- ^ The average of this row's values.---  )+import Hledger.Reports.MultiBalanceReport +-- All MixedAmounts: type BudgetGoal    = Change type BudgetTotal   = Total type BudgetAverage = Average  -- | A budget report tracks expected and actual changes per account and subperiod.+-- Each table cell has an actual change amount and/or a budget goal amount. type BudgetCell = (Maybe Change, Maybe BudgetGoal)-type BudgetReport = PeriodicReport BudgetCell-type BudgetReportRow = PeriodicReportRow BudgetCell+-- | A row in a budget report table - account name and data cells.+type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell+-- | A full budget report table.+type BudgetReport    = PeriodicReport    DisplayName BudgetCell --- | Calculate budget goals from all periodic transactions,--- actual balance changes from the regular transactions,--- and compare these to get a 'BudgetReport'.--- Unbudgeted accounts may be hidden or renamed (see budgetRollup).-budgetReport :: ReportOpts -> Bool -> DateSpan -> Day -> Journal -> BudgetReport-budgetReport ropts' assrt reportspan d j =-  let+_brrShowDebug :: BudgetReportRow -> String+_brrShowDebug (PeriodicReportRow dname budgetpairs _tot _avg) =+  unwords [+    T.unpack $ displayFull dname,+    "",+    intercalate " | "+      [ maybe "-" showMixedAmount mactual <> " [" <> maybe "-" showMixedAmount mgoal <> "]"+      | (mactual,mgoal) <- budgetpairs ]+    ]++-- | Calculate per-account, per-period budget (balance change) goals+-- from all periodic transactions, calculate actual balance changes+-- from the regular transactions, and compare these to get a 'BudgetReport'.+-- Unbudgeted accounts may be hidden or renamed (see journalWithBudgetAccountNames).+budgetReport :: ReportSpec -> BalancingOpts -> DateSpan -> Journal -> BudgetReport+budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport+  where     -- Budget report demands ALTree mode to ensure subaccounts and subaccount budgets are properly handled     -- and that reports with and without --empty make sense when compared side by side-    ropts = ropts' { accountlistmode_ = ALTree }+    ropts = (_rsReportOpts rspec){ accountlistmode_ = ALTree }+    -- ropts = _rsReportOpts rspec     showunbudgeted = empty_ ropts-    q = queryFromOpts d ropts -    budgetedaccts = -      dbg2 "budgetedacctsinperiod" $-      nub $ -      concatMap expandAccountName $-      accountNamesFromPostings $ -      concatMap tpostings $ -      concatMap (flip runPeriodicTransaction reportspan) $ ++    budgetedaccts =+      dbg3 "budgetedacctsinperiod" $+      S.fromList $+      expandAccountNames $+      accountNamesFromPostings $+      concatMap tpostings $+      concatMap (\pt -> runPeriodicTransaction False pt reportspan) $       jperiodictxns j-    actualj = dbg1 "actualj" $ budgetRollUp budgetedaccts showunbudgeted j-    budgetj = dbg1 "budgetj" $ budgetJournal assrt ropts reportspan j-    actualreport@(MultiBalanceReport (actualspans, _, _)) = dbg1 "actualreport" $ multiBalanceReport ropts  q actualj-    budgetgoalreport@(MultiBalanceReport (_, budgetgoalitems, budgetgoaltotals)) = dbg1 "budgetgoalreport" $ multiBalanceReport (ropts{empty_=True}) q budgetj-    budgetgoalreport'-      -- If no interval is specified:-      -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; -      -- it should be safe to replace it with the latter, so they combine well. -      | interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals)-      | otherwise = budgetgoalreport -    budgetreport = combineBudgetAndActual budgetgoalreport' actualreport-    sortedbudgetreport = sortBudgetReport ropts j budgetreport-  in-    dbg1 "sortedbudgetreport" sortedbudgetreport --- | Sort a budget report's rows according to options.-sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport-sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps, sortedrows, trow)+    actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j+    budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j+    priceoracle = journalPriceOracle (infer_prices_ ropts) j++    (_, actualspans) = dbg5 "actualspans" $ reportSpan actualj rspec+    (_, budgetspans) = dbg5 "budgetspans" $ reportSpan budgetj rspec+    allspans = dbg5 "allspans" $ case (interval_ ropts, budgetspans) of+        -- If no interval is specified:+        -- budgetgoalreport's span might be shorter actualreport's due to periodic txns;+        -- it should be safe to replace it with the latter, so they combine well.+        (NoInterval, _) -> actualspans+        (_,    Nothing) -> actualspans+        (_, Just bspan) -> unionDayPartitions bspan =<< actualspans++    actualps = dbg5 "actualps" $ getPostings rspec actualj priceoracle reportspan+    budgetps = dbg5 "budgetps" $ getPostings rspec budgetj priceoracle reportspan++    actualAcct = dbg5 "actualAcct" $ generateMultiBalanceAccount rspec actualj priceoracle actualspans actualps+    budgetAcct = dbg5 "budgetAcct" $ generateMultiBalanceAccount rspec budgetj priceoracle budgetspans budgetps++    combinedAcct = dbg5 "combinedAcct" $ if null budgetps+        -- If no budget postings, just use actual account, to avoid unnecssary budget zeros+        then This <$> actualAcct+        else mergeAccounts actualAcct budgetAcct++    budgetreport = generateBudgetReport ropts allspans combinedAcct++-- | Lay out a set of postings grouped by date span into a regular matrix with rows+-- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport+-- from the columns.+generateBudgetReport :: ReportOpts -> Maybe DayPartition -> Account (These BalanceData BalanceData) -> BudgetReport+generateBudgetReport = generatePeriodicReport makeBudgetReportRow treeActualBalance flatActualBalance   where-    sortedrows -      | sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows-      | sort_amount_ ropts                = sortFlatBURByActualAmount rows-      | otherwise                         = sortByAccountDeclaration rows+    treeActualBalance = these bdincludingsubs (const nullmixedamt) (const . bdincludingsubs)+    flatActualBalance = fromMaybe nullmixedamt . fst -    -- Sort a tree-mode budget report's rows by total actual amount at each level.-    sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] -    sortTreeBURByActualAmount rows = sortedrows+-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makeBudgetReportRow :: ReportOpts -> (BalanceData -> MixedAmount)+                    -> a -> Account (These BalanceData BalanceData) -> PeriodicReportRow a BudgetCell+makeBudgetReportRow ropts balance =+    makePeriodicReportRow (Just nullmixedamt, Nothing) avg ropts (theseToMaybe . bimap balance balance)+  where+    avg xs = ((actualtotal, budgettotal), (actualavg, budgetavg))       where-        anamesandrows = [(first6 r, r) | r <- rows]-        anames = map fst anamesandrows-        atotals = [(a,tot) | (a,_,_,_,(tot,_),_) <- rows]-        accounttree = accountTree "root" anames-        accounttreewithbals = mapAccounts setibalance accounttree-          where-            setibalance a = a{aibalance=-              fromMaybe 0 $ -- when there's no actual amount, assume 0; will mess up with negative amounts ? TODO -              fromMaybe (error "sortTreeByAmount 1") $ -- should not happen, but it's ugly; TODO -              lookup (aname a) atotals-              }-        sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals-        sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree-        sortedrows = sortAccountItemsLike sortedanames anamesandrows +        (actuals, budgets) = unzip $ toList xs+        (actualtotal, actualavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes actuals+        (budgettotal, budgetavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes budgets -    -- Sort a flat-mode budget report's rows by total actual amount.-    sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] -    sortFlatBURByActualAmount = sortBy (maybeflip $ comparing (fst . fifth6))-      where-        maybeflip = if normalbalance_ ropts == Just NormallyNegative then id else flip+    theseToMaybe (This a) = (Just a, Nothing)+    theseToMaybe (That b) = (Just nullmixedamt, Just b)+    theseToMaybe (These a b) = (Just a, Just b) -    -- Sort the report rows by account declaration order then account name. -    -- <unbudgeted> remains at the top.-    sortByAccountDeclaration rows = sortedrows+-- | Use all (or all matched by --budget's argument) periodic transactions in the journal +-- to generate budget goal transactions in the specified date span (and before, to support+-- --historical. The precise start date is the natural start date of the largest interval+-- of the active periodic transaction rules that is on or before the earlier of journal start date,+-- report start date.)+-- Budget goal transactions are similar to forecast transactions except their purpose +-- and effect is to define balance change goals, per account and period, for BudgetReport.+--+journalAddBudgetGoalTransactions :: BalancingOpts -> ReportOpts -> DateSpan -> Journal -> Journal+journalAddBudgetGoalTransactions bopts ropts reportspan j =+  either error' id $  -- PARTIAL:+    (journalStyleAmounts >=> journalBalanceTransactions bopts) j{ jtxns = budgetts }+  where+    budgetspan = dbg3 "budget span" $ DateSpan (Exact <$> mbudgetgoalsstartdate) (Exact <$> spanEnd reportspan)       where-        (unbudgetedrow,rows') = partition ((=="<unbudgeted>").first6) rows-        anamesandrows = [(first6 r, r) | r <- rows']-        anames = map fst anamesandrows-        sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames-        sortedrows = unbudgetedrow ++ sortAccountItemsLike sortedanames anamesandrows +        mbudgetgoalsstartdate =+          -- We want to also generate budget goal txns before the report start date, in case -H is used.+          -- What should the actual starting date for goal txns be ? This gets tricky. +          -- Consider a journal with a "~ monthly" periodic transaction rule, where the first transaction is on 1/5.+          -- Users will certainly expect a budget goal for january, but "~ monthly" generates transactions+          -- on the first of month, and starting from 1/5 would exclude 1/1.+          -- Secondly, consider a rule like "~ every february 2nd from 2020/01"; we should not start that+          -- before 2020-02-02.+          -- Hopefully the following algorithm produces intuitive behaviour in general:+          -- from the earlier of the journal start date and the report start date,+          -- move backward to the nearest natural start date of the largest period seen among the+          -- active periodic transactions, unless that is disallowed by a start date in the periodic rule.+          -- (Do we need to pay attention to an end date in the rule ? Don't think so.)+          -- (So with "~ monthly", the journal start date 1/5 is adjusted to 1/1.)+          case minimumDef Nothing $ filter isJust [journalStartDate False j, spanStart reportspan] of+            Nothing -> Nothing+            Just d  -> Just d'+              where+                -- the interval and any date span of the periodic transaction with longest period+                (intervl, spn) =+                  case budgetpts of+                    []  -> (Days 1, nulldatespan)+                    pts -> (ptinterval pt, ptspan pt)+                      where pt = maximumBy (comparing ptinterval) pts  -- PARTIAL: maximumBy won't fail+                -- the natural start of this interval on or before the journal/report start+                intervalstart = intervalBoundaryBefore intervl d+                -- the natural interval start before the journal/report start,+                -- or the rule-specified start if later,+                -- but no later than the journal/report start.+                d' = min d $ maybe intervalstart (max intervalstart) $ spanStart spn --- | Use all periodic transactions in the journal to generate --- budget transactions in the specified report period.--- Budget transactions are similar to forecast transactions except--- their purpose is to set goal amounts (of change) per account and period.-budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal-budgetJournal assrt _ropts reportspan j =-  either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts }-  where-    budgetspan = dbg2 "budgetspan" $ reportspan+    -- select periodic transactions matching a pattern+    -- (the argument of the (final) --budget option).+    -- XXX two limitations/wishes, requiring more extensive type changes:+    -- - give an error if pat is non-null and matches no periodic txns+    -- - allow a regexp or a full hledger query, not just a substring+    pat = fromMaybe "" $ dbg3 "budget pattern" $ T.toLower <$> budgetpat_ ropts+    budgetpts = [pt | pt <- jperiodictxns j, pat `T.isInfixOf` T.toLower (ptdescription pt)]     budgetts =-      dbg1 "budgetts" $+      dbg5 "budget goal txns" $       [makeBudgetTxn t-      | pt <- jperiodictxns j-      , t <- runPeriodicTransaction pt budgetspan+      | pt <- budgetpts+      , t <- runPeriodicTransaction False pt budgetspan       ]     makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }  -- | Adjust a journal's account names for budget reporting, in two ways: ----- 1. accounts with no budget goal anywhere in their ancestry are moved +-- 1. accounts with no budget goal anywhere in their ancestry are moved --    under the "unbudgeted" top level account. -- -- 2. subaccounts with no budget goal are merged with their closest parent account---    with a budget goal, so that only budgeted accounts are shown. ---    This can be disabled by --empty.+--    with a budget goal, so that only budgeted accounts are shown.+--    This can be disabled by -E/--empty. ---budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal-budgetRollUp budgetedaccts showunbudgeted j = j { jtxns = remapTxn <$> jtxns j }+journalWithBudgetAccountNames :: S.Set AccountName -> Bool -> Journal -> Journal+journalWithBudgetAccountNames budgetedaccts showunbudgeted j =+  dbg5With (("budget account names: "++).pshow.journalAccountNamesUsed) $+  j { jtxns = remapTxn <$> jtxns j }   where-    remapTxn = mapPostings (map remapPosting)+    remapTxn = txnTieKnot . transactionTransformPostings remapPosting+    remapPosting p = p { paccount = remapAccount $ paccount p, poriginal = poriginal p <|> Just p }+    remapAccount a+      | a `S.member` budgetedaccts = a+      | Just p <- budgetedparent   = if showunbudgeted then a else p+      | otherwise                  = if showunbudgeted then u <> acctsep <> a else u       where-        mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t }-        remapPosting p = p { paccount = remapAccount $ paccount p, poriginal = Just . fromMaybe p $ poriginal p }-          where-            remapAccount a-              | hasbudget         = a-              | hasbudgetedparent = if showunbudgeted then a else budgetedparent -              | otherwise         = if showunbudgeted then u <> acctsep <> a else u-              where-                hasbudget = a `elem` budgetedaccts-                hasbudgetedparent = not $ T.null budgetedparent-                budgetedparent = headDef "" $ filter (`elem` budgetedaccts) $ parentAccountNames a-                u = unbudgetedAccountName+        budgetedparent = find (`S.member` budgetedaccts) $ parentAccountNames a+        u = unbudgetedAccountName --- | Combine a per-account-and-subperiod report of budget goals, and one--- of actual change amounts, into a budget performance report.--- The two reports should have the same report interval, but need not--- have exactly the same account rows or date columns.--- (Cells in the combined budget report can be missing a budget goal,--- an actual amount, or both.) The combined report will include:------ - consecutive subperiods at the same interval as the two reports,---   spanning the period of both reports------ - all accounts mentioned in either report, sorted by account code or---   account name or amount as appropriate.----combineBudgetAndActual :: MultiBalanceReport -> MultiBalanceReport -> BudgetReport-combineBudgetAndActual-  (MultiBalanceReport (budgetperiods, budgetrows, (budgettots, budgetgrandtot, budgetgrandavg)))-  (MultiBalanceReport (actualperiods, actualrows, (actualtots, actualgrandtot, actualgrandavg))) =-  let-    periods = nub $ sort $ filter (/= nulldatespan) $ budgetperiods ++ actualperiods -    -- first, combine any corresponding budget goals with actual changes-    rows1 =-      [ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal)-      | (acct, treeacct, treeindent, actualamts, actualtot, actualavg) <- actualrows-      , let mbudgetgoals       = Map.lookup acct budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage)-      , let budgetmamts        = maybe (replicate (length periods) Nothing) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal]-      , let mbudgettot         = maybe Nothing (Just . second3) mbudgetgoals :: Maybe BudgetTotal-      , let mbudgetavg         = maybe Nothing (Just . third3)  mbudgetgoals :: Maybe BudgetAverage-      , let acctBudgetByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal-      , let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change-      , let amtandgoals        = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)]-      , let totamtandgoal      = (Just actualtot, mbudgettot)-      , let avgamtandgoal      = (Just actualavg, mbudgetavg)-      ]-      where-        budgetGoalsByAcct :: Map AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) =-          Map.fromList [ (acct, (amts, tot, avg)) | (acct, _, _, amts, tot, avg) <- budgetrows ]--    -- next, make rows for budget goals with no actual changes-    rows2 =-      [ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal)-      | (acct, treeacct, treeindent, budgetgoals, budgettot, budgetavg) <- budgetrows-      , not $ acct `elem` acctsdone-      , let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal-      , let amtandgoals        = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)]-      , let totamtandgoal      = (Nothing, Just budgettot)-      , let avgamtandgoal      = (Nothing, Just budgetavg)-      ]-      where-        acctsdone = map first6 rows1--    -- combine and re-sort rows-    -- TODO: use MBR code-    -- TODO: respect --sort-amount-    -- TODO: add --sort-budget to sort by budget goal amount-    rows :: [PeriodicReportRow (Maybe Change, Maybe BudgetGoal)] =-      sortBy (comparing first6) $ rows1 ++ rows2--    -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells-    totalrow =-      ( ""-      , ""-      , 0-      , [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] :: [(Maybe Total, Maybe BudgetTotal)]-      , ( Just actualgrandtot, Just budgetgrandtot ) :: (Maybe Total, Maybe BudgetTotal)-      , ( Just actualgrandavg, Just budgetgrandavg ) :: (Maybe Total, Maybe BudgetTotal)-      )-      where-        totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal-        totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change--  in-    PeriodicReport-      ( periods-      , rows-      , totalrow-      )---- | Figure out the overall period of a BudgetReport.-budgetReportSpan :: BudgetReport -> DateSpan-budgetReportSpan (PeriodicReport ([], _, _))    = DateSpan Nothing Nothing-budgetReportSpan (PeriodicReport (spans, _, _)) = DateSpan (spanStart $ head spans) (spanEnd $ last spans)---- | Render a budget report as plain text suitable for console output.-budgetReportAsText :: ReportOpts -> BudgetReport -> String-budgetReportAsText ropts budgetr@(PeriodicReport ( _, rows, _)) =-  printf "Budget performance in %s:\n\n" (showDateSpan $ budgetReportSpan budgetr)-  ++ -  tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr)-  where-    actualwidth =-      maximum [ maybe 0 (length . showMixedAmountOneLineWithoutPrice) amt-      | (_, _, _, amtandgoals, _, _) <- rows-      , (amt, _) <- amtandgoals ]-    budgetwidth =-      maximum [ maybe 0 (length . showMixedAmountOneLineWithoutPrice) goal-      | (_, _, _, amtandgoals, _, _) <- rows-      , (_, goal) <- amtandgoals ]-    -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells-    showcell :: (Maybe Change, Maybe BudgetGoal) -> String-    showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr-      where-        percentwidth = 4-        actual = fromMaybe 0 mactual-        actualstr = printf ("%"++show actualwidth++"s") (showamt actual)-        budgetstr = case mbudget of-          Nothing     -> replicate (percentwidth + 7 + budgetwidth) ' '-          Just budget ->-            case percentage actual budget of-              Just pct ->-                printf ("[%"++show percentwidth++"s%% of %"++show budgetwidth++"s]")-                       (show $ roundTo 0 pct) (showbudgetamt budget)-              Nothing ->-                printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]")-                       (showbudgetamt budget)--    -- | Calculate the percentage of actual change to budget goal to show, if any.-    -- Both amounts are converted to cost, if possible, before comparing.-    -- A percentage will not be shown if:-    -- - actual or goal are not the same, single, commodity-    -- - the goal is zero-    percentage :: Change -> BudgetGoal -> Maybe Percentage-    percentage actual budget =-      case (toCost actual, toCost budget) of-        (Mixed [a], Mixed [b]) | (acommodity a == acommodity b || isZeroAmount a) && not (isZeroAmount b) -            -> Just $ 100 * aquantity a / aquantity b-        _   -> Nothing-      where-        toCost = normaliseMixedAmount . costOfMixedAmount --    showamt :: MixedAmount -> String-    showamt | color_ ropts  = cshowMixedAmountOneLineWithoutPrice-            | otherwise     = showMixedAmountOneLineWithoutPrice--    -- don't show the budget amount in color, it messes up alignment-    showbudgetamt = showMixedAmountOneLineWithoutPrice--    maybetranspose | transpose_ ropts = \(Table rh ch vals) -> Table ch rh (transpose vals)-                   | otherwise       = id---- | Build a 'Table' from a multi-column balance report.-budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)-budgetReportAsTable -  ropts -  (PeriodicReport-    ( periods-    , rows-    , (_, _, _, coltots, grandtot, grandavg)-    )) =-    addtotalrow $ -    Table-      (T.Group NoLine $ map Header accts)-      (T.Group NoLine $ map Header colheadings)-      (map rowvals rows)-  where-    colheadings = map showDateSpanMonthAbbrev periods-                  ++ (if row_total_ ropts then ["  Total"] else [])-                  ++ (if average_   ropts then ["Average"] else [])-    accts = map renderacct rows-    renderacct (a,a',i,_,_,_)-      | tree_ ropts = replicate ((i-1)*2) ' ' ++ T.unpack a'-      | otherwise   = T.unpack $ maybeAccountNameDrop ropts a-    rowvals (_,_,_,as,rowtot,rowavg) = as-                                       ++ (if row_total_ ropts then [rowtot] else [])-                                       ++ (if average_   ropts then [rowavg] else [])-    addtotalrow | no_total_ ropts = id-                | otherwise       = (+----+ (row "" $-                                     coltots-                                     ++ (if row_total_ ropts && not (null coltots) then [grandtot] else [])-                                     ++ (if average_   ropts && not (null coltots) then [grandavg] else [])-                                     ))---- XXX here for now--- TODO: does not work for flat-by-default reports with --flat not specified explicitly  --- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.-maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName-maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a-                            | otherwise  = a- -- tests -tests_BudgetReport = tests "BudgetReport" [+tests_BudgetReport = testGroup "BudgetReport" [  ]
Hledger/Reports/EntriesReport.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} {-|  Journal entries report, used by the print command.@@ -14,13 +16,14 @@ ) where -import Data.List-import Data.Ord+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Time (fromGregorian)  import Hledger.Data-import Hledger.Query+import Hledger.Query (Query(..), filterQuery, queryIsDepth) import Hledger.Reports.ReportOptions-import Hledger.Utils +import Hledger.Utils   -- | A journal entries report is a list of whole transactions as@@ -30,17 +33,18 @@ type EntriesReportItem = Transaction  -- | Select transactions for an entries report.-entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport-entriesReport opts q j =-  sortBy (comparing date) $ filter (q `matchesTransaction`) ts-    where-      date = transactionDateFn opts-      ts = jtxns $ journalSelectingAmountFromOpts opts j+entriesReport :: ReportSpec -> Journal -> EntriesReport+entriesReport rspec@ReportSpec{_rsReportOpts=ropts} =+      sortBy (comparing $ transactionDateFn ropts)+    . map  (if invert_ ropts then transactionNegate else id)+    . jtxns+    . journalApplyValuationFromOpts (setDefaultConversionOp NoConversionOp rspec)+    . filterJournalTransactions (filterQuery (not.queryIsDepth) $ _rsQuery rspec) -tests_EntriesReport = tests "EntriesReport" [-  tests "entriesReport" [-     test "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) `is` 1-    ,test "date" $ (length $ entriesReport defreportopts (Date $ mkdatespan "2008/06/01" "2008/07/01") samplejournal) `is` 3+tests_EntriesReport = testGroup "EntriesReport" [+  testGroup "entriesReport" [+     testCase "not acct" $ (length $ entriesReport defreportspec{_rsQuery=Not . Acct $ toRegex' "bank"} samplejournal) @?= 1+    ,testCase "date" $ (length $ entriesReport defreportspec{_rsQuery=Date $ DateSpan (Just $ Exact $ fromGregorian 2008 06 01) (Just $ Exact $ fromGregorian 2008 07 01)} samplejournal) @?= 3   ]  ]
+ Hledger/Reports/MultiBalanceReport.hs view
@@ -0,0 +1,556 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-|++Multi-column balance reports, used by the balance command.++-}++module Hledger.Reports.MultiBalanceReport (+  MultiBalanceReport,+  MultiBalanceReportRow,++  multiBalanceReport,+  multiBalanceReportWith,++  compoundBalanceReport,+  compoundBalanceReportWith,++  -- * Helper functions+  makeReportQuery,+  getPostings,+  generateMultiBalanceAccount,+  generatePeriodicReport,+  makePeriodicReportRow,++  -- -- * Tests+  tests_MultiBalanceReport+)+where++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+import Control.Monad (guard)+import Data.Foldable (toList)+import Data.HashSet qualified as HS+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Map qualified as M+import Data.Maybe (fromMaybe, isJust)+import Data.Ord (Down(..))+import Data.Semigroup (sconcat)+import Data.These (these)+import Data.Time.Calendar (Day(..), fromGregorian)+import Data.Traversable (mapAccumL)++import Hledger.Data+import Hledger.Query+import Hledger.Utils+import Hledger.Reports.ReportOptions+import Hledger.Reports.ReportTypes+++-- | A multi balance report is a kind of periodic report, where the amounts+-- correspond to balance changes or ending balances in a given period. It has:+--+-- 1. a list of each column's period (date span)+--+-- 2. a list of rows, each containing:+--+--   * the full account name, display name, and display depth+--+--   * A list of amounts, one for each column.+--+--   * the total of the row's amounts for a periodic report+--+--   * the average of the row's amounts+--+-- 3. the column totals, and the overall grand total (or zero for+-- cumulative/historical reports) and grand average.++type MultiBalanceReport    = PeriodicReport    DisplayName MixedAmount+type MultiBalanceReportRow = PeriodicReportRow DisplayName MixedAmount+++-- | Generate a multicolumn balance report for the matched accounts,+-- showing the change of balance, accumulated balance, or historical balance+-- in each of the specified periods. If the normalbalance_ option is set, it+-- adjusts the sorting and sign of amounts (see ReportOpts and+-- CompoundBalanceCommand). hledger's most powerful and useful report, used+-- by the balance command (in multiperiod mode) and (via compoundBalanceReport)+-- by the bs/cf/is commands.+multiBalanceReport :: ReportSpec -> Journal -> MultiBalanceReport+multiBalanceReport rspec j = multiBalanceReportWith rspec j (journalPriceOracle infer j)+  where infer = infer_prices_ $ _rsReportOpts rspec++-- | A helper for multiBalanceReport. This one takes some extra arguments,+-- a 'PriceOracle' to be used for looking up market prices, and a set of+-- 'AccountName's which should not be elided. Commands which run multiple+-- reports (bs etc.) can generate the price oracle just once for efficiency,+-- passing it to each report by calling this function directly.+multiBalanceReportWith :: ReportSpec -> Journal -> PriceOracle -> MultiBalanceReport+multiBalanceReportWith rspec' j priceoracle = report+  where+    -- Queries, report/column dates.+    (reportspan, colspans) = dbg5 "multiBalanceReportWith reportSpan" $ reportSpan j rspec'+    rspec = dbg3 "multiBalanceReportWith rspec" $ makeReportQuery rspec' reportspan+    -- force evaluation order to show price lookup after date spans in debug output (XXX not working)+    -- priceoracle = reportspan `seq` priceoracle0++    -- Get postings+    ps = dbg5 "multiBalanceReportWith ps" $ getPostings rspec j priceoracle reportspan++    -- Process changes into normal, cumulative, or historical amounts, plus value them and mark which are uninteresting+    acct = dbg5 "multiBalanceReportWith acct" $ generateMultiBalanceAccount rspec j priceoracle colspans ps++    -- Generate and postprocess the report, negating balances and taking percentages if needed+    report = dbg4 "multiBalanceReportWith report" $ generateMultiBalanceReport (_rsReportOpts rspec) colspans acct++-- | Generate a compound balance report from a list of CBCSubreportSpec. This+-- shares postings between the subreports.+compoundBalanceReport :: ReportSpec -> Journal -> [CBCSubreportSpec a]+                      -> CompoundPeriodicReport a MixedAmount+compoundBalanceReport rspec j = compoundBalanceReportWith rspec j (journalPriceOracle infer j)+  where infer = infer_prices_ $ _rsReportOpts rspec++-- | A helper for compoundBalanceReport, similar to multiBalanceReportWith.+compoundBalanceReportWith :: ReportSpec -> Journal -> PriceOracle+                          -> [CBCSubreportSpec a]+                          -> CompoundPeriodicReport a MixedAmount+compoundBalanceReportWith rspec' j priceoracle subreportspecs = cbr+  where+    -- Queries, report/column dates.+    (reportspan, colspans) = dbg5 "compoundBalanceReportWith reportSpan" $ reportSpan j rspec'+    rspec = dbg3 "compoundBalanceReportWith rspec" $ makeReportQuery rspec' reportspan++    -- Get postings+    ps = dbg5 "compoundBalanceReportWith ps" $ getPostings rspec j priceoracle reportspan++    subreports = map generateSubreport subreportspecs+      where+        generateSubreport CBCSubreportSpec{..} =+            ( cbcsubreporttitle+            -- Postprocess the report, negating balances and taking percentages if needed+            , cbcsubreporttransform $ generateMultiBalanceReport ropts colspans acct+            , cbcsubreportincreasestotal+            )+          where+            ropts = cbcsubreportoptions $ _rsReportOpts rspec+            -- Add a restriction to this subreport to the report query.+            -- XXX in non-thorough way, consider updateReportSpec ?+            rspecsub = rspec{_rsReportOpts=ropts, _rsQuery=And [cbcsubreportquery, _rsQuery rspec]}+            -- Match and postings for the subreport+            subreportps = filter (matchesPostingExtra (journalAccountType j) cbcsubreportquery) ps+            -- Account representing this subreport+            acct = generateMultiBalanceAccount rspecsub j priceoracle colspans subreportps++    -- Sum the subreport totals by column. Handle these cases:+    -- - no subreports+    -- - empty subreports, having no subtotals (#588)+    -- - subreports with a shorter subtotals row than the others+    overalltotals = case subreports of+        []     -> PeriodicReportRow () [] nullmixedamt nullmixedamt+        (r:rs) -> sconcat $ fmap subreportTotal (r:|rs)+      where+        subreportTotal (_, sr, increasestotal) =+            (if increasestotal then id else fmap maNegate) $ prTotals sr++    cbr = CompoundPeriodicReport "" (maybeDayPartitionToDateSpans colspans) subreports overalltotals+++-- | Remove any date queries and insert queries from the report span.+-- The user's query expanded to the report span+-- if there is one (otherwise any date queries are left as-is, which+-- handles the hledger-ui+future txns case above).+makeReportQuery :: ReportSpec -> DateSpan -> ReportSpec+makeReportQuery rspec reportspan+    | reportspan == nulldatespan = rspec+    | otherwise = rspec{_rsQuery=query}+  where+    query            = simplifyQuery $ And [dateless $ _rsQuery rspec, reportspandatesq]+    reportspandatesq = dbg3 "makeReportQuery reportspandatesq" $ dateqcons reportspan+    dateless         = dbg3 "makeReportQuery dateless" . filterQuery (not . queryIsDateOrDate2)+    dateqcons        = if date2_ (_rsReportOpts rspec) then Date2 else Date++-- | Gather postings matching the query within the report period.+getPostings :: ReportSpec -> Journal -> PriceOracle -> DateSpan -> [Posting]+getPostings rspec@ReportSpec{_rsQuery=query, _rsReportOpts=ropts} j priceoracle reportspan =+    setPostingsCount+    . filter hasAmount  -- omit postings with no definite amount+    . journalPostings+    $ journalValueAndFilterPostingsWith rspec' j priceoracle+  where+    -- If doing --count, set all posting amounts to "1".+    setPostingsCount = case balancecalc_ ropts of+        CalcPostingsCount -> map (postingTransformAmount (const $ mixed [num 1]))+        _                 -> id++    rspec' = rspec{_rsQuery=fullreportq,_rsReportOpts=ropts'}+    -- If we're re-valuing every period, we need to have the unvalued start+    -- balance, so we can do it ourselves later.+    ropts' = if isJust (valuationAfterSum ropts)+        then ropts{period_=dateSpanAsPeriod fullreportspan, value_=Nothing, conversionop_=Just NoConversionOp}  -- If we're valuing after the sum, don't do it now+        else ropts{period_=dateSpanAsPeriod fullreportspan}++    -- q projected back before the report start date.+    -- When there's no report start date, in case there are future txns (the hledger-ui case above),+    -- we use emptydatespan to make sure they aren't counted as starting balance.+    fullreportq = dbg3 "getPostings fullreportq" $ And [datelessq, fullreportspanq]+    datelessq   = dbg3 "getPostings datelessq" $ filterQuery (not . queryIsDateOrDate2) depthlessq++    -- The user's query with no depth limit, and expanded to the report span+    -- if there is one (otherwise any date queries are left as-is, which+    -- handles the hledger-ui+future txns case above).+    depthlessq = dbg3 "getPostings depthlessq" $ filterQuery (not . queryIsDepth) query++    fullreportspan  = if requiresHistorical ropts then DateSpan Nothing (Exact <$> spanEnd reportspan) else reportspan+    fullreportspanq = (if date2_ ropts then Date2 else Date) $ case fullreportspan of+        DateSpan Nothing Nothing -> emptydatespan+        a -> a++-- | Generate the 'Account' for the requested multi-balance report from a list+-- of 'Posting's.+generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe DayPartition -> [Posting] -> Account BalanceData+generateMultiBalanceAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans =+    -- Set account declaration info (for sorting purposes)+    mapAccounts (accountSetDeclarationInfo j)+    -- Add declared accounts if called with --declared and --empty+    . (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id)+    -- Negate amounts if applicable+    . (if invert_ ropts then fmap (mapBalanceData maNegate) else id)+    -- Mark which accounts are boring and which are interesting+    . markAccountBoring rspec+    -- Process changes into normal, cumulative, or historical amounts, plus value them+    . calculateReportAccount rspec j priceoracle colspans+    -- Clip account names+    . map clipPosting+  where+    -- Clip postings to the requested depth according to the query+    clipPosting p = p{paccount = clipOrEllipsifyAccountName depthSpec $ paccount p}+    depthSpec = dbg3 "generateMultiBalanceAccount depthSpec"+              . queryDepth . filterQuery queryIsDepth $ _rsQuery rspec++-- | Add declared accounts to the account tree.+addDeclaredAccounts :: Monoid a => ReportSpec -> Journal -> Account a -> Account a+addDeclaredAccounts rspec j acct =+    these id id const <$> mergeAccounts acct declaredTree+  where+    declaredTree =+        mapAccounts (\a -> a{aboring = not $ aname a `HS.member` HS.fromList declaredAccounts}) $+          accountTreeFromBalanceAndNames "root" (mempty <$ adata acct) declaredAccounts++    -- With --declared, add the query-matching declared accounts (as dummy postings+    -- so they are processed like the rest).+    declaredAccounts =+      map (clipOrEllipsifyAccountName depthSpec) .+      filter (matchesAccountExtra (journalAccountType j) (journalAccountTags j) accttypetagsq) $+      journalAccountNamesDeclared j++    accttypetagsq  = dbg3 "addDeclaredAccounts accttypetagsq" .+      filterQueryOrNotQuery (\q -> queryIsAcct q || queryIsType q || queryIsTag q) $+      _rsQuery rspec++    depthSpec = queryDepth . filterQuery queryIsDepth $ _rsQuery rspec+++-- | Gather the account balance changes into a regular matrix, then+-- accumulate and value amounts, as specified by the report options.+-- Makes sure all report columns have an entry.+calculateReportAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe DayPartition -> [Posting] -> Account BalanceData+calculateReportAccount _ _ _ Nothing _ =+    accountFromBalances "root" $ periodDataFromList mempty [(nulldate, mempty)]+calculateReportAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle (Just colspans) ps =+    mapPeriodData rowbals changesAcct+  where+    -- The valued row amounts to be displayed: per-period changes,+    -- zero-based cumulative totals, or+    -- starting-balance-based historical balances.+    rowbals :: PeriodData BalanceData -> PeriodData BalanceData+    rowbals unvaluedChanges = case balanceaccum_ ropts of+        PerPeriod  -> changes+        Cumulative -> cumulative+        Historical -> historical+      where+        -- changes to report on: usually just the valued changes themselves, but use the+        -- differences in the valued historical amount for CalcValueChange and CalcGain.+        changes = case balancecalc_ ropts of+            CalcChange        -> avalue unvaluedChanges+            CalcBudget        -> avalue unvaluedChanges+            CalcValueChange   -> periodChanges historical+            CalcGain          -> periodChanges historical+            CalcPostingsCount -> avalue unvaluedChanges+        -- the historical balance is the valued cumulative sum of all unvalued changes+        historical = avalue $ cumulativeSum unvaluedChanges+        -- since this is a cumulative sum of valued amounts, it should not be valued again+        cumulative = cumulativeSum changes{pdpre = mempty}+        avalue = periodDataValuation ropts j priceoracle colspans++    changesAcct = dbg5With (\x -> "calculateReportAccount changesAcct\n" ++ showAccounts x) .+        mapPeriodData (padPeriodData mempty (dayPartitionToPeriodData colspans)) $+        accountFromPostings getIntervalStartDate ps++    getIntervalStartDate p = fst $ dayPartitionFind (getPostingDate p) colspans+    getPostingDate = postingDateOrDate2 (whichDate (_rsReportOpts rspec))++-- | The valuation function to use for the chosen report options.+periodDataValuation :: ReportOpts -> Journal -> PriceOracle -> DayPartition+                    -> PeriodData BalanceData -> PeriodData BalanceData+periodDataValuation ropts j priceoracle colspans =+    opPeriodData valueBalanceData (dayPartitionToPeriodData colspans)+  where+    valueBalanceData :: Day -> BalanceData -> BalanceData+    valueBalanceData d = mapBalanceData (valueMixedAmount d)++    valueMixedAmount :: Day -> MixedAmount -> MixedAmount+    valueMixedAmount = mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle++-- | Mark which nodes of an 'Account' are boring, and so should be omitted from reports.+markAccountBoring :: ReportSpec -> Account BalanceData -> Account BalanceData+markAccountBoring ReportSpec{_rsQuery=query,_rsReportOpts=ropts}+    -- If depth 0, all accounts except the top-level account are boring+    | qdepthIsZero = markBoring False . mapAccounts (markBoring True)+    -- Otherwise the top level account is boring, and subaccounts are boring if+    -- they are both boring in and of themselves and are boring parents+    | otherwise    = markBoring True . mapAccounts (markBoringBy (liftA2 (&&) isBoring isBoringParent))+  where+    -- Accounts boring on their own+    isBoring :: Account BalanceData -> Bool+    isBoring acct = tooDeep || allZeros+      where+        tooDeep = d > qdepth                                       -- Throw out anything too deep+        allZeros = isZeroRow balance amts && not keepEmptyAccount  -- Throw away everything with a zero balance in the row, unless..+        keepEmptyAccount = empty_ ropts && keepWhenEmpty acct      -- We are keeping empty rows and this row meets the criteria++        amts = pdperiods $ adata acct+        d = accountNameLevel $ aname acct++        qdepth = fromMaybe maxBound . getAccountNameClippedDepth depthspec $ aname acct+        balance = maybeStripPrices . case accountlistmode_ ropts of+            ALTree | d == qdepth -> bdincludingsubs+            _                    -> bdexcludingsubs++    -- Accounts which don't have enough interesting subaccounts+    isBoringParent :: Account a -> Bool+    isBoringParent acct = case accountlistmode_ ropts of+        ALTree -> notEnoughSubs || droppedAccount+        ALFlat -> True+      where+        notEnoughSubs = length interestingSubs < minimumSubs+        droppedAccount = accountNameLevel (aname acct) <= drop_ ropts+        interestingSubs = filter (anyAccounts (not . aboring)) $ asubs acct+        minimumSubs = if no_elide_ ropts then 1 else 2++    isZeroRow balance = all (mixedAmountLooksZero . balance)+    keepWhenEmpty = case accountlistmode_ ropts of+        ALFlat -> any ((0<) . bdnumpostings) . pdperiods . adata  -- Keep all accounts that have postings in flat mode+        ALTree -> null . asubs                                    -- Keep only empty leaves in tree mode+    maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts++    qdepthIsZero = depthspec == DepthSpec (Just 0) []+    depthspec = queryDepth query++    markBoring   v a = a{aboring = v}+    markBoringBy f a = a{aboring = f a}+++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+generateMultiBalanceReport :: ReportOpts -> Maybe DayPartition -> Account BalanceData -> MultiBalanceReport+generateMultiBalanceReport ropts colspans =+    reportPercent ropts . generatePeriodicReport makeMultiBalanceReportRow bdincludingsubs id ropts colspans++-- | Lay out a set of postings grouped by date span into a regular matrix with rows+-- given by AccountName and columns by DateSpan, then generate a MultiBalanceReport+-- from the columns.+generatePeriodicReport :: Show c =>+    (forall a. ReportOpts -> (BalanceData -> MixedAmount) -> a -> Account b -> PeriodicReportRow a c)+    -> (b -> MixedAmount) -> (c -> MixedAmount)+    -> ReportOpts -> Maybe DayPartition -> Account b -> PeriodicReport DisplayName c+generatePeriodicReport makeRow treeAmt flatAmt ropts colspans acct =+    PeriodicReport (maybeDayPartitionToDateSpans colspans) (buildAndSort acct) totalsrow+  where+    -- Build report rows and sort them+    buildAndSort = dbg5 "generatePeriodicReport buildAndSort" . case accountlistmode_ ropts of+        ALTree | sort_amount_ ropts -> buildRows . sortTreeByAmount+        ALFlat | sort_amount_ ropts -> sortFlatByAmount . buildRows+        _                           -> buildRows . sortAccountTreeByDeclaration++    buildRows = buildReportRows makeRow ropts++    -- Calculate column totals from the inclusive balances of the root account+    totalsrow = dbg5 "generatePeriodicReport totalsrow" $ makeRow ropts bdincludingsubs () acct++    sortTreeByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of+        NormallyPositive -> sortAccountTreeOn (\r -> (Down $ amt r, aname r))+        NormallyNegative -> sortAccountTreeOn (\r -> (amt r, aname r))+      where+        amt = mixedAmountStripCosts . sortKey . fmap treeAmt . pdperiods . adata+        sortKey = case balanceaccum_ ropts of+          PerPeriod -> maSum+          _         -> maybe nullmixedamt snd . M.lookupMax++    sortFlatByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of+        NormallyPositive -> sortOn (\r -> (Down $ amt r, prrFullName r))+        NormallyNegative -> sortOn (\r -> (amt r, prrFullName r))+      where amt = mixedAmountStripCosts . flatAmt . prrTotal++-- | Build the report rows.+-- One row per account, with account name info, row amounts, row total and row average.+-- Rows are sorted according to the order in the 'Account' tree.+buildReportRows :: forall b c.+                (ReportOpts -> (BalanceData -> MixedAmount) -> DisplayName -> Account b -> PeriodicReportRow DisplayName c)+                -> ReportOpts -> Account b -> [PeriodicReportRow DisplayName c]+buildReportRows makeRow ropts = mkRows True (-drop_ ropts) 0+  where+    -- Build the row for an account at a given depth with some number of boring parents+    mkRows :: Bool -> Int -> Int -> Account b -> [PeriodicReportRow DisplayName c]+    mkRows isRoot d boringParents acct+        -- Account is boring and has no interesting children at any depth, so we stop+        | allBoring acct                 = []+        -- Account is a boring root account, and should be bypassed entirely+        | aboring acct && isRoot         = buildSubrows d 0+        -- Account is boring and has been dropped, so should be skipped and move up the hierarchy+        | aboring acct && d < 0          = buildSubrows (d + 1) 0+        -- Account is boring, and we can omit boring parents, so we should omit but keep track+        | aboring acct && canOmitParents = buildSubrows d (boringParents + 1)+        -- Account is not boring or otherwise should be displayed.+        | otherwise = makeRow ropts balance displayname acct : buildSubrows (d + 1) 0+      where+        displayname = displayedName d boringParents $ aname acct+        buildSubrows i b = concatMap (mkRows False i b) $ asubs acct++    canOmitParents = flat_ ropts || not (no_elide_ ropts)+    allBoring a = aboring a && all allBoring (asubs a)+    balance = case accountlistmode_ ropts of+        ALTree -> bdincludingsubs+        ALFlat -> bdexcludingsubs++    displayedName d boringParents name+        | d == 0 && name == "root" = DisplayName "..." "..." 0+        | otherwise = case accountlistmode_ ropts of+            ALTree -> DisplayName name leaf $ max 0 d+            ALFlat -> DisplayName name droppedName 0+      where+        leaf = accountNameFromComponents+               . reverse . take (boringParents + 1) . reverse+               $ accountNameComponents droppedName+        droppedName = accountNameDrop (drop_ ropts) name+++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makeMultiBalanceReportRow :: ReportOpts -> (BalanceData -> MixedAmount)+                          -> a -> Account BalanceData -> PeriodicReportRow a MixedAmount+makeMultiBalanceReportRow = makePeriodicReportRow nullmixedamt sumAndAverageMixedAmounts++-- | Build a report row.+--+-- Calculate the column totals. These are always the sum of column amounts.+makePeriodicReportRow :: c -> (M.Map Day c -> (c, c))+                      -> ReportOpts -> (b -> c)+                      -> a -> Account b -> PeriodicReportRow a c+makePeriodicReportRow nullEntry totalAndAverage ropts balance name acct =+    PeriodicReportRow name (toList rowbals) rowtotal avg+  where+    rowbals = fmap balance . pdperiods $ adata acct+    (total, avg) = totalAndAverage rowbals+    -- Total for a cumulative/historical report is always the last column.+    rowtotal = case balanceaccum_ ropts of+        PerPeriod -> total+        _         -> maybe nullEntry snd $ M.lookupMax rowbals++-- | Map the report rows to percentages if needed+reportPercent :: ReportOpts -> MultiBalanceReport -> MultiBalanceReport+reportPercent ropts report@(PeriodicReport spans rows totalrow)+  | percent_ ropts = PeriodicReport spans (map percentRow rows) (percentRow totalrow)+  | otherwise      = report+  where+    percentRow (PeriodicReportRow name rowvals rowtotal rowavg) =+      PeriodicReportRow name+        (zipWith perdivide rowvals $ prrAmounts totalrow)+        (perdivide rowtotal $ prrTotal totalrow)+        (perdivide rowavg $ prrAverage totalrow)++-- | A helper: what percentage is the second mixed amount of the first ?+-- Keeps the sign of the first amount.+-- Uses unifyMixedAmount to unify each argument and then divides them.+-- Both amounts should be in the same, single commodity.+-- This can call error if the arguments are not right.+perdivide :: MixedAmount -> MixedAmount -> MixedAmount+perdivide a b = fromMaybe (error' errmsg) $ do  -- PARTIAL:+    a' <- unifyMixedAmount a+    b' <- unifyMixedAmount b+    guard $ amountIsZero a' || amountIsZero b' || acommodity a' == acommodity b'+    return $ mixed [per $ if aquantity b' == 0 then 0 else aquantity a' / abs (aquantity b') * 100]+  where errmsg = "Cannot calculate percentages if accounts have different commodities (Hint: Try --cost, -V or similar flags.)"++-- | Calculate a cumulative sum from a list of period changes.+cumulativeSum :: Traversable t => t BalanceData -> t BalanceData+cumulativeSum = snd . mapAccumL (\prev new -> let z = prev <> new in (z, z)) mempty++-- | Extract period changes from a cumulative list.+periodChanges :: Traversable t => t BalanceData -> t BalanceData+periodChanges = snd . mapAccumL (\prev new -> (new, opBalanceData maMinus new prev)) mempty++-- tests++tests_MultiBalanceReport = testGroup "MultiBalanceReport" [++  let+    amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing, acostbasis=Nothing,+      astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing,+      asdecimalmark = Just '.', asprecision = Precision 2, asrounding = NoRounding}}+    (rspec,journal) `gives` r = do+      let rspec' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]}+          (eitems, etotal) = r+          (PeriodicReport _ aitems atotal) = multiBalanceReport rspec' journal+          showw (PeriodicReportRow a lAmt amt amt')+              = (displayFull a, displayName a, displayIndent a, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')+      (map showw aitems) @?= (map showw eitems)+      showMixedAmountDebug (prrTotal atotal) @?= showMixedAmountDebug etotal -- we only check the sum of the totals+  in+   testGroup "multiBalanceReport" [+      testCase "null journal"  $+      (defreportspec, nulljournal) `gives` ([], nullmixedamt)++     ,testCase "with -H on a populated period"  $+      (defreportspec{_rsReportOpts=defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balanceaccum_=Historical}}, samplejournal) `gives`+       (+        [ PeriodicReportRow (flatDisplayName "assets:bank:checking") [mixedAmount $ usd 1]    (mixedAmount $ usd 1)    (mixedAmount amt0{aquantity=1})+        , PeriodicReportRow (flatDisplayName "income:salary")        [mixedAmount $ usd (-1)] (mixedAmount $ usd (-1)) (mixedAmount amt0{aquantity=(-1)})+        ],+        mixedAmount $ usd 0)++     -- ,testCase "a valid history on an empty period"  $+     --  (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balanceaccum_=Historical}, samplejournal) `gives`+     --   (+     --    [+     --     ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})+     --    ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})+     --    ],+     --    mixedAmount usd0)++     -- ,testCase "a valid history on an empty period (more complex)"  $+     --  (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balanceaccum_=Historical}, samplejournal) `gives`+     --   (+     --    [+     --    ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})+     --    ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=1})+     --    ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",mixedAmount amt0 {aquantity=(-2)})+     --    ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=(1)})+     --    ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",mixedAmount amt0 {aquantity=(1)})+     --    ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})+     --    ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",mixedAmount amt0 {aquantity=(-1)})+     --    ],+     --    mixedAmount usd0)+    ]+ ]
− Hledger/Reports/MultiBalanceReports.hs 
@@ -1,355 +0,0 @@-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}-{-|--Multi-column balance reports, used by the balance command.---}--module Hledger.Reports.MultiBalanceReports (-  MultiBalanceReport(..),-  MultiBalanceReportRow,-  multiBalanceReport,-  balanceReportFromMultiBalanceReport,-  mbrNegate,-  mbrNormaliseSign,-  multiBalanceReportSpan,-  tableAsText,--  -- -- * Tests-  tests_MultiBalanceReports-)-where--import Data.List-import Data.Maybe-import Data.Ord-import Data.Time.Calendar-import Safe-import Text.Tabular as T-import Text.Tabular.AsciiWide--import Hledger.Data-import Hledger.Query-import Hledger.Utils -import Hledger.Read (mamountp')-import Hledger.Reports.ReportOptions-import Hledger.Reports.BalanceReport----- | A multi balance report is a balance report with one or more columns. It has:------ 1. a list of each column's period (date span)------ 2. a list of rows, each containing:------   * the full account name------   * the leaf account name------   * the account's depth------   * a list of amounts, one for each column------   * the total of the row's amounts------   * the average of the row's amounts------ 3. the column totals and the overall total and average------ The meaning of the amounts depends on the type of multi balance--- report, of which there are three: periodic, cumulative and historical--- (see 'BalanceType' and "Hledger.Cli.Commands.Balance").-newtype MultiBalanceReport =-  MultiBalanceReport ([DateSpan]-                     ,[MultiBalanceReportRow]-                     ,MultiBalanceReportTotals-                     )-type MultiBalanceReportRow    = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount)-type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals)--instance Show MultiBalanceReport where-    -- use pshow (pretty-show's ppShow) to break long lists onto multiple lines-    -- we add some bogus extra shows here to help it parse the output-    -- and wrap tuples and lists properly-    show (MultiBalanceReport (spans, items, totals)) =-        "MultiBalanceReport (ignore extra quotes):\n" ++ pshow (show spans, map show items, totals)---- type alias just to remind us which AccountNames might be depth-clipped, below.-type ClippedAccountName = AccountName---- | Generate a multicolumn balance report for the matched accounts,--- showing the change of balance, accumulated balance, or historical balance--- in each of the specified periods. Does not support tree-mode boring parent eliding.--- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts --- (see ReportOpts and CompoundBalanceCommand).-multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport-multiBalanceReport opts q j =-  (if invert_ opts then mbrNegate else id) $ -  MultiBalanceReport (displayspans, sorteditems, totalsrow)-    where-      symq       = dbg1 "symq"   $ filterQuery queryIsSym $ dbg1 "requested q" q-      depthq     = dbg1 "depthq" $ filterQuery queryIsDepth q-      depth      = queryDepth depthq-      depthless  = dbg1 "depthless" . filterQuery (not . queryIsDepth)-      datelessq  = dbg1 "datelessq"  $ filterQuery (not . queryIsDateOrDate2) q-      dateqcons  = if date2_ opts then Date2 else Date-      -- The date span specified by -b/-e/-p options and query args if any.-      requestedspan  = dbg1 "requestedspan"  $ queryDateSpan (date2_ opts) q-      -- If the requested span is open-ended, close it using the journal's end dates.-      -- This can still be the null (open) span if the journal is empty.-      requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j-      -- The list of interval spans enclosing the requested span.-      -- This list can be empty if the journal was empty,-      -- or if hledger-ui has added its special date:-tomorrow to the query-      -- and all txns are in the future.-      intervalspans  = dbg1 "intervalspans"  $ splitSpan (interval_ opts) requestedspan'           -      -- The requested span enlarged to enclose a whole number of intervals.-      -- This can be the null span if there were no intervals. -      reportspan     = dbg1 "reportspan"     $ DateSpan (maybe Nothing spanStart $ headMay intervalspans)-                                                        (maybe Nothing spanEnd   $ lastMay intervalspans)-      -- The user's query with no depth limit, and expanded to the report span-      -- if there is one (otherwise any date queries are left as-is, which-      -- handles the hledger-ui+future txns case above).-      reportq   = dbg1 "reportq" $ depthless $ -        if reportspan == nulldatespan -        then q -        else And [datelessq, reportspandatesq]-          where-            reportspandatesq = dbg1 "reportspandatesq" $ dateqcons reportspan-      -- q projected back before the report start date, to calculate starting balances.-      -- When there's no report start date, in case there are future txns (the hledger-ui case above),-      -- we use emptydatespan to make sure they aren't counted as starting balance.  -      startbalq = dbg1 "startbalq" $ And [datelessq, dateqcons precedingspan]-        where-          precedingspan = case spanStart reportspan of-                            Just d  -> DateSpan Nothing (Just d)-                            Nothing -> emptydatespan -      ps :: [Posting] =-          dbg1 "ps" $-          journalPostings $-          filterJournalAmounts symq $     -- remove amount parts excluded by cur:-          filterJournalPostings reportq $        -- remove postings not matched by (adjusted) query-          journalSelectingAmountFromOpts opts j--      displayspans = dbg1 "displayspans" $ splitSpan (interval_ opts) displayspan-        where-          displayspan-            | empty_ opts = dbg1 "displayspan (-E)" reportspan                                -- all the requested intervals-            | otherwise   = dbg1 "displayspan"      $ requestedspan `spanIntersect` matchedspan -- exclude leading/trailing empty intervals-          matchedspan = dbg1 "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps--      psPerSpan :: [[Posting]] =-          dbg1 "psPerSpan"-          [filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans]--      postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =-          dbg1 "postedAcctBalChangesPerSpan" $-          map postingAcctBals psPerSpan-          where-            postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)]-            postingAcctBals ps = [(aname a, (if tree_ opts then aibalance else aebalance) a) | a <- as]-                where-                  as = depthLimit $-                       (if tree_ opts then id else filter ((>0).anumpostings)) $-                       drop 1 $ accountsFromPostings ps-                  depthLimit-                      | tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances-                      | otherwise  = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit--      postedAccts :: [AccountName] = dbg1 "postedAccts" $ sort $ accountNamesFromPostings ps--      -- starting balances and accounts from transactions before the report start date-      startacctbals = dbg1 "startacctbals" $ map (\(a,_,_,b) -> (a,b)) startbalanceitems-          where-            (startbalanceitems,_) = dbg1 "starting balance report" $ balanceReport opts' startbalq j-                                    where-                                      opts' | tree_ opts = opts{no_elide_=True}-                                            | otherwise  = opts{accountlistmode_=ALFlat}-      startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals-      startAccts = dbg1 "startAccts" $ map fst startacctbals--      displayedAccts :: [ClippedAccountName] =-          dbg1 "displayedAccts" $-          (if tree_ opts then expandAccountNames else id) $-          nub $ map (clipOrEllipsifyAccountName depth) $-          if empty_ opts || (balancetype_ opts) == HistoricalBalance then nub $ sort $ startAccts ++ postedAccts else postedAccts--      acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =-          dbg1 "acctBalChangesPerSpan"-          [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes-           | postedacctbals <- postedAcctBalChangesPerSpan]-          where zeroes = [(a, nullmixedamt) | a <- displayedAccts]--      acctBalChanges :: [(ClippedAccountName, [MixedAmount])] =-          dbg1 "acctBalChanges"-          [(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null...--      items :: [MultiBalanceReportRow] =-          dbg1 "items" $-          [(a, accountLeafName a, accountNameLevel a, displayedBals, rowtot, rowavg)-           | (a,changes) <- acctBalChanges-           , let displayedBals = case balancetype_ opts of-                                  HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes-                                  CumulativeChange -> drop 1 $ scanl (+) nullmixedamt changes-                                  _                 -> changes-           , let rowtot = sum displayedBals-           , let rowavg = averageMixedAmounts displayedBals-           , empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals-           ]--      -- TODO TBD: is it always ok to sort report rows after report has been generated ?-      -- Or does sorting sometimes need to be done as part of the report generation ?  -      sorteditems :: [MultiBalanceReportRow] =-        dbg1 "sorteditems" $-        sortitems items-        where-          sortitems-            | sort_amount_ opts && accountlistmode_ opts == ALTree       = sortTreeMBRByAmount-            | sort_amount_ opts                                          = sortFlatMBRByAmount-            | otherwise                                                  = sortMBRByAccountDeclaration-            where-              -- Sort the report rows, representing a tree of accounts, by row total at each level.-              -- Similar to sortMBRByAccountDeclaration/sortAccountNamesByDeclaration.-              sortTreeMBRByAmount rows = sortedrows-                where-                  anamesandrows = [(first6 r, r) | r <- rows]-                  anames = map fst anamesandrows-                  atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]-                  accounttree = accountTree "root" anames-                  accounttreewithbals = mapAccounts setibalance accounttree-                    where-                      -- should not happen, but it's dangerous; TODO -                      setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}-                  sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals-                  sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree-                  sortedrows = sortAccountItemsLike sortedanames anamesandrows --              -- Sort the report rows, representing a flat account list, by row total. -              sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fifth6))-                where-                  maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip--              -- Sort the report rows by account declaration order then account name. -              sortMBRByAccountDeclaration rows = sortedrows-                where -                  anamesandrows = [(first6 r, r) | r <- rows]-                  anames = map fst anamesandrows-                  sortedanames = sortAccountNamesByDeclaration j (tree_ opts) anames-                  sortedrows = sortAccountItemsLike sortedanames anamesandrows --      totals :: [MixedAmount] =-          -- dbg1 "totals" $-          map sum balsbycol-          where-            balsbycol = transpose [bs | (a,_,_,bs,_,_) <- sorteditems, not (tree_ opts) || a `elem` highestlevelaccts]-            highestlevelaccts     =-                dbg1 "highestlevelaccts"-                [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a]--      totalsrow :: MultiBalanceReportTotals =-          dbg1 "totalsrow"-          (totals, sum totals, averageMixedAmounts totals)--      dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s)  -- add prefix in this function's debug output-      -- dbg1 = const id  -- exclude this function from debug output---- | Given a MultiBalanceReport and its normal balance sign,--- if it is known to be normally negative, convert it to normally positive.-mbrNormaliseSign :: NormalSign -> MultiBalanceReport -> MultiBalanceReport-mbrNormaliseSign NormallyNegative = mbrNegate-mbrNormaliseSign _ = id---- | Flip the sign of all amounts in a MultiBalanceReport.-mbrNegate (MultiBalanceReport (colspans, rows, totalsrow)) =-  MultiBalanceReport (colspans, map mbrRowNegate rows, mbrTotalsRowNegate totalsrow)-  where-    mbrRowNegate (acct,shortacct,indent,amts,tot,avg) = (acct,shortacct,indent,map negate amts,-tot,-avg)-    mbrTotalsRowNegate (amts,tot,avg) = (map negate amts,-tot,-avg)---- | Figure out the overall date span of a multicolumn balance report.-multiBalanceReportSpan :: MultiBalanceReport -> DateSpan-multiBalanceReportSpan (MultiBalanceReport ([], _, _))       = DateSpan Nothing Nothing-multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)---- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport, --- in order to support --historical. Does not support tree-mode boring parent eliding. --- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts --- (see ReportOpts and CompoundBalanceCommand).-balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport-balanceReportFromMultiBalanceReport opts q j = (rows', total)-  where-    MultiBalanceReport (_, rows, (totals, _, _)) = multiBalanceReport opts q j-    rows' = [(a-             ,if flat_ opts then a else a'   -- BalanceReport expects full account name here with --flat-             ,if tree_ opts then d-1 else 0  -- BalanceReport uses 0-based account depths-             , headDef nullmixedamt amts     -- 0 columns is illegal, should not happen, return zeroes if it does-             ) | (a,a',d, amts, _, _) <- rows]-    total = headDef nullmixedamt totals----- common rendering helper, XXX here for now--tableAsText :: ReportOpts -> (a -> String) -> Table String String a -> String-tableAsText (ReportOpts{pretty_tables_ = pretty}) showcell =-  unlines-  . trimborder-  . lines-  . render pretty id id showcell-  . align-  where-    trimborder = drop 1 . init . map (drop 1 . init)-    align (Table l t d) = Table l' t d-      where-        acctswidth = maximum' $ map strWidth (headerContents l)-        l'         = padRightWide acctswidth <$> l---- tests--tests_MultiBalanceReports = tests "MultiBalanceReports" [-  let-    (opts,journal) `gives` r = do-      let (eitems, etotal) = r-          (MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal-          showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')-      (map showw aitems) `is` (map showw eitems)-      ((\(_, b, _) -> showMixedAmountDebug b) atotal) `is` (showMixedAmountDebug etotal) -- we only check the sum of the totals-    usd0 = usd 0-    amount0 = Amount {acommodity="$", aquantity=0, aprice=NoPrice, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}-  in -   tests "multiBalanceReport" [-      test "null journal"  $-      (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])-  -     ,test "with -H on a populated period"  $-      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`-       (-        [-         ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-        ],-        Mixed [usd0])-  -     ,test "a valid history on an empty period"  $-      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`-       (-        [-         ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-        ],-        Mixed [usd0])-  -     ,test "a valid history on an empty period (more complex)"  $-      (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`-       (-        [-        ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-        ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-        ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amount0 {aquantity=(-2)}])-        ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])-        ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])-        ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-        ],-        Mixed [usd0])-    ]- ]
Hledger/Reports/PostingsReport.hs view
@@ -1,192 +1,225 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, TupleSections, OverloadedStrings #-} {-|  Postings report, used by the register command.  -} +{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+ module Hledger.Reports.PostingsReport (   PostingsReport,   PostingsReportItem,   postingsReport,   mkpostingsReportItem,+  SortSpec,+  defsortspec,    -- * Tests   tests_PostingsReport ) where -import Data.List-import Data.Maybe-import Data.Ord (comparing)--- import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar-import Safe (headMay, lastMay)+import Data.List (nub, sortBy, sortOn)+import Data.List.Extra (nubSort)+import Data.Maybe (isJust, isNothing, fromMaybe)+import Data.Ord+import Data.Text (Text)+import Data.Time.Calendar (Day)+import Safe (headMay)  import Hledger.Data import Hledger.Query-import Hledger.Utils +import Hledger.Utils import Hledger.Reports.ReportOptions  --- | A postings report is a list of postings with a running total, a label--- for the total field, and a little extra transaction info to help with rendering.+-- | A postings report is a list of postings with a running total, and a little extra+-- transaction info to help with rendering. -- This is used eg for the register command.-type PostingsReport = (String               -- label for the running balance column XXX remove-                      ,[PostingsReportItem] -- line items, one per posting-                      )-type PostingsReportItem = (Maybe Day    -- The posting date, if this is the first posting in a-                                        -- transaction or if it's different from the previous-                                        -- posting's date. Or if this a summary posting, the-                                        -- report interval's start date if this is the first-                                        -- summary posting in the interval.-                          ,Maybe Day    -- If this is a summary posting, the report interval's-                                        -- end date if this is the first summary posting in-                                        -- the interval.-                          ,Maybe String -- The posting's transaction's description, if this is the first posting in the transaction.-                          ,Posting      -- The posting, possibly with the account name depth-clipped.-                          ,MixedAmount  -- The running total after this posting, or with --average,-                                        -- the running average posting amount. With --historical,-                                        -- postings before the report start date are included in-                                        -- the running total/average.+type PostingsReport = [PostingsReportItem] -- line items, one per posting+type PostingsReportItem = (Maybe Day     -- The posting date, if this is the first posting in a+                                         -- transaction or if it's different from the previous+                                         -- posting's date. Or if this a summary posting, the+                                         -- report interval's start date if this is the first+                                         -- summary posting in the interval.+                          ,Maybe Period  -- If this is a summary posting, the report interval's period.+                          ,Maybe Text    -- The posting's transaction's description, if this is the first posting in the transaction.+                          ,Posting       -- The posting, possibly with the account name depth-clipped.+                          ,MixedAmount   -- The running total after this posting, or with --average,+                                         -- the running average posting amount. With --historical,+                                         -- postings before the report start date are included in+                                         -- the running total/average.                           ) +instance HasAmounts PostingsReportItem where+  styleAmounts styles (a,b,c,d,e) = (a,b,c,styleAmounts styles d,styleAmounts styles e)++-- | A summary posting summarises the activity in one account within a report+-- interval. It is by a regular Posting with no description, the interval's+-- start date stored as the posting date, and the interval's Period attached+-- with a tuple.+type SummaryPosting = (Posting, Period)+ -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command.-postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport-postingsReport opts q j = (totallabel, items)+postingsReport :: ReportSpec -> Journal -> PostingsReport+postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items     where-      reportspan = adjustReportDates opts q j-      whichdate = whichDateFromOpts opts-      depth = queryDepth q+      (reportspan, colspans) = reportSpanBothDates j rspec+      whichdate   = whichDate ropts+      depthSpec   = queryDepth $ _rsQuery rspec+      multiperiod = interval_ /= NoInterval        -- postings to be included in the report, and similarly-matched postings before the report start date-      (precedingps, reportps) = matchedPostingsBeforeAndDuring opts q j reportspan+      (precedingps, reportps) = matchedPostingsBeforeAndDuring rspec j reportspan -      -- postings or pseudo postings to be displayed-      displayps | interval == NoInterval = map (,Nothing) reportps-                | otherwise              = summarisePostingsByInterval interval whichdate depth showempty reportspan reportps+      -- Postings, or summary postings with their subperiod's end date, to be displayed.+      displayps :: [(Posting, Maybe Period)]+        | multiperiod = [(p', Just period') | (p', period') <- summariseps reportps]+        | otherwise   = [(p', Nothing) | p' <- reportps]         where-          interval = interval_ opts -- XXX-          showempty = empty_ opts || average_ opts+          summariseps = summarisePostingsByInterval whichdate (dsFlatDepth depthSpec) showempty colspans+          showempty = empty_ || average_ -      -- posting report items ready for display-      items = dbg1 "postingsReport items" $ postingsReportItems displayps (nullposting,Nothing) whichdate depth startbal runningcalc startnum+      sortedps = if sortspec_ /= defsortspec then sortPostings ropts sortspec_ displayps else displayps++      -- Posting report items ready for display.+      items =+        dbg4 "postingsReport items" $+        postingsReportItems postings (nullposting,Nothing) whichdate depthSpec startbal runningcalc startnum         where-          historical = balancetype_ opts == HistoricalBalance-          precedingsum = sumPostings precedingps-          precedingavg | null precedingps = 0-                       | otherwise        = divideMixedAmount (fromIntegral $ length precedingps) precedingsum-          startbal | average_ opts = if historical then precedingavg else 0-                   | otherwise     = if historical then precedingsum else 0+          -- In historical mode we'll need a starting balance, which we+          -- may be converting to value per hledger_options.m4.md "Effect+          -- of --value on reports".+          -- XXX balance report doesn't value starting balance.. should this ?+          historical = balanceaccum_ == Historical+          startbal | average_  = if historical then precedingavg else nullmixedamt+                   | otherwise = if historical then precedingsum else nullmixedamt+            where+              precedingsum = sumPostings precedingps+              precedingavg = divideMixedAmount (fromIntegral $ length precedingps) precedingsum++          runningcalc = registerRunningCalculationFn ropts           startnum = if historical then length precedingps + 1 else 1-          runningcalc | average_ opts = \i avg amt -> divideMixedAmount (fromIntegral i) avg + amt - avg  -- running average-                      | otherwise     = \_ bal amt -> bal + amt                                           -- running total+          postings | historical = if sortspec_ /= defsortspec +                        then error' "--historical and --sort should not be used together" +                        else sortedps+                   | otherwise = sortedps -totallabel = "Total"+-- | Based on the given report options, return a function that does the appropriate+-- running calculation for the register report, ie a running average or running total.+-- This function will take the item number, previous average/total, and new posting amount,+-- and return the new average/total.+registerRunningCalculationFn :: ReportOpts -> (Int -> MixedAmount -> MixedAmount -> MixedAmount)+registerRunningCalculationFn ropts+  | average_ ropts = \i avg amt -> avg `maPlus` divideMixedAmount (fromIntegral i) (amt `maMinus` avg)+  | otherwise      = \_ bal amt -> bal `maPlus` amt --- | Adjust report start/end dates to more useful ones based on--- journal data and report intervals. Ie:--- 1. If the start date is unspecified, use the earliest date in the journal (if any)--- 2. If the end date is unspecified, use the latest date in the journal (if any)--- 3. If a report interval is specified, enlarge the dates to enclose whole intervals-adjustReportDates :: ReportOpts -> Query -> Journal -> DateSpan-adjustReportDates opts q j = reportspan-  where-    -- see also multiBalanceReport-    requestedspan       = dbg1 "requestedspan"       $ queryDateSpan' q                                       -- span specified by -b/-e/-p options and query args-    journalspan         = dbg1 "journalspan"         $ dates `spanUnion` date2s                               -- earliest and latest dates (or date2s) in the journal-      where-        dates  = journalDateSpan False j-        date2s = journalDateSpan True  j-    requestedspanclosed = dbg1 "requestedspanclosed" $ requestedspan `spanDefaultsFrom` journalspan           -- if open-ended, close it using the journal's dates (if any)-    intervalspans       = dbg1 "intervalspans"       $ splitSpan (interval_ opts) requestedspanclosed  -- get the whole intervals enclosing that-    mreportstart        = dbg1 "reportstart"         $ maybe Nothing spanStart $ headMay intervalspans        -- start of the first interval, or open ended-    mreportend          = dbg1 "reportend"           $ maybe Nothing spanEnd   $ lastMay intervalspans        -- end of the last interval, or open ended-    reportspan          = dbg1 "reportspan"          $ DateSpan mreportstart mreportend                       -- the requested span enlarged to whole intervals if possible+-- | Sort two postings by the current list of value expressions (given in SortSpec).+comparePostings :: ReportOpts -> SortSpec -> (Posting, Maybe Period) -> (Posting, Maybe Period) -> Ordering+comparePostings _ [] _ _ = EQ+comparePostings ropts (ex:es) (a, pa) (b, pb) = +    let +    getDescription p = +        let tx = ptransaction p +            description = fmap (\t -> tdescription t) tx+        -- If there's no transaction attached, then use empty text for the description+        in fromMaybe "" description+    comparison = case ex of+          AbsAmount' False -> compare (abs (pamount a)) (abs (pamount b))+          Amount' False -> compare (pamount a) (pamount b)+          Account' False -> compare (paccount a) (paccount b)+          Date' False -> compare (postingDateOrDate2 (whichDate ropts) a) (postingDateOrDate2 (whichDate ropts) b)+          Description' False -> compare (getDescription a) (getDescription b)+          AbsAmount' True -> compare (Down (abs (pamount a))) (Down (abs (pamount b)))+          Amount' True -> compare (Down (pamount a)) (Down (pamount b))+          Account' True -> compare (Down (paccount a)) (Down (paccount b))+          Date' True -> compare (Down (postingDateOrDate2 (whichDate ropts) a)) (Down (postingDateOrDate2 (whichDate ropts) b))+          Description' True -> compare (Down (getDescription a)) (Down (getDescription b))+    in +    if comparison == EQ then comparePostings ropts es (a, pa) (b, pb) else comparison +-- | Sort postings by the current SortSpec.+sortPostings :: ReportOpts -> SortSpec -> [(Posting, Maybe Period)] -> [(Posting, Maybe Period)]+sortPostings ropts sspec = sortBy (comparePostings ropts sspec)+ -- | Find postings matching a given query, within a given date span, -- and also any similarly-matched postings before that date span. -- Date restrictions and depth restrictions in the query are ignored. -- A helper for the postings report.-matchedPostingsBeforeAndDuring :: ReportOpts -> Query -> Journal -> DateSpan -> ([Posting],[Posting])-matchedPostingsBeforeAndDuring opts q j (DateSpan mstart mend) =-  dbg1 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps+matchedPostingsBeforeAndDuring :: ReportSpec -> Journal -> DateSpan -> ([Posting],[Posting])+matchedPostingsBeforeAndDuring rspec@ReportSpec{_rsReportOpts=ropts,_rsQuery=q} j reportspan =+    dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps   where-    beforestartq = dbg1 "beforestartq" $ dateqtype $ DateSpan Nothing mstart+    beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing (Exact <$> spanStart reportspan)     beforeandduringps =-      dbg1 "ps5" $ sortBy (comparing sortdate) $                               -- sort postings by date or date2-      dbg1 "ps4" $ (if invert_ opts then map negatePostingAmount else id) $    -- with --invert, invert amounts-      dbg1 "ps3" $ map (filterPostingAmount symq) $                            -- remove amount parts which the query's cur: terms would exclude-      dbg1 "ps2" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings-      dbg1 "ps1" $ filter (beforeandduringq `matchesPosting`) $                -- filter postings by the query, with no start date or depth limit-                  journalPostings $ journalSelectingAmountFromOpts opts j-      where-        beforeandduringq = dbg1 "beforeandduringq" $ And [depthless $ dateless q, beforeendq]-          where-            depthless  = filterQuery (not . queryIsDepth)-            dateless   = filterQuery (not . queryIsDateOrDate2)-            beforeendq = dateqtype $ DateSpan Nothing mend-        sortdate = if date2_ opts then postingDate2 else postingDate-        symq = dbg1 "symq" $ filterQuery queryIsSym q-    dateqtype-      | queryIsDate2 dateq || (queryIsDate dateq && date2_ opts) = Date2-      | otherwise = Date+        sortOn (postingDateOrDate2 (whichDate ropts))            -- sort postings by date or date2+      . (if invert_ ropts then map postingNegateMainAmount else id)  -- with --invert, invert amounts+      . filter hasAmount                                         -- omit postings with no definite amount+      . journalPostings+      -- With most calls we will not require transaction prices past this point, and can get a big+      -- speed improvement by stripping them early. In some cases, such as in hledger-ui, we still+      -- want to keep prices around, so we can toggle between cost and no cost quickly. We can use+      -- the show_costs_ flag to be efficient when we can, and detailed when we have to.+      . (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripCosts)+      $ journalValueAndFilterPostings rspec{_rsQuery=beforeandduringq} j++    -- filter postings by the query, with no start date or depth limit+    beforeandduringq = dbg4 "beforeandduringq" $ And [depthless $ dateless q, beforeendq]       where-        dateq = dbg1 "dateq" $ filterQuery queryIsDateOrDate2 $ dbg1 "q" q  -- XXX confused by multiple date:/date2: ?+        depthless  = filterQuery (not . queryIsDepth)+        dateless   = filterQuery (not . queryIsDateOrDate2)+        beforeendq = dateqtype $ DateSpan Nothing (Exact <$> spanEnd reportspan) -negatePostingAmount :: Posting -> Posting-negatePostingAmount p = p { pamount = negate $ pamount p }+    dateqtype = if queryIsDate2 dateq || (queryIsDate dateq && date2_ ropts) then Date2 else Date+      where+        dateq = dbg4 "matchedPostingsBeforeAndDuring dateq" $ filterQuery queryIsDateOrDate2 $ dbg4 "matchedPostingsBeforeAndDuring q" q  -- XXX confused by multiple date:/date2: ?  -- | Generate postings report line items from a list of postings or (with--- non-Nothing dates attached) summary postings.-postingsReportItems :: [(Posting,Maybe Day)] -> (Posting,Maybe Day) -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem]+-- non-Nothing periods attached) summary postings.+postingsReportItems :: [(Posting,Maybe Period)] -> (Posting,Maybe Period) -> WhichDate -> DepthSpec -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = []-postingsReportItems ((p,menddate):ps) (pprev,menddateprev) wd d b runningcalcfn itemnum = i:(postingsReportItems ps (p,menddate) wd d b' runningcalcfn (itemnum+1))-    where-      i = mkpostingsReportItem showdate showdesc wd menddate p' b'-      (showdate, showdesc) | isJust menddate = (menddate /= menddateprev,        False)-                           | otherwise       = (isfirstintxn || isdifferentdate, isfirstintxn)-      isfirstintxn = ptransaction p /= ptransaction pprev-      isdifferentdate = case wd of PrimaryDate   -> postingDate p  /= postingDate pprev-                                   SecondaryDate -> postingDate2 p /= postingDate2 pprev-      p' = p{paccount= clipOrEllipsifyAccountName d $ paccount p}-      b' = runningcalcfn itemnum b (pamount p)+postingsReportItems ((p,mperiod):ps) (pprev,mperiodprev) wd d b runningcalcfn itemnum =+    i:(postingsReportItems ps (p,mperiod) wd d b' runningcalcfn (itemnum+1))+  where+    i = mkpostingsReportItem showdate showdesc wd mperiod p' b'+    (showdate, showdesc) | isJust mperiod = (mperiod /= mperiodprev,          False)+                         | otherwise      = (isfirstintxn || isdifferentdate, isfirstintxn)+    isfirstintxn = ptransaction p /= ptransaction pprev+    isdifferentdate = case wd of PrimaryDate   -> postingDate p  /= postingDate pprev+                                 SecondaryDate -> postingDate2 p /= postingDate2 pprev+    p' = p{paccount= clipOrEllipsifyAccountName d $ paccount p}+    b' = runningcalcfn itemnum b $ pamount p  -- | Generate one postings report line item, containing the posting, -- the current running balance, and optionally the posting date and/or -- the transaction description.-mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Day -> Posting -> MixedAmount -> PostingsReportItem-mkpostingsReportItem showdate showdesc wd menddate p b =-  (if showdate then Just date else Nothing-  ,menddate-  ,if showdesc then Just desc else Nothing+mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Period -> Posting -> MixedAmount -> PostingsReportItem+mkpostingsReportItem showdate showdesc wd mperiod p b =+  (if showdate then Just $ postingDateOrDate2 wd p else Nothing+  ,mperiod+  ,if showdesc then tdescription <$> ptransaction p else Nothing   ,p   ,b   )-  where-    date = case wd of PrimaryDate   -> postingDate p-                      SecondaryDate -> postingDate2 p-    desc = T.unpack $ maybe "" tdescription $ ptransaction p  -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any.-summarisePostingsByInterval :: Interval -> WhichDate -> Int -> Bool -> DateSpan -> [Posting] -> [SummaryPosting]-summarisePostingsByInterval interval wd depth showempty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan-    where-      summarisespan s = summarisePostingsInDateSpan s wd depth showempty (postingsinspan s)-      postingsinspan s = filter (isPostingInDateSpan' wd s) ps---- | A summary posting summarises the activity in one account within a report--- interval. It is currently kludgily represented by a regular Posting with no--- description, the interval's start date stored as the posting date, and the--- interval's end date attached with a tuple.-type SummaryPosting = (Posting, Maybe Day)+-- Each summary posting will have a non-Nothing interval end date.+summarisePostingsByInterval :: WhichDate -> Maybe Int -> Bool -> Maybe DayPartition -> [Posting] -> [SummaryPosting]+summarisePostingsByInterval wd mdepth showempty colspans =+    concatMap (\(s,ps) -> summarisePostingsInDateSpan s wd mdepth showempty ps)+    -- Group postings into their columns. We try to be efficient, since+    -- there can possibly be a very large number of intervals (cf #1683)+    . groupByDateSpan showempty (postingDateOrDate2 wd) (maybeDayPartitionToDateSpans colspans)  -- | Given a date span (representing a report interval) and a list of -- postings within it, aggregate the postings into one summary posting per--- account.+-- account. Each summary posting will have a non-Nothing interval end date. -- -- When a depth argument is present, postings to accounts of greater -- depth are also aggregated where possible. If the depth is 0, all@@ -196,52 +229,49 @@ -- The showempty flag includes spans with no postings and also postings -- with 0 amount. ---summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Int -> Bool -> [Posting] -> [SummaryPosting]-summarisePostingsInDateSpan (DateSpan b e) wd depth showempty ps-    | null ps && (isNothing b || isNothing e) = []-    | null ps && showempty = [(summaryp, Just e')]-    | otherwise = summarypes-    where-      postingdate = if wd == PrimaryDate then postingDate else postingDate2-      b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b-      e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e-      summaryp = nullposting{pdate=Just b'}-      clippedanames | depth > 0 = nub $ map (clipAccountName depth) anames-                    | otherwise = ["..."]-      summaryps | depth > 0 = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]-                | otherwise = [summaryp{paccount="...",pamount=sum $ map pamount ps}]-      summarypes = map (, Just e') $ (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps-      anames = sort $ nub $ map paccount ps-      -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping-      accts = accountsFromPostings ps-      balance a = maybe nullmixedamt bal $ lookupAccount a accts-        where-          bal = if isclipped a then aibalance else aebalance-          isclipped a = accountNameLevel a >= depth+summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Maybe Int -> Bool -> [Posting] -> [SummaryPosting]+summarisePostingsInDateSpan spn@(DateSpan b e) wd mdepth showempty ps+  | null ps && (isNothing b || isNothing e) = []+  | null ps && showempty = [(summaryp, dateSpanAsPeriod spn)]+  | otherwise = summarypes+  where+    postingdate = if wd == PrimaryDate then postingDate else postingDate2+    b' = maybe (maybe nulldate postingdate $ headMay ps) fromEFDay b+    summaryp = nullposting{pdate=Just b'}+    clippedanames = nub $ map (clipAccountName (DepthSpec mdepth [])) anames+    summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}]+              | otherwise        = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]+    summarypes = map (, dateSpanAsPeriod spn) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps+    anames = nubSort $ map paccount ps+    -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping+    accts = accountsFromPostings (const Nothing) ps+    balance a = maybe nullmixedamt bal $ lookupAccount a accts+      where+        bal = (if isclipped a then bdincludingsubs else bdexcludingsubs) . pdpre . adata+        isclipped a' = maybe False (accountNameLevel a' >=) mdepth + -- tests -tests_PostingsReport = tests "PostingsReport" [+tests_PostingsReport = testGroup "PostingsReport" [ -   tests "postingsReport" $-    let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n-    in [-     -- with the query specified explicitly-      (Any, nulljournal) `gives` 0-     ,(Any, samplejournal) `gives` 13-     -- register --depth just clips account names-     ,(Depth 2, samplejournal) `gives` 13-     ,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2-     ,(And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2-  -     -- with query and/or command-line options-     ,(length $ snd $ postingsReport defreportopts Any samplejournal) `is` 13-     ,(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) `is` 11-     ,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20-     ,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5-  +   testCase "postingsReport" $ do+    let (query, journal) `gives` n = (length $ postingsReport defreportspec{_rsQuery=query} journal) @?= n+    -- with the query specified explicitly+    (Any, nulljournal) `gives` 0+    (Any, samplejournal) `gives` 13+    -- register --depth just clips account names+    (Depth 2, samplejournal) `gives` 13+    (And [Depth 1, StatusQ Cleared, Acct (toRegex' "expenses")], samplejournal) `gives` 2+    (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2+    -- with query and/or command-line options+    (length $ postingsReport defreportspec samplejournal) @?= 13+    (length $ postingsReport defreportspec{_rsReportOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11+    (length $ postingsReport defreportspec{_rsReportOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20+    (length $ postingsReport defreportspec{_rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5+      -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0-     -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking             $1,$1)+     -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking             $1,$1)      -- ,(Nothing,income:salary                   $-1,0)      -- ,(Just (2008-06-01,"gift"),assets:bank:checking             $1,$1)      -- ,(Nothing,income:gifts                    $-1,0)@@ -251,7 +281,7 @@      -- ,(Nothing,expenses:supplies                $1,$2)      -- ,(Nothing,assets:cash                     $-2,0)      -- ,(Just (2008-12-31,"pay off"),liabilities:debts                $1,$1)-     -- ,(Nothing,assets:bank:checking            $-1,0)    +     -- ,(Nothing,assets:bank:checking            $-1,0)      {-         let opts = defreportopts@@ -268,11 +298,11 @@          ,"2008/12/31 pay off              liabilities:debts                $1           $1"          ,"                                assets:bank:checking            $-1            0"          ]-    +       ,"postings report with cleared option" ~:        do         let opts = defreportopts{cleared_=True}-        j <- readJournal' sample_journal_str+        j <- readJournal'' sample_journal_str         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/06/03 eat & shop           expenses:food                    $1           $1"          ,"                                expenses:supplies                $1           $2"@@ -280,11 +310,11 @@          ,"2008/12/31 pay off              liabilities:debts                $1           $1"          ,"                                assets:bank:checking            $-1            0"          ]-    +       ,"postings report with uncleared option" ~:        do         let opts = defreportopts{uncleared_=True}-        j <- readJournal' sample_journal_str+        j <- readJournal'' sample_journal_str         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/01/01 income               assets:bank:checking             $1           $1"          ,"                                income:salary                   $-1            0"@@ -293,10 +323,10 @@          ,"2008/06/02 save                 assets:bank:saving               $1           $1"          ,"                                assets:bank:checking            $-1            0"          ]-    +       ,"postings report sorts by date" ~:        do-        j <- readJournal' $ unlines+        j <- readJournal'' $ unlines             ["2008/02/02 a"             ,"  b  1"             ,"  c"@@ -307,7 +337,7 @@             ]         let opts = defreportopts         registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]-    +       ,"postings report with account pattern" ~:        do         j <- samplejournal@@ -315,7 +345,7 @@         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"          ]-    +       ,"postings report with account pattern, case insensitive" ~:        do         j <- samplejournal@@ -323,33 +353,33 @@         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"          ]-    +       ,"postings report with display expression" ~:        do         j <- samplejournal         let gives displayexpr =                 (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`)-                    where opts = defreportopts{display_=Just displayexpr}+                    where opts = defreportopts         "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]         "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]         "d=[2008/6/2]"  `gives` ["2008/06/02"]         "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]         "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]-    +       ,"postings report with period expression" ~:        do         j <- samplejournal         let periodexpr `gives` dates = do               j' <- samplejournal               registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates-                  where opts = defreportopts{period_=maybePeriod date1 periodexpr}+                  where opts = defreportopts{period_=Just $ parsePeriodExpr' date1 periodexpr}         ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]         "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]         "2007" `gives` []         "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]         "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]         "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]-        let opts = defreportopts{period_=maybePeriod date1 "yearly"}+        let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "yearly"}         (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines          ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"          ,"                                assets:cash                     $-2          $-1"@@ -359,13 +389,13 @@          ,"                                income:salary                   $-1          $-1"          ,"                                liabilities:debts                $1            0"          ]-        let opts = defreportopts{period_=maybePeriod date1 "quarterly"}+        let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "quarterly"}         registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]-        let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True}+        let opts = defreportopts{period_=Just $ parsePeriodExpr' date1 "quarterly",empty_=True}         registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]-    +       ]-    +       , "postings report with depth arg" ~:        do         j <- samplejournal@@ -383,50 +413,46 @@          ,"2008/12/31 pay off              liabilities:debts                $1           $1"          ,"                                assets:bank                     $-1            0"          ]-    +     -}-    ] -  ,tests "summarisePostingsByInterval" [-    tests "summarisePostingsByInterval" [-      summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` []-      ]-   ]-  +  ,testCase "summarisePostingsByInterval" $+    summarisePostingsByInterval PrimaryDate Nothing False Nothing [] @?= []+   -- ,tests_summarisePostingsInDateSpan = [     --  "summarisePostingsInDateSpan" ~: do     --   let gives (b,e,depth,showempty,ps) =-    --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)+    --           (summarisePostingsInDateSpan (DateSpan b e) depth showempty ps `is`)     --   let ps =     --           [-    --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}-    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 2]}-    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}-    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 8]}+    --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=mixedAmount (usd 1)}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=mixedAmount (usd 2)}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=mixedAmount (usd 4)}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=mixedAmount (usd 8)}     --           ]     --   ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`     --    []     --   ("2008/01/01","2009/01/01",0,9999,True,[]) `gives`     --    [-    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}+    --     nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31"}     --    ]     --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`     --    [-    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}-    --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 10]}-    --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}+    --     nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=mixedAmount (usd 4)}+    --    ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=mixedAmount (usd 10)}+    --    ,nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=mixedAmount (usd 1)}     --    ]     --   ("2008/01/01","2009/01/01",0,2,False,ts) `gives`     --    [-    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]}+    --     nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=mixedAmount (usd 15)}     --    ]     --   ("2008/01/01","2009/01/01",0,1,False,ts) `gives`     --    [-    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]}+    --     nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=mixedAmount (usd 15)}     --    ]     --   ("2008/01/01","2009/01/01",0,0,False,ts) `gives`     --    [-    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]}+    --     nullposting{lpdate=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="",lpamount=mixedAmount (usd 15)}     --    ]-  +  ]
Hledger/Reports/ReportOptions.hs view
@@ -4,443 +4,1023 @@  -} -{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable #-}--module Hledger.Reports.ReportOptions (-  ReportOpts(..),-  BalanceType(..),-  AccountListMode(..),-  FormatStr,-  defreportopts,-  rawOptsToReportOpts,-  checkReportOpts,-  flat_,-  tree_,-  reportOptsToggleStatus,-  simplifyStatuses,-  whichDateFromOpts,-  journalSelectingAmountFromOpts,-  intervalFromRawOpts,-  queryFromOpts,-  queryFromOptsOnly,-  queryOptsFromOpts,-  transactionDateFn,-  postingDateFn,-  reportSpan,-  reportStartDate,-  reportEndDate,-  specifiedStartEndDates,-  specifiedStartDate,-  specifiedEndDate,--  tests_ReportOptions-)-where--import Control.Applicative ((<|>))-import Data.Data (Data)-import Data.List-import Data.Maybe-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Data.Time.Calendar-import Data.Default-import Safe-import System.Console.ANSI (hSupportsANSI)-import System.IO (stdout)-import Text.Megaparsec.Custom--import Hledger.Data-import Hledger.Query-import Hledger.Utils---type FormatStr = String---- | Which "balance" is being shown in a balance report.-data BalanceType = PeriodChange      -- ^ The change of balance in each period.-                 | CumulativeChange  -- ^ The accumulated change across multiple periods.-                 | HistoricalBalance -- ^ The historical ending balance, including the effect of-                                     --   all postings before the report period. Unless altered by,-                                     --   a query, this is what you would see on a bank statement.-  deriving (Eq,Show,Data,Typeable)--instance Default BalanceType where def = PeriodChange---- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ?-data AccountListMode = ALDefault | ALTree | ALFlat deriving (Eq, Show, Data, Typeable)--instance Default AccountListMode where def = ALDefault---- | Standard options for customising report filtering and output.--- Most of these correspond to standard hledger command-line options--- or query arguments, but not all. Some are used only by certain--- commands, as noted below. -data ReportOpts = ReportOpts {-     period_         :: Period-    ,interval_       :: Interval-    ,statuses_       :: [Status]  -- ^ Zero, one, or two statuses to be matched-    ,cost_           :: Bool-    ,depth_          :: Maybe Int-    ,display_        :: Maybe DisplayExp-    ,date2_          :: Bool-    ,empty_          :: Bool-    ,no_elide_       :: Bool-    ,real_           :: Bool-    ,format_         :: Maybe FormatStr-    ,query_          :: String -- all arguments, as a string-    -- register command only-    ,average_        :: Bool-    ,related_        :: Bool-    -- balance-type commands only-    ,balancetype_    :: BalanceType-    ,accountlistmode_ :: AccountListMode-    ,drop_           :: Int-    ,row_total_      :: Bool-    ,no_total_       :: Bool-    ,value_          :: Bool-    ,pretty_tables_  :: Bool-    ,sort_amount_    :: Bool-    ,invert_         :: Bool  -- ^ if true, flip all amount signs in reports-    ,normalbalance_  :: Maybe NormalSign-      -- ^ This can be set when running balance reports on a set of accounts-      --   with the same normal balance type (eg all assets, or all incomes).-      -- - It helps --sort-amount know how to sort negative numbers-      --   (eg in the income section of an income statement) -      -- - It helps compound balance report commands (is, bs etc.) do  -      --   sign normalisation, converting normally negative subreports to -      --   normally positive for a more conventional display.   -    ,color_          :: Bool-    ,forecast_       :: Bool-    ,transpose_      :: Bool- } deriving (Show, Data, Typeable)--instance Default ReportOpts where def = defreportopts--defreportopts :: ReportOpts-defreportopts = ReportOpts-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def--rawOptsToReportOpts :: RawOpts -> IO ReportOpts-rawOptsToReportOpts rawopts = checkReportOpts <$> do-  let rawopts' = checkRawOpts rawopts-  d <- getCurrentDay-  color <- hSupportsANSI stdout-  return defreportopts{-     period_      = periodFromRawOpts d rawopts'-    ,interval_    = intervalFromRawOpts rawopts'-    ,statuses_    = statusesFromRawOpts rawopts'-    ,cost_        = boolopt "cost" rawopts'-    ,depth_       = maybeintopt "depth" rawopts'-    ,display_     = maybedisplayopt d rawopts'-    ,date2_       = boolopt "date2" rawopts'-    ,empty_       = boolopt "empty" rawopts'-    ,no_elide_    = boolopt "no-elide" rawopts'-    ,real_        = boolopt "real" rawopts'-    ,format_      = maybestringopt "format" rawopts' -- XXX move to CliOpts or move validation from Cli.CliOptions to here-    ,query_       = unwords $ listofstringopt "args" rawopts' -- doesn't handle an arg like "" right-    ,average_     = boolopt "average" rawopts'-    ,related_     = boolopt "related" rawopts'-    ,balancetype_ = balancetypeopt rawopts'-    ,accountlistmode_ = accountlistmodeopt rawopts'-    ,drop_        = intopt "drop" rawopts'-    ,row_total_   = boolopt "row-total" rawopts'-    ,no_total_    = boolopt "no-total" rawopts'-    ,value_       = boolopt "value" rawopts'-    ,sort_amount_ = boolopt "sort-amount" rawopts'-    ,invert_      = boolopt "invert" rawopts'-    ,pretty_tables_ = boolopt "pretty-tables" rawopts'-    ,color_       = color-    ,forecast_    = boolopt "forecast" rawopts'-    ,transpose_   = boolopt "transpose" rawopts'-    }---- | Do extra validation of raw option values, raising an error if there's a problem.-checkRawOpts :: RawOpts -> RawOpts-checkRawOpts rawopts--- our standard behaviour is to accept conflicting options actually,--- using the last one - more forgiving for overriding command-line aliases---   | countopts ["change","cumulative","historical"] > 1---     = usageError "please specify at most one of --change, --cumulative, --historical"---   | countopts ["flat","tree"] > 1---     = usageError "please specify at most one of --flat, --tree"---   | countopts ["daily","weekly","monthly","quarterly","yearly"] > 1---     = usageError "please specify at most one of --daily, "-  | otherwise = rawopts---   where---     countopts = length . filter (`boolopt` rawopts)---- | Do extra validation of report options, raising an error if there's a problem.-checkReportOpts :: ReportOpts -> ReportOpts-checkReportOpts ropts@ReportOpts{..} =-  either usageError (const ropts) $ do-    case depth_ of-      Just d | d < 0 -> Left "--depth should have a positive number"-      _              -> Right ()--accountlistmodeopt :: RawOpts -> AccountListMode-accountlistmodeopt rawopts =-  case reverse $ filter (`elem` ["tree","flat"]) $ map fst rawopts of-    ("tree":_) -> ALTree-    ("flat":_) -> ALFlat-    _          -> ALDefault--balancetypeopt :: RawOpts -> BalanceType-balancetypeopt rawopts =-  case reverse $ filter (`elem` ["change","cumulative","historical"]) $ map fst rawopts of-    ("historical":_) -> HistoricalBalance-    ("cumulative":_) -> CumulativeChange-    _                -> PeriodChange---- Get the period specified by the intersection of -b/--begin, -e/--end and/or--- -p/--period options, using the given date to interpret relative date expressions.-periodFromRawOpts :: Day -> RawOpts -> Period-periodFromRawOpts d rawopts =-  case (mearliestb, mlateste) of-    (Nothing, Nothing) -> PeriodAll-    (Just b, Nothing)  -> PeriodFrom b-    (Nothing, Just e)  -> PeriodTo e-    (Just b, Just e)   -> simplifyPeriod $-                          PeriodBetween b e-  where-    mearliestb = case beginDatesFromRawOpts d rawopts of-                   [] -> Nothing-                   bs -> Just $ minimum bs-    mlateste   = case endDatesFromRawOpts d rawopts of-                   [] -> Nothing-                   es -> Just $ maximum es---- Get all begin dates specified by -b/--begin or -p/--period options, in order,--- using the given date to interpret relative date expressions.-beginDatesFromRawOpts :: Day -> RawOpts -> [Day]-beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d)-  where-    begindatefromrawopt d (n,v)-      | n == "begin" =-          either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $-          fixSmartDateStrEither' d (T.pack v)-      | n == "period" =-        case-          either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $-          parsePeriodExpr d (stripquotes $ T.pack v)-        of-          (_, DateSpan (Just b) _) -> Just b-          _                        -> Nothing-      | otherwise = Nothing---- Get all end dates specified by -e/--end or -p/--period options, in order,--- using the given date to interpret relative date expressions.-endDatesFromRawOpts :: Day -> RawOpts -> [Day]-endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d)-  where-    enddatefromrawopt d (n,v)-      | n == "end" =-          either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $-          fixSmartDateStrEither' d (T.pack v)-      | n == "period" =-        case-          either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $-          parsePeriodExpr d (stripquotes $ T.pack v)-        of-          (_, DateSpan _ (Just e)) -> Just e-          _                        -> Nothing-      | otherwise = Nothing---- | Get the report interval, if any, specified by the last of -p/--period,--- -D/--daily, -W/--weekly, -M/--monthly etc. options.-intervalFromRawOpts :: RawOpts -> Interval-intervalFromRawOpts = lastDef NoInterval . catMaybes . map intervalfromrawopt-  where-    intervalfromrawopt (n,v)-      | n == "period" =-          either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) (Just . fst) $-          parsePeriodExpr nulldate (stripquotes $ T.pack v) -- reference date does not affect the interval-      | n == "daily"     = Just $ Days 1-      | n == "weekly"    = Just $ Weeks 1-      | n == "monthly"   = Just $ Months 1-      | n == "quarterly" = Just $ Quarters 1-      | n == "yearly"    = Just $ Years 1-      | otherwise = Nothing---- | Get any statuses to be matched, as specified by -U/--unmarked,--- -P/--pending, -C/--cleared flags. -UPC is equivalent to no flags,--- so this returns a list of 0-2 unique statuses.-statusesFromRawOpts :: RawOpts -> [Status]-statusesFromRawOpts = simplifyStatuses . catMaybes . map statusfromrawopt-  where-    statusfromrawopt (n,_)-      | n == "unmarked"  = Just Unmarked-      | n == "pending"   = Just Pending-      | n == "cleared"   = Just Cleared-      | otherwise        = Nothing---- | Reduce a list of statuses to just one of each status,--- and if all statuses are present return the empty list.-simplifyStatuses l-  | length l' >= numstatuses = []-  | otherwise                = l'-  where-    l' = nub $ sort l -    numstatuses = length [minBound .. maxBound :: Status]---- | Add/remove this status from the status list. Used by hledger-ui.-reportOptsToggleStatus s ropts@ReportOpts{statuses_=ss}-  | s `elem` ss = ropts{statuses_=filter (/= s) ss}-  | otherwise   = ropts{statuses_=simplifyStatuses (s:ss)}--type DisplayExp = String--maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp-maybedisplayopt d rawopts =-    maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts-    where-      fixbracketeddatestr "" = ""-      fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"---- | Select the Transaction date accessor based on --date2.-transactionDateFn :: ReportOpts -> (Transaction -> Day)-transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate---- | Select the Posting date accessor based on --date2.-postingDateFn :: ReportOpts -> (Posting -> Day)-postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate---- | Report which date we will report on based on --date2.-whichDateFromOpts :: ReportOpts -> WhichDate-whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate---- | Legacy-compatible convenience aliases for accountlistmode_.-tree_ :: ReportOpts -> Bool-tree_ = (==ALTree) . accountlistmode_--flat_ :: ReportOpts -> Bool-flat_ = (==ALFlat) . accountlistmode_---- depthFromOpts :: ReportOpts -> Int--- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts)---- | Convert this journal's postings' amounts to the cost basis amounts if--- specified by options.-journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal-journalSelectingAmountFromOpts opts-    | cost_ opts = journalConvertAmountsToCost-    | otherwise = id---- | Convert report options and arguments to a query.-queryFromOpts :: Day -> ReportOpts -> Query-queryFromOpts d ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]-  where-    flagsq = And $-              [(if date2_ then Date2 else Date) $ periodAsDateSpan period_]-              ++ (if real_ then [Real True] else [])-              ++ (if empty_ then [Empty True] else []) -- ?-              ++ [Or $ map StatusQ statuses_]-              ++ (maybe [] ((:[]) . Depth) depth_)-    argsq = fst $ parseQuery d (T.pack query_)---- | Convert report options to a query, ignoring any non-flag command line arguments.-queryFromOptsOnly :: Day -> ReportOpts -> Query-queryFromOptsOnly _d ReportOpts{..} = simplifyQuery flagsq-  where-    flagsq = And $-              [(if date2_ then Date2 else Date) $ periodAsDateSpan period_]-              ++ (if real_ then [Real True] else [])-              ++ (if empty_ then [Empty True] else []) -- ?-              ++ [Or $ map StatusQ statuses_]-              ++ (maybe [] ((:[]) . Depth) depth_)---- | Convert report options and arguments to query options.-queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]-queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts-  where-    flagsqopts = []-    argsqopts = snd $ parseQuery d (T.pack query_)---- | The effective report span is the start and end dates specified by--- options or queries, or otherwise the earliest and latest transaction or --- posting dates in the journal. If no dates are specified by options/queries--- and the journal is empty, returns the null date span.--- Needs IO to parse smart dates in options/queries.-reportSpan :: Journal -> ReportOpts -> IO DateSpan-reportSpan j ropts = do-  (mspecifiedstartdate, mspecifiedenddate) <--    dbg2 "specifieddates" <$> specifiedStartEndDates ropts-  let-    DateSpan mjournalstartdate mjournalenddate =-      dbg2 "journalspan" $ journalDateSpan False j  -- ignore secondary dates-    mstartdate = mspecifiedstartdate <|> mjournalstartdate-    menddate   = mspecifiedenddate   <|> mjournalenddate-  return $ dbg1 "reportspan" $ DateSpan mstartdate menddate--reportStartDate :: Journal -> ReportOpts -> IO (Maybe Day)-reportStartDate j ropts = spanStart <$> reportSpan j ropts--reportEndDate :: Journal -> ReportOpts -> IO (Maybe Day)-reportEndDate j ropts = spanEnd <$> reportSpan j ropts---- | The specified report start/end dates are the dates specified by options or queries, if any.--- Needs IO to parse smart dates in options/queries.-specifiedStartEndDates :: ReportOpts -> IO (Maybe Day, Maybe Day)-specifiedStartEndDates ropts = do-  today <- getCurrentDay-  let-    q = queryFromOpts today ropts-    mspecifiedstartdate = queryStartDate False q-    mspecifiedenddate   = queryEndDate   False q-  return (mspecifiedstartdate, mspecifiedenddate)--specifiedStartDate :: ReportOpts -> IO (Maybe Day)-specifiedStartDate ropts = fst <$> specifiedStartEndDates ropts--specifiedEndDate :: ReportOpts -> IO (Maybe Day)-specifiedEndDate ropts = snd <$> specifiedStartEndDates ropts---- tests--tests_ReportOptions = tests "ReportOptions" [-   tests "queryFromOpts" [-      (queryFromOpts nulldate defreportopts) `is` Any-     ,(queryFromOpts nulldate defreportopts{query_="a"}) `is` (Acct "a")-     ,(queryFromOpts nulldate defreportopts{query_="desc:'a a'"}) `is` (Desc "a a")-     ,(queryFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01"),query_="date:'to 2013'" }) -      `is` (Date $ mkdatespan "2012/01/01" "2013/01/01")-     ,(queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"}) `is` (Date2 $ mkdatespan "2012/01/01" "2013/01/01")-     ,(queryFromOpts nulldate defreportopts{query_="'a a' 'b"}) `is` (Or [Acct "a a", Acct "'b"])-     ]--  ,tests "queryOptsFromOpts" [-      (queryOptsFromOpts nulldate defreportopts) `is` []-     ,(queryOptsFromOpts nulldate defreportopts{query_="a"}) `is` []-     ,(queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01")-                                                                   ,query_="date:'to 2013'"-                                                                   })-      `is` []-    ]- ]-+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators #-}++module Hledger.Reports.ReportOptions (+  ReportOpts(..),+  HasReportOptsNoUpdate(..),+  HasReportOpts(..),+  ReportSpec(..),+  HasReportSpec(..),+  SortField(..),+  SortSpec,+  sortKeysDescription,+  overEither,+  setEither,+  BalanceCalculation(..),+  BalanceAccumulation(..),+  AccountListMode(..),+  ValuationType(..),+  Layout(..),+  defreportopts,+  rawOptsToReportOpts,+  defreportspec,+  defsortspec,+  setDefaultConversionOp,+  reportOptsToSpec,+  updateReportSpec,+  updateReportSpecWith,+  rawOptsToReportSpec,+  balanceAccumulationOverride,+  flat_,+  tree_,+  reportOptsToggleStatus,+  simplifyStatuses,+  whichDate,+  journalValueAndFilterPostings,+  journalValueAndFilterPostingsWith,+  journalApplyValuationFromOpts,+  journalApplyValuationFromOptsWith,+  mixedAmountApplyValuationAfterSumFromOptsWith,+  valuationAfterSum,+  requiresHistorical,+  intervalFromRawOpts,+  queryFromFlags,+  transactionDateFn,+  postingDateFn,+  reportSpan,+  reportSpanBothDates,+  reportStartDate,+  reportEndDate,+  reportPeriodStart,+  reportPeriodOrJournalStart,+  reportPeriodLastDay,+  reportPeriodOrJournalLastDay,+  reportPeriodName+)+where++import Prelude hiding (Applicative(..))+import Control.Applicative (Applicative(..), Const(..), (<|>))+import Control.Monad (guard, join)+import Data.Char (toLower)+import Data.Either (fromRight)+import Data.Either.Extra (eitherToMaybe)+import Data.Functor.Identity (Identity(..))+import Data.List (partition)+import Data.List.Extra (find, isPrefixOf, nubSort, stripPrefix)+import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)+import Data.Text qualified as T+import Data.Time.Calendar (Day, addDays)+import Data.Default (Default(..))+import Safe (lastDef, lastMay, maximumMay, readMay)++import Hledger.Data+import Hledger.Query+import Hledger.Utils+import Data.Function ((&))++-- | What to calculate for each cell in a balance report.+-- "Balance report types -> Calculation type" in the hledger manual.+data BalanceCalculation =+    CalcChange        -- ^ Sum of posting amounts in the period.+  | CalcBudget        -- ^ Sum of posting amounts and the goal for the period.+  | CalcValueChange   -- ^ Change from previous period's historical end value to this period's historical end value.+  | CalcGain          -- ^ Change from previous period's gain, i.e. valuation minus cost basis.+  | CalcPostingsCount -- ^ Number of postings in the period.+  deriving (Eq, Show)++instance Default BalanceCalculation where def = CalcChange++-- | How to accumulate calculated values across periods (columns) in a balance report.+-- "Balance report types -> Accumulation type" in the hledger manual.+data BalanceAccumulation =+    PerPeriod   -- ^ No accumulation. Eg, shows the change of balance in each period.+  | Cumulative  -- ^ Accumulate changes across periods, starting from zero at report start.+  | Historical  -- ^ Accumulate changes across periods, including any from before report start.+                --   Eg, shows the historical end balance of each period.+  deriving (Eq,Show)++instance Default BalanceAccumulation where def = PerPeriod++-- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ?+data AccountListMode = ALFlat | ALTree deriving (Eq, Show)++instance Default AccountListMode where def = ALFlat++data Layout = LayoutWide (Maybe Int)+            | LayoutTall+            | LayoutBare+            | LayoutTidy+  deriving (Eq, Show)++-- | Standard options for customising report filtering and output.+-- Most of these correspond to standard hledger command-line options+-- or query arguments, but not all. Some are used only by certain+-- commands, as noted below.+data ReportOpts = ReportOpts {+     -- for most reports:+     period_           :: Period+    ,interval_         :: Interval+    ,statuses_         :: [Status]  -- ^ Zero, one, or two statuses to be matched+    ,conversionop_     :: Maybe ConversionOp  -- ^ Which operation should we apply to conversion transactions?+    ,value_            :: Maybe ValuationType  -- ^ What value should amounts be converted to ?+    ,infer_prices_     :: Bool      -- ^ Infer market prices from transactions ?+    ,depth_            :: DepthSpec+    ,date2_            :: Bool+    ,empty_            :: Bool+    ,no_elide_         :: Bool+    ,real_             :: Bool+    ,format_           :: StringFormat+    ,balance_base_url_ :: Maybe T.Text+    ,pretty_           :: Bool+    ,querystring_      :: [T.Text]+    --+    ,average_          :: Bool+    -- for posting reports (register)+    ,related_          :: Bool+    -- for sorting reports (register)+    ,sortspec_             :: SortSpec+    -- for account transactions reports (aregister)+    ,txn_dates_        :: Bool+    -- for balance reports (bal, bs, cf, is)+    ,balancecalc_      :: BalanceCalculation  -- ^ What to calculate in balance report cells+    ,balanceaccum_     :: BalanceAccumulation -- ^ How to accumulate balance report values over time+    ,budgetpat_        :: Maybe T.Text  -- ^ A case-insensitive description substring+                                        --   to select periodic transactions for budget reports.+                                        --   (Not a regexp, nor a full hledger query, for now.)+    ,accountlistmode_  :: AccountListMode+    ,drop_             :: Int+    ,declared_         :: Bool  -- ^ Include accounts declared but not yet posted to ?+    ,row_total_        :: Bool+    ,no_total_         :: Bool+    ,summary_only_     :: Bool+    ,show_costs_       :: Bool  -- ^ Show costs for reports which normally don't show them ?+    ,sort_amount_      :: Bool+    ,percent_          :: Bool+    ,invert_           :: Bool  -- ^ Flip all amount signs in reports ?+    ,normalbalance_    :: Maybe NormalSign+      -- ^ This can be set when running balance reports on a set of accounts+      --   with the same normal balance type (eg all assets, or all incomes).+      -- - It helps --sort-amount know how to sort negative numbers+      --   (eg in the income section of an income statement)+      -- - It helps compound balance report commands (is, bs etc.) do+      --   sign normalisation, converting normally negative subreports to+      --   normally positive for a more conventional display.+    ,color_            :: Bool+      -- ^ Whether to use ANSI color codes in text output.+      --   Influenced by the --color/colour flag (cf CliOptions),+      --   whether stdout is an interactive terminal, and the value of+      --   TERM and existence of NO_COLOR environment variables.+    ,transpose_        :: Bool+    ,layout_           :: Layout+ } deriving (Show)++instance Default ReportOpts where def = defreportopts++defreportopts :: ReportOpts+defreportopts = ReportOpts+    { period_           = PeriodAll+    , interval_         = NoInterval+    , statuses_         = []+    , conversionop_     = Nothing+    , value_            = Nothing+    , infer_prices_     = False+    , depth_            = DepthSpec Nothing []+    , date2_            = False+    , empty_            = False+    , no_elide_         = False+    , real_             = False+    , format_           = def+    , balance_base_url_ = Nothing+    , pretty_           = False+    , querystring_      = []+    , average_          = False+    , related_          = False+    , sortspec_         = defsortspec +    , txn_dates_        = False+    , balancecalc_      = def+    , balanceaccum_     = def+    , budgetpat_        = Nothing+    , accountlistmode_  = ALFlat+    , drop_             = 0+    , declared_         = False+    , row_total_        = False+    , no_total_         = False+    , summary_only_     = False+    , show_costs_       = False+    , sort_amount_      = False+    , percent_          = False+    , invert_           = False+    , normalbalance_    = Nothing+    , color_            = False+    , transpose_        = False+    , layout_           = LayoutWide Nothing+    }++-- | Generate a ReportOpts from raw command-line input, given a day and whether to use ANSI colour/styles in standard output.+-- This will fail with a usage error if it is passed+-- - an invalid --format argument,+-- - an invalid --value argument,+-- - if --valuechange is called with a valuation type other than -V/--value=end.+-- - an invalid --pretty argument,+rawOptsToReportOpts :: Day -> Bool -> RawOpts -> ReportOpts+rawOptsToReportOpts d usecoloronstdout rawopts =++    let formatstring = T.pack <$> maybestringopt "format" rawopts+        querystring  = map T.pack $ listofstringopt "args" rawopts  -- doesn't handle an arg like "" right+        pretty = fromMaybe False $ ynopt "pretty" rawopts++        format = case parseStringFormat <$> formatstring of+            Nothing         -> defaultBalanceLineFormat+            Just (Right x)  -> x+            Just (Left err) -> usageError $ "could not parse format option: " ++ err++    in defreportopts+          {period_           = periodFromRawOpts d rawopts+          ,interval_         = intervalFromRawOpts rawopts+          ,statuses_         = statusesFromRawOpts rawopts+          ,conversionop_     = conversionOpFromRawOpts rawopts+          ,value_            = valuationTypeFromRawOpts rawopts+          ,infer_prices_     = boolopt "infer-market-prices" rawopts+          ,depth_            = depthFromRawOpts rawopts+          ,date2_            = boolopt "date2" rawopts+          ,empty_            = boolopt "empty" rawopts+          ,no_elide_         = boolopt "no-elide" rawopts+          ,real_             = boolopt "real" rawopts+          ,format_           = format+          ,balance_base_url_ = T.pack <$> maybestringopt "base-url" rawopts+          ,querystring_      = querystring+          ,average_          = boolopt "average" rawopts+          ,related_          = boolopt "related" rawopts+          ,sortspec_         = getSortSpec rawopts+          ,txn_dates_        = boolopt "txn-dates" rawopts+          ,balancecalc_      = balancecalcopt rawopts+          ,balanceaccum_     = balanceaccumopt rawopts+          ,budgetpat_        = maybebudgetpatternopt rawopts+          ,accountlistmode_  = accountlistmodeopt rawopts+          ,drop_             = posintopt "drop" rawopts+          ,declared_         = boolopt "declared" rawopts+          ,row_total_        = boolopt "row-total" rawopts+          ,no_total_         = boolopt "no-total" rawopts+          ,summary_only_     = boolopt "summary-only" rawopts+          ,show_costs_       = boolopt "show-costs" rawopts+          ,sort_amount_      = boolopt "sort-amount" rawopts+          ,percent_          = boolopt "percent" rawopts+          ,invert_           = boolopt "invert" rawopts+          ,pretty_           = pretty+          ,color_            = usecoloronstdout+          ,transpose_        = boolopt "transpose" rawopts+          ,layout_           = layoutopt rawopts+          }++-- | A fully-determined set of report parameters +-- (report options with all partial values made total, eg the begin and end+-- dates are known, avoiding date/regex errors; plus the reporting date),+-- and the query successfully calculated from them.+--+-- If you change the report options or date in one of these, you should+-- use `reportOptsToSpec` to regenerate the whole thing, avoiding inconsistency.+--+data ReportSpec = ReportSpec+  { _rsReportOpts :: ReportOpts  -- ^ The underlying ReportOpts used to generate this ReportSpec+  , _rsDay        :: Day         -- ^ The Day this ReportSpec is generated for+  , _rsQuery      :: Query       -- ^ The generated Query for the given day+  , _rsQueryOpts  :: [QueryOpt]  -- ^ A list of QueryOpts for the given day+  } deriving (Show)++instance Default ReportSpec where def = defreportspec++defreportspec :: ReportSpec+defreportspec = ReportSpec+    { _rsReportOpts = def+    , _rsDay        = nulldate+    , _rsQuery      = Any+    , _rsQueryOpts  = []+    }++-- | Set the default ConversionOp.+setDefaultConversionOp :: ConversionOp -> ReportSpec -> ReportSpec+setDefaultConversionOp defop rspec@ReportSpec{_rsReportOpts=ropts} =+    rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just defop}}++accountlistmodeopt :: RawOpts -> AccountListMode+accountlistmodeopt =+  fromMaybe ALFlat . choiceopt parse where+    parse = \case+      "tree" -> Just ALTree+      "flat" -> Just ALFlat+      _      -> Nothing++-- Get the argument of the --budget option if any, or the empty string.+maybebudgetpatternopt :: RawOpts -> Maybe T.Text+maybebudgetpatternopt = fmap T.pack . maybestringopt "budget"++balancecalcopt :: RawOpts -> BalanceCalculation+balancecalcopt =+  fromMaybe CalcChange . choiceopt parse where+    parse = \case+      "sum"         -> Just CalcChange+      "valuechange" -> Just CalcValueChange+      "gain"        -> Just CalcGain+      "budget"      -> Just CalcBudget+      "count"       -> Just CalcPostingsCount+      _             -> Nothing++balanceaccumopt :: RawOpts -> BalanceAccumulation+balanceaccumopt = fromMaybe PerPeriod . balanceAccumulationOverride++ynopt :: String -> RawOpts -> Maybe Bool+ynopt opt rawopts = case maybestringopt opt rawopts of+    Just "always" -> Just True+    Just "yes"    -> Just True+    Just "y"      -> Just True+    Just "never"  -> Just False+    Just "no"     -> Just False+    Just "n"      -> Just False+    Just _        -> usageError "this argument should be one of y, yes, n, no"+    _             -> Nothing++balanceAccumulationOverride :: RawOpts -> Maybe BalanceAccumulation+balanceAccumulationOverride rawopts = choiceopt parse rawopts <|> reportbal+  where+    parse = \case+      "historical" -> Just Historical+      "cumulative" -> Just Cumulative+      "change"     -> Just PerPeriod+      _            -> Nothing+    reportbal = case balancecalcopt rawopts of+      CalcValueChange -> Just PerPeriod+      _               -> Nothing++layoutopt :: RawOpts -> Layout+layoutopt rawopts = fromMaybe (LayoutWide Nothing) $ layout <|> column+  where+    layout = parse <$> maybestringopt "layout" rawopts+    column = LayoutBare <$ guard (boolopt "commodity-column" rawopts)++    parse opt = maybe err snd $ guard (not $ null s) *> find (isPrefixOf s . fst) checkNames+      where+        checkNames = [ ("wide", LayoutWide w)+                     , ("tall", LayoutTall)+                     , ("bare", LayoutBare)+                     , ("tidy", LayoutTidy)+                     ]+        -- For `--layout=elided,n`, elide to the given width+        (s,n) = break (==',') $ map toLower opt+        w = case drop 1 n of+              "" -> Nothing+              c | Just w' <- readMay c -> Just w'+              _ -> usageError "width in --layout=wide,WIDTH must be an integer"++        err = usageError "--layout's argument should be \"wide[,WIDTH]\", \"tall\", \"bare\", or \"tidy\""++-- Get the period specified by any -b/--begin, -e/--end and/or -p/--period+-- options appearing in the command line.+-- Its bounds are the rightmost begin date specified by a -b or -p, and+-- the rightmost end date specified by a -e or -p. Cf #1011.+-- Today's date is provided to help interpret any relative dates.+periodFromRawOpts :: Day -> RawOpts -> Period+periodFromRawOpts d rawopts =+  case (mlastb, mlaste) of+    (Nothing, Nothing) -> PeriodAll+    (Just b, Nothing)  -> PeriodFrom b+    (Nothing, Just e)  -> PeriodTo e+    (Just b, Just e)   -> simplifyPeriod $ PeriodBetween b e+  where+    mlastb = case beginDatesFromRawOpts d rawopts of+                   [] -> Nothing+                   bs -> Just $ fromEFDay $ last bs+    mlaste = case endDatesFromRawOpts d rawopts of+                   [] -> Nothing+                   es -> Just $ fromEFDay $ last es++-- Get all begin dates specified by -b/--begin or -p/--period options, in order,+-- using the given date to interpret relative date expressions.+beginDatesFromRawOpts :: Day -> RawOpts -> [EFDay]+beginDatesFromRawOpts d = collectopts (begindatefromrawopt d)+  where+    begindatefromrawopt d' (n,v)+      | n == "begin" =+          either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $+          fixSmartDateStrEither' d' (T.pack v)+      | n == "period" =+        case+          either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $+          parsePeriodExpr d' (stripquotes $ T.pack v)+        of+          (_, DateSpan (Just b) _) -> Just b+          _                        -> Nothing+      | otherwise = Nothing++-- Get all end dates specified by -e/--end or -p/--period options, in order,+-- using the given date to interpret relative date expressions.+endDatesFromRawOpts :: Day -> RawOpts -> [EFDay]+endDatesFromRawOpts d = collectopts (enddatefromrawopt d)+  where+    enddatefromrawopt d' (n,v)+      | n == "end" =+          either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $+          fixSmartDateStrEither' d' (T.pack v)+      | n == "period" =+        case+          either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $+          parsePeriodExpr d' (stripquotes $ T.pack v)+        of+          (_, DateSpan _ (Just e)) -> Just e+          _                        -> Nothing+      | otherwise = Nothing++-- | Get the report interval, if any, specified by the last of -p/--period,+-- -D/--daily, -W/--weekly, -M/--monthly etc. options.+-- An interval from --period counts only if it is explicitly defined.+intervalFromRawOpts :: RawOpts -> Interval+intervalFromRawOpts = lastDef NoInterval . collectopts intervalfromrawopt+  where+    intervalfromrawopt (n,v)+      | n == "period" =+          either+            (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e)+            extractIntervalOrNothing $+            parsePeriodExpr+              (error' "intervalFromRawOpts: did not expect to need today's date here")  -- PARTIAL: should not happen; we are just getting the interval, which does not use the reference date+              (stripquotes $ T.pack v)+      | n == "daily"     = Just $ Days 1+      | n == "weekly"    = Just $ Weeks 1+      | n == "monthly"   = Just $ Months 1+      | n == "quarterly" = Just $ Quarters 1+      | n == "yearly"    = Just $ Years 1+      | otherwise = Nothing++-- | Extract the interval from the parsed -p/--period expression.+-- Return Nothing if an interval is not explicitly defined.+extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval+extractIntervalOrNothing (NoInterval, _) = Nothing+extractIntervalOrNothing (interval, _) = Just interval++-- | Get the last interval specified in query opts, if any.+-- date: queries can specify a reporting interval.+intervalFromQueryOpts :: [QueryOpt] -> Maybe Interval+intervalFromQueryOpts = lastMay . mapMaybe getInterval+  where+    getInterval (QueryOptInterval i) = Just i+    getInterval _ = Nothing++-- | Get any statuses to be matched, as specified by -U/--unmarked,+-- -P/--pending, -C/--cleared flags. -UPC is equivalent to no flags,+-- so this returns a list of 0-2 unique statuses.+statusesFromRawOpts :: RawOpts -> [Status]+statusesFromRawOpts = simplifyStatuses . collectopts statusfromrawopt+  where+    statusfromrawopt (n,_)+      | n == "unmarked"  = Just Unmarked+      | n == "pending"   = Just Pending+      | n == "cleared"   = Just Cleared+      | otherwise        = Nothing++-- | Reduce a list of statuses to just one of each status,+-- and if all statuses are present return the empty list.+simplifyStatuses l+  | length l' >= numstatuses = []+  | otherwise                = l'+  where+    l' = nubSort l+    numstatuses = length [minBound .. maxBound :: Status]++-- | Add/remove this status from the status list. Used by hledger-ui.+reportOptsToggleStatus s ropts@ReportOpts{statuses_=ss}+  | s `elem` ss = ropts{statuses_=filter (/= s) ss}+  | otherwise   = ropts{statuses_=simplifyStatuses (s:ss)}++-- | Parse the type of valuation to be performed, if any, specified by -V,+-- -X/--exchange, or --value flags. If there's more than one valuation type,+-- the rightmost flag wins. This will fail with a usage error if an invalid+-- argument is passed to --value, or if --valuechange is called with a+-- valuation type other than -V/--value=end.+valuationTypeFromRawOpts :: RawOpts -> Maybe ValuationType+valuationTypeFromRawOpts rawopts = case (balancecalcopt rawopts, directval) of+    (CalcValueChange, Nothing       ) -> Just $ AtEnd Nothing  -- If no valuation requested for valuechange, use AtEnd+    (CalcValueChange, Just (AtEnd _)) -> directval             -- If AtEnd valuation requested, use it+    (CalcValueChange, _             ) -> usageError "--valuechange only produces sensible results with --value=end"+    (CalcGain,        Nothing       ) -> Just $ AtEnd Nothing  -- If no valuation requested for gain, use AtEnd+    (_,               _             ) -> directval             -- Otherwise, use requested valuation+  where+    directval = lastMay $ collectopts valuationfromrawopt rawopts+    valuationfromrawopt (n,v)  -- option name, value+      | n == "V"     = Just $ AtEnd Nothing+      | n == "X"     = Just $ AtEnd (Just $ T.pack v)+      | n == "value" = valueopt v+      | otherwise    = Nothing+    valueopt v+      | t `elem` ["cost","c"]  = AtEnd . Just <$> mc  -- keep supporting --value=cost,COMM for now+      | t `elem` ["then" ,"t"] = Just $ AtThen mc+      | t `elem` ["end" ,"e"]  = Just $ AtEnd  mc+      | t `elem` ["now" ,"n"]  = Just $ AtNow  mc+      | otherwise = case parsedate t of+            Just d  -> Just $ AtDate d mc+            Nothing -> usageError $ "could not parse \""++t++"\" as valuation type, should be: then|end|now|t|e|n|YYYY-MM-DD"+      where+        -- parse --value's value: TYPE[,COMM]+        (t,c') = break (==',') v+        mc     = case drop 1 c' of+                   "" -> Nothing+                   c  -> Just $ T.pack c++-- | Parse the type of costing to be performed, if any, specified by -B/--cost+-- or --value flags. If there's more than one costing type, the rightmost flag+-- wins. This will fail with a usage error if an invalid argument is passed to+-- --cost or if a costing type is requested with --gain.+conversionOpFromRawOpts :: RawOpts -> Maybe ConversionOp+conversionOpFromRawOpts rawopts+    | isJust costFlag && balancecalcopt rawopts == CalcGain = usageError "--gain cannot be combined with --cost"+    | otherwise = costFlag+  where+    costFlag = lastMay $ collectopts conversionopfromrawopt rawopts+    conversionopfromrawopt (n,v)  -- option name, value+      | n == "B"                                    = Just ToCost+      | n == "value", takeWhile (/=',') v `elem` ["cost", "c"] = Just ToCost  -- keep supporting --value=cost for now+      | otherwise                                   = Nothing++-- | Parse the depth arguments. This can be either a flat depth that applies to+-- all accounts, or a regular expression and depth, which only matches certain+-- accounts. If an account name is matched by a regular expression, then the+-- smallest depth is used. Otherwise, if no regular expressions match, then the+-- flat depth is used. If more than one flat depth is supplied, use only the+-- last one.+depthFromRawOpts :: RawOpts -> DepthSpec+depthFromRawOpts rawopts = lastDef mempty flats <> mconcat regexps+  where+    (flats, regexps) = partition (\(DepthSpec f rs) -> isJust f && null rs) depthSpecs+    depthSpecs = case mapM (parseDepthSpec . T.pack) depths of+      Right d -> d+      Left err -> usageError $ "Unable to parse depth specification: " ++ err+    depths = listofstringopt "depth" rawopts++-- | Select the Transaction date accessor based on --date2.+transactionDateFn :: ReportOpts -> (Transaction -> Day)+transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate++-- | Select the Posting date accessor based on --date2.+postingDateFn :: ReportOpts -> (Posting -> Day)+postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate++-- | Report which date we will report on based on --date2.+whichDate :: ReportOpts -> WhichDate+whichDate ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate++-- | Legacy-compatible convenience aliases for accountlistmode_.+tree_ :: ReportOpts -> Bool+tree_ ReportOpts{accountlistmode_ = ALTree} = True+tree_ ReportOpts{accountlistmode_ = ALFlat} = False++flat_ :: ReportOpts -> Bool+flat_ = not . tree_++-- depthFromOpts :: ReportOpts -> Int+-- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts)++-- | Convert a 'Journal''s amounts to cost and/or to value (see+-- 'journalApplyValuationFromOpts'), and filter by the 'ReportSpec' 'Query'.+--+-- We make sure to first filter by amt: and cur: terms, then value the+-- 'Journal', then filter by the remaining terms.+journalValueAndFilterPostings :: ReportSpec -> Journal -> Journal+journalValueAndFilterPostings rspec j =+  -- dbg4With (\j2 -> "valuedfilteredj" <> pshow (jtxns j2)) $+  journalValueAndFilterPostingsWith rspec j priceoracle+  where priceoracle = journalPriceOracle (infer_prices_ $ _rsReportOpts rspec) j++{- [Querying before valuation]+This helper is used by multiBalanceReport (all balance reports).+Previously, at least since #1625 (2021), it was filtering with the cur:/amt: parts+of the query before valuation, and with the other parts after valuation.+Now, since #2387 (2025), it does all filtering before valuation.+This avoids breaking boolean queries (#2371), avoids a strictness bug (#2385),+is simpler, and we think it's otherwise equivalent.+-}+-- | Like 'journalValueAndFilterPostings', but takes a 'PriceOracle' as an argument.+journalValueAndFilterPostingsWith :: ReportSpec -> Journal -> PriceOracle -> Journal+journalValueAndFilterPostingsWith = _journalValueAndFilterPostingsWith1431++-- 1.42+-- #2371 This goes wrong with complex boolean queries, splitting them apart in a lossy way.+-- _journalValueAndFilterPostingsWith142 rspec@ReportSpec{_rsQuery=q, _rsReportOpts=ropts} j =+--     -- Third, filter by the non amt:/cur: parts of the query+--       filterJournalPostings' reportq+--     -- Second, apply valuation and costing+--     . journalApplyValuationFromOptsWith rspec+--     -- First, filter by the amt:/cur: parts of the query, so they match pre-valuation amounts+--       (if queryIsNull amtsymq then j else filterJournalAmounts amtsymq j)+--   where+--     -- with -r, replace each posting with its sibling postings+--     filterJournalPostings' = if related_ ropts then filterJournalRelatedPostings else filterJournalPostings+--     amtsymq = dbg1 "amtsymq" $ filterQuery queryIsAmtOrSym q+--     reportq = dbg1 "reportq" $ filterQuery (not . queryIsAmtOrSym) q++-- 1.43+-- XXX #2396 This goes wrong with cur:. filterJournal*Postings keep all postings containing the matched commodity,+-- but do not remove the unmatched commodities from multicommodity postings, as filterJournalAmounts would.+-- _journalValueAndFilterPostingsWith143 rspec@ReportSpec{_rsQuery = q, _rsReportOpts = ropts} =+--   journalApplyValuationFromOptsWith rspec .+--   dbg1With (\j1 -> "j1" <> pshow (jtxns j1)) .+--   (if related_ ropts then filterJournalRelatedPostings else filterJournalPostings) q++-- 1.43.1+_journalValueAndFilterPostingsWith1431 rspec@ReportSpec{_rsQuery = q, _rsReportOpts = ropts} =+  journalApplyValuationFromOptsWith rspec . filterjournal q+  where+    filterjournal q2 =+      filterJournalAmounts (filterQuery queryIsAmtOrSym q2) .  -- an extra amount filtering pass for #2396+      (if related_ ropts then filterJournalRelatedPostings q2 else filterJournalPostings q2)++-- | Convert this journal's postings' amounts to cost and/or to value, if specified+-- by options (-B/--cost/-V/-X/--value etc.). Strip prices if not needed. This+-- should be the main stop for performing costing and valuation. The exception is+-- whenever you need to perform valuation _after_ summing up amounts, as in a+-- historical balance report with --value=end. valuationAfterSum will check for this+-- condition.+journalApplyValuationFromOpts :: ReportSpec -> Journal -> Journal+journalApplyValuationFromOpts rspec j =+  journalApplyValuationFromOptsWith rspec j priceoracle+  where priceoracle = journalPriceOracle (infer_prices_ $ _rsReportOpts rspec) j++-- | Like journalApplyValuationFromOpts, but takes PriceOracle as an argument.+journalApplyValuationFromOptsWith :: ReportSpec -> Journal -> PriceOracle -> Journal+journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle =+  costfn j+  & journalMapPostings (\p -> p+    & dbg9With (lbl "before calc".showMixedAmountOneLine.pamount)+    & postingTransformAmount (calcfn p)+    & dbg9With (lbl (show calc).showMixedAmountOneLine.pamount)+    )+  where+    lbl = lbl_ "journalApplyValuationFromOptsWith"+    -- Which custom calculation to do for balance reports. For all other reports, it will be CalcChange.+    calc = balancecalc_ ropts+    calcfn = case calc of+      CalcGain -> \p -> maybe id (mixedAmountApplyGain      priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts)+      _        -> \p -> maybe id (mixedAmountApplyValuation priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts)+    costfn = case calc of+      CalcGain -> id+      _        -> journalToCost costop where costop = fromMaybe NoConversionOp $ conversionop_ ropts++    -- Find the "end" valuation date for this posting.+    -- With a report interval, this is the last day of the report subperiod containing this posting;+    -- with no interval it's the last date of the overall report period+    -- (which for an end value report may have been extended to include the latest non-future P directive).+    -- To get the period's last day, we subtract one from the (exclusive) period end date.+    postingperiodend = postingPeriodEnd . postingDateOrDate2 (whichDate ropts)+      where+        postingPeriodEnd d = fromMaybe err $ case interval_ ropts of+          NoInterval -> fmap (snd . dayPartitionStartEnd)    . snd $ reportSpan j rspec+          _          -> fmap (snd . dayPartitionFind d) . snd $ reportSpanBothDates j rspec+        -- Should never happen, because there are only invalid dayPartitions+        -- when there are no transactions, in which case this function is never called+        err = error' "journalApplyValuationFromOpts: expected all spans to have an end date"+++    styles = journalCommodityStyles j++-- | Select the Account valuation functions required for performing valuation after summing+-- amounts. Used in MultiBalanceReport to value historical and similar reports.+mixedAmountApplyValuationAfterSumFromOptsWith :: ReportOpts -> Journal -> PriceOracle+                                              -> (Day -> MixedAmount -> MixedAmount)+mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle =+    case valuationAfterSum ropts of+        Just mc -> case balancecalc_ ropts of+            CalcGain -> gain mc+            _        -> \d -> valuation mc d . costing+        Nothing      -> const id+  where+    valuation mc d = mixedAmountValueAtDate priceoracle styles mc d+    gain mc d = mixedAmountGainAtDate priceoracle styles mc d+    costing = case fromMaybe NoConversionOp $ conversionop_ ropts of+        NoConversionOp -> id+        ToCost         -> styleAmounts styles . mixedAmountCost+    styles = journalCommodityStyles j++-- | If the ReportOpts specify that we are performing valuation after summing amounts,+-- return Just of the commodity symbol we're converting to, Just Nothing for the default,+-- and otherwise return Nothing.+-- Used for example with historical reports with --value=end.+valuationAfterSum :: ReportOpts -> Maybe (Maybe CommoditySymbol)+valuationAfterSum ropts = case value_ ropts of+    Just (AtEnd mc) | requiresHistorical ropts -> Just mc+    _                                          -> Nothing++-- | If the ReportOpts specify that we will need to consider historical+-- postings, either because this is a historical report, or because the+-- valuation strategy requires historical amounts.+requiresHistorical :: ReportOpts -> Bool+requiresHistorical ReportOpts{balanceaccum_ = accum, balancecalc_ = calc} =+    accum == Historical || calc == CalcValueChange || calc == CalcGain++-- | Convert report options to a query, ignoring any non-flag command line arguments.+queryFromFlags :: ReportOpts -> Query+queryFromFlags ReportOpts{..} = simplifyQuery $ And flagsq+  where+    flagsq = consIf   Real  real_+           . consJust Depth flatDepth+           $ map (uncurry DepthAcct) regexpDepths+           ++  [ (if date2_ then Date2 else Date) $ periodAsDateSpan period_+               , Or $ map StatusQ statuses_+               ]+    consIf f b = if b then (f True:) else id+    DepthSpec flatDepth regexpDepths = depth_+    consJust f = maybe id ((:) . f)++-- Methods/types needed for --sort argument++-- Possible arguments taken by the --sort command+-- Each of these takes a bool, which shows if it has been inverted+-- (True -> has been inverted, reverse the order)+data SortField+    = AbsAmount' Bool+    | Account' Bool+    | Amount' Bool+    | Date' Bool+    | Description' Bool+    deriving (Show, Eq)+type SortSpec = [SortField]++-- By default, sort by date in ascending order+defsortspec :: SortSpec+defsortspec = [Date' False]++-- Load a SortSpec from the argument given to --sort+-- If there is no spec given, then sort by [Date' False] by default+getSortSpec :: RawOpts -> SortSpec+getSortSpec opts = +    let opt = maybestringopt "sort" opts+        optParser s = +          let terms = map strip $ splitAtElement ',' s +              termParser t = case trimmed of+                "date"        -> Date'        isNegated+                "desc"        -> Description' isNegated+                "description" -> Description' isNegated+                "account"     -> Account'     isNegated+                "amount"      -> Amount'      isNegated+                "absamount"   -> AbsAmount'   isNegated+                _ -> error' $ "unknown --sort key " ++ t ++ ". Supported keys are: " <> sortKeysDescription <> "."+                where isNegated = isPrefixOf "-" t+                      trimmed = fromMaybe t (stripPrefix "-" t)+          in map termParser terms+    in maybe defsortspec optParser opt ++-- for option's help and parse error message+sortKeysDescription = "date, desc, account, amount, absamount"  -- 'description' is also accepted++-- Report dates.++-- | The effective report span is the start and end dates requested by options or queries.+-- If the start date is unspecified, the earliest transaction or posting date is used.+-- If the end date is unspecified, the latest transaction or posting date+-- (or non-future market price date, when doing an end value report) is used.+-- If none of these things are present, the null date span is returned.+-- The report sub-periods caused by a report interval, if any, are also returned.+reportSpan :: Journal -> ReportSpec -> (DateSpan, Maybe DayPartition)+reportSpan = reportSpanHelper False+-- Note: In end value reports, the report end date and valuation date are the same.+-- If valuation date ever needs to be different, journalApplyValuationFromOptsWith is the place.++-- | Like reportSpan, but considers both primary and secondary dates, not just one or the other.+reportSpanBothDates :: Journal -> ReportSpec -> (DateSpan, Maybe DayPartition)+reportSpanBothDates = reportSpanHelper True++reportSpanHelper :: Bool -> Journal -> ReportSpec -> (DateSpan, Maybe DayPartition)+reportSpanHelper bothdates j ReportSpec{_rsQuery=query, _rsReportOpts=ropts, _rsDay=today} =+    (enlargedreportspan, intervalspans)+  where+    -- The date span specified by -b/-e/-p options and query args if any.+    requestedspan = dbg3 "requestedspan" $+      if bothdates then queryDateSpan' query else queryDateSpan (date2_ ropts) query++    -- If the requested span has open ends, fill them with defaults.+    reportspan = dbg3 "reportspan" $ requestedspan `spanValidDefaultsFrom` txnsorpricespan+      where+        txnsorpricespan = dbg3 "txnsorpricespan" $ DateSpan mfirsttxn mlatesttxnorprice+          where+            DateSpan mfirsttxn mlasttxn = dbg3 "txnsspan" $+              if bothdates then journalDateSpanBothDates j else journalDateSpan (date2_ ropts) j+            mlatesttxnorprice =+              case value_ ropts of+                Just (AtEnd _) -> mlasttxn `max` mlatestnonfutureprice+                _              -> mlasttxn+              where+                mlatestnonfutureprice = dbg3 "latestnonfutureprice" $ -- #2445+                  fmap (Exact . addDays 1) . maximumMay . filter (not . (> today)) . map pddate $ jpricedirectives j++    -- The list of interval spans enclosing the requested span.+    -- This list can be empty if the journal was empty,+    -- or if hledger-ui has added its special date:-tomorrow to the query+    -- and all txns are in the future.+    intervalspans = dbg3 "intervalspans" $ splitSpan adjust (interval_ ropts) reportspan+      where+        -- When calculating report periods, we will adjust the start date back to the nearest interval boundary+        -- unless a start date was specified explicitly.+        adjust = isNothing $ spanStart requestedspan++    -- The requested span enlarged to enclose a whole number of intervals.+    -- This can be the null span if there were no intervals.+    enlargedreportspan = dbg3 "enlargedreportspan" $+        maybe (DateSpan Nothing Nothing) (mkSpan . dayPartitionStartEnd) intervalspans+      where mkSpan (s, e) = DateSpan (Just $ Exact s) (Just . Exact $ addDays 1 e)++reportStartDate :: Journal -> ReportSpec -> Maybe Day+reportStartDate j = spanStart . fst . reportSpan j++reportEndDate :: Journal -> ReportSpec -> Maybe Day+reportEndDate j = spanEnd . fst . reportSpan j++-- Some pure alternatives to the above. XXX review/clean up++-- Get the report's start date.+-- If no report period is specified, will be Nothing.+reportPeriodStart :: ReportSpec -> Maybe Day+reportPeriodStart = queryStartDate False . _rsQuery++-- Get the report's start date, or if no report period is specified,+-- the journal's start date (the earliest posting date). If there's no+-- report period and nothing in the journal, will be Nothing.+reportPeriodOrJournalStart :: ReportSpec -> Journal -> Maybe Day+reportPeriodOrJournalStart rspec j =+  reportPeriodStart rspec <|> journalStartDate False j++-- Get the last day of the overall report period.+-- This the inclusive end date (one day before the+-- more commonly used, exclusive, report end date).+-- If no report period is specified, will be Nothing.+reportPeriodLastDay :: ReportSpec -> Maybe Day+reportPeriodLastDay = fmap (addDays (-1)) . queryEndDate False . _rsQuery++-- Get the last day of the overall report period, or if no report+-- period is specified, the last day of the journal (ie the latest+-- posting date). If we're doing period-end valuation, include price+-- directive dates. If there's no report period and nothing in the+-- journal, will be Nothing.+reportPeriodOrJournalLastDay :: ReportSpec -> Journal -> Maybe Day+reportPeriodOrJournalLastDay rspec j = reportPeriodLastDay rspec <|> journalOrPriceEnd+  where+    journalOrPriceEnd = case value_ $ _rsReportOpts rspec of+        Just (AtEnd _) -> max (journalLastDay False j) lastPriceDirective+        _              -> journalLastDay False j+    lastPriceDirective = fmap (addDays 1) . maximumMay . map pddate $ jpricedirectives j++-- | Make a name for the given period in a multiperiod report, given+-- the type of balance being reported and the full set of report+-- periods. This will be used as a column heading (or row heading, in+-- a register summary report). We try to pick a useful name as follows:+--+-- - ending-balance reports: the period's end date+--+-- - balance change reports where the periods are months and all in the same year:+--   the short month name in the current locale+--+-- - all other balance change reports: a description of the datespan,+--   abbreviated to compact form if possible (see showDateSpan).+reportPeriodName :: BalanceAccumulation -> [DateSpan] -> DateSpan -> T.Text+reportPeriodName balanceaccumulation spans =+  case balanceaccumulation of+    PerPeriod -> if multiyear then showDateSpan else showDateSpanAbbrev+      where+        multiyear = (>1) $ length $ nubSort $ map spanStartYear spans+    _ -> maybe "" (showDate . prevday) . spanEnd++-- lenses++-- Reportable functors are so that we can create special lenses which can fail+-- and report on their failure.+class Functor f => Reportable f e where+    report :: a -> f (Either e a) -> f a++instance Reportable (Const r) e where+    report _ (Const x) = Const x++instance Reportable Identity e where+    report a (Identity i) = Identity $ fromRight a i++instance Reportable Maybe e where+    report _ = (eitherToMaybe =<<)++instance (e ~ a) => Reportable (Either a) e where+    report _ = join++-- | Apply a function over a lens, but report on failure.+overEither :: ((a -> Either e b) -> s -> Either e t) -> (a -> b) -> s -> Either e t+overEither l f = l (pure . f)++-- | Set a field using a lens, but report on failure.+setEither :: ((a -> Either e b) -> s -> Either e t) -> b -> s -> Either e t+setEither l = overEither l . const++type ReportableLens' s a = forall f. Reportable f String => (a -> f a) -> s -> f s++-- | Lenses for ReportOpts.++-- Implement HasReportOptsNoUpdate, the basic lenses for ReportOpts.+makeHledgerClassyLenses ''ReportOpts+makeHledgerClassyLenses ''ReportSpec++-- | Special lenses for ReportOpts which also update the Query and QueryOpts in ReportSpec.+-- Note that these are not true lenses, as they have a further restriction on+-- the functor. This will work as a normal lens for all common uses, but since they+-- don't obey the lens laws for some fancy cases, they may fail in some exotic circumstances.+--+-- Note that setEither/overEither should only be necessary with+-- querystring and reportOpts: the other lenses should never fail.+--+-- === Examples:+-- >>> import Lens.Micro (set)+-- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec+-- Right (Acct (RegexpCI "assets"))+-- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec+-- Left "This regular expression is invalid or unsupported, please correct it:\n(assets"+-- >>> _rsQuery $ set querystring ["assets"] defreportspec+-- Acct (RegexpCI "assets")+-- >>> _rsQuery $ set period (MonthPeriod 2021 08) defreportspec+-- Date DateSpan 2021-08+--+-- XXX testing error output isn't working since adding color to it:+-- > import System.Environment+-- > setEnv "NO_COLOR" "1" >> return (_rsQuery $ set querystring ["(assets"] defreportspec)+-- *** Exception: Error: Updating ReportSpec failed: try using overEither instead of over or setEither instead of set+class HasReportOptsNoUpdate a => HasReportOpts a where+    reportOpts :: ReportableLens' a ReportOpts+    reportOpts = reportOptsNoUpdate+    {-# INLINE reportOpts #-}++    -- XXX these names are a bit clashy++    period :: ReportableLens' a Period+    period = reportOpts.periodNoUpdate+    {-# INLINE period #-}++    statuses :: ReportableLens' a [Status]+    statuses = reportOpts.statusesNoUpdate+    {-# INLINE statuses #-}++    depth :: ReportableLens' a DepthSpec+    depth = reportOpts.depthNoUpdate+    {-# INLINE depth #-}++    date2 :: ReportableLens' a Bool+    date2 = reportOpts.date2NoUpdate+    {-# INLINE date2 #-}++    real :: ReportableLens' a Bool+    real = reportOpts.realNoUpdate+    {-# INLINE real #-}++    querystring :: ReportableLens' a [T.Text]+    querystring = reportOpts.querystringNoUpdate+    {-# INLINE querystring #-}++instance HasReportOpts ReportOpts++instance HasReportOptsNoUpdate ReportSpec where+    reportOptsNoUpdate = rsReportOpts++instance HasReportOpts ReportSpec where+    reportOpts f rspec = report (error' "Updating ReportSpec failed: try using overEither instead of over or setEither instead of set") $  -- PARTIAL:+      reportOptsToSpec (_rsDay rspec) <$> f (_rsReportOpts rspec)+    {-# INLINE reportOpts #-}++-- | Generate a ReportSpec from a set of ReportOpts on a given day.+reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec+reportOptsToSpec day ropts = do+    (argsquery, queryopts) <- parseQueryList day $ querystring_ ropts+    -- If there's an interval in the query opts, it overrides the interval from -p/--period/etc+    let ropts' = case intervalFromQueryOpts queryopts of+                   Just i  -> ropts{interval_=i}+                   Nothing -> ropts+    return ReportSpec+      { _rsReportOpts = ropts'+      , _rsDay        = day+      , _rsQuery      = simplifyQuery $ And [queryFromFlags ropts', argsquery]+      , _rsQueryOpts  = queryopts+      }++-- | Update the ReportOpts and the fields derived from it in a ReportSpec,+-- or return an error message if there is a problem such as missing or+-- unparseable options data. This is the safe way to change a ReportSpec,+-- ensuring that all fields (_rsQuery, _rsReportOpts, querystring_, etc.) are in sync.+updateReportSpec :: ReportOpts -> ReportSpec -> Either String ReportSpec+updateReportSpec = setEither reportOpts++-- | Like updateReportSpec, but takes a ReportOpts-modifying function.+updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec+updateReportSpecWith = overEither reportOpts++-- | Generate a ReportSpec from RawOpts and a provided day, or return an error+-- string if there are regular expression errors.+rawOptsToReportSpec :: Day -> Bool -> RawOpts -> Either String ReportSpec+rawOptsToReportSpec day coloronstdout = reportOptsToSpec day . rawOptsToReportOpts day coloronstdout
Hledger/Reports/ReportTypes.hs view
@@ -1,12 +1,52 @@ {- | New common report types, used by the BudgetReport for now, perhaps all reports later. -}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}  module Hledger.Reports.ReportTypes-where+( PeriodicReport(..)+, PeriodicReportRow(..) -import Data.Decimal+, Percentage+, Change+, Balance+, Total+, Average++, periodicReportSpan+, prMapName+, prMapMaybeName++, CompoundPeriodicReport(..)+, CBCSubreportSpec(..)++, DisplayName(..)+, flatDisplayName+, treeDisplayName++, prrShowDebug+, prrFullName+, prrDisplayName+, prrIndent+, prrAdd+) where++import Data.Aeson (ToJSON(..))+import Data.Bifunctor (Bifunctor(..))+import Data.Decimal (Decimal)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import GHC.Generics (Generic)+ import Hledger.Data+import Hledger.Query (Query)+import Hledger.Reports.ReportOptions (ReportOpts)+import Data.Text qualified as T+import Data.List (intercalate)  type Percentage = Decimal @@ -15,26 +55,195 @@ type Total   = MixedAmount  -- ^ The sum of 'Change's in a report or a report row. Does not make sense for 'Balance's. type Average = MixedAmount  -- ^ The average of 'Change's or 'Balance's in a report or report row. --- | A generic tabular report of some value, where each row corresponds to an account--- and each column is a date period. The column periods are usually consecutive subperiods--- formed by splitting the overall report period by some report interval (daily, weekly, etc.)--- Depending on the value type, this can be a report of balance changes, ending balances,--- budget performance, etc. Successor to MultiBalanceReport.-data PeriodicReport a =+-- | A periodic report is a generic tabular report, where each row corresponds+-- to some label (usually an account name) and each column to a date period.+-- The column periods are usually consecutive subperiods formed by splitting+-- the overall report period by some report interval (daily, weekly, etc.).+-- It has:+--+-- 1. a list of each column's period (date span)+--+-- 2. a list of rows, each containing:+--+--   * an account label+--+--   * the account's depth+--+--   * A list of amounts, one for each column. Depending on the value type,+--     these can represent balance changes, ending balances, budget+--     performance, etc. (for example, see 'BalanceAccumulation' and+--     "Hledger.Cli.Commands.Balance").+--+--   * the total of the row's amounts for a periodic report,+--     or zero for cumulative/historical reports (since summing+--     end balances generally doesn't make sense).+--+--   * the average of the row's amounts+--+-- 3. the column totals, and the overall grand total (or zero for+-- cumulative/historical reports) and grand average.++data PeriodicReport a b =   PeriodicReport-    ( [DateSpan]            -- The subperiods formed by splitting the overall report period by the report interval.-                            -- For ending-balance reports, only the end date is significant.-                            -- Usually displayed as report columns.-    , [PeriodicReportRow a] -- One row per account in the report.-    , PeriodicReportRow a   -- The grand totals row. The account name in this row is always empty.-    )-   deriving (Show)+  { prDates  :: [DateSpan]               -- The subperiods formed by splitting the overall+                                         -- report period by the report interval. For+                                         -- ending-balance reports, only the end date is+                                         -- significant. Usually displayed as report columns.+  , prRows   :: [PeriodicReportRow a b]  -- One row per account in the report.+  , prTotals :: PeriodicReportRow () b   -- The grand totals row.+  } deriving (Show, Functor, Generic, ToJSON) -type PeriodicReportRow a =-  ( AccountName  -- A full account name.-  , AccountName  -- Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed.-  , Int          -- Indent level for displaying this account name in tree mode. 0, 1, 2... -  , [a]          -- The data value for each subperiod.-  , a            -- The total of this row's values.-  , a            -- The average of this row's values.-  )+instance Bifunctor PeriodicReport where+  bimap f g pr = pr{prRows = map (bimap f g) $ prRows pr, prTotals = g <$> prTotals pr}++instance HasAmounts b => HasAmounts (PeriodicReport a b) where+  styleAmounts styles r@PeriodicReport{prRows,prTotals} =+    r{prRows=styleAmounts styles prRows, prTotals=styleAmounts styles prTotals}++data PeriodicReportRow a b =+  PeriodicReportRow+  { prrName    :: a    -- An account name.+  , prrAmounts :: [b]  -- The data value for each subperiod.+  , prrTotal   :: b    -- The total of this row's values.+  , prrAverage :: b    -- The average of this row's values.+  } deriving (Show, Functor, Generic, ToJSON)++instance Bifunctor PeriodicReportRow where+  first f prr = prr{prrName = f $ prrName prr}+  second = fmap++instance Semigroup b => Semigroup (PeriodicReportRow a b) where+  (<>) = prrAdd++instance HasAmounts b => HasAmounts (PeriodicReportRow a b) where+  styleAmounts styles r =+    r{prrAmounts=styleAmounts styles $ prrAmounts r+     ,prrTotal  =styleAmounts styles $ prrTotal r+     ,prrAverage=styleAmounts styles $ prrAverage r+     }++prrShowDebug :: PeriodicReportRow DisplayName MixedAmount -> String+prrShowDebug (PeriodicReportRow dname amts _tot _avg) =+  unwords [+    T.unpack $ displayFull dname,+    "",+    intercalate " | " $ map showMixedAmount amts+    ]++-- | Add two 'PeriodicReportRows', preserving the name of the first.+prrAdd :: Semigroup b => PeriodicReportRow a b -> PeriodicReportRow a b -> PeriodicReportRow a b+prrAdd (PeriodicReportRow n1 amts1 t1 a1) (PeriodicReportRow _ amts2 t2 a2) =+    PeriodicReportRow n1 (zipWithPadded (<>) amts1 amts2) (t1 <> t2) (a1 <> a2)++-- | Version of 'zipWith' which will not end on the shortest list, but will copy the rest of the longer list.+zipWithPadded :: (a -> a -> a) -> [a] -> [a] -> [a]+zipWithPadded f (a:as) (b:bs) = f a b : zipWithPadded f as bs+zipWithPadded _ as     []     = as+zipWithPadded _ []     bs     = bs++-- | Figure out the overall date span of a PeriodicReport+periodicReportSpan :: PeriodicReport a b -> DateSpan+periodicReportSpan (PeriodicReport colspans _ _) =+  case colspans of+    []  -> DateSpan Nothing Nothing+    s:_ -> DateSpan (Exact <$> spanStart s) (Exact <$> spanEnd (last colspans))++-- | Map a function over the row names.+prMapName :: (a -> b) -> PeriodicReport a c -> PeriodicReport b c+prMapName f report = report{prRows = map (prrMapName f) $ prRows report}++-- | Map a function over the row names, possibly discarding some.+prMapMaybeName :: (a -> Maybe b) -> PeriodicReport a c -> PeriodicReport b c+prMapMaybeName f report = report{prRows = mapMaybe (prrMapMaybeName f) $ prRows report}++-- | Map a function over the row names of the PeriodicReportRow.+prrMapName :: (a -> b) -> PeriodicReportRow a c -> PeriodicReportRow b c+prrMapName f row = row{prrName = f $ prrName row}++-- | Map maybe a function over the row names of the PeriodicReportRow.+prrMapMaybeName :: (a -> Maybe b) -> PeriodicReportRow a c -> Maybe (PeriodicReportRow b c)+prrMapMaybeName f row = case f $ prrName row of+    Nothing -> Nothing+    Just a  -> Just row{prrName = a}+++-- | A compound balance report has:+--+-- * an overall title+--+-- * the period (date span) of each column+--+-- * one or more named, normal-positive multi balance reports,+--   with columns corresponding to the above, and a flag indicating+--   whether they increased or decreased the overall totals+--+-- * a list of overall totals for each column, and their grand total and average+--+-- It is used in compound balance report commands like balancesheet,+-- cashflow and incomestatement.+data CompoundPeriodicReport a b = CompoundPeriodicReport+  { cbrTitle      :: Text+  , cbrDates      :: [DateSpan]+  , cbrSubreports :: [(Text, PeriodicReport a b, Bool)]+  , cbrTotals     :: PeriodicReportRow () b+  } deriving (Show, Functor, Generic, ToJSON)++instance HasAmounts b => HasAmounts (CompoundPeriodicReport a b) where+  styleAmounts styles cpr@CompoundPeriodicReport{cbrSubreports, cbrTotals} =+    cpr{+        cbrSubreports = styleAmounts styles cbrSubreports+      , cbrTotals     = styleAmounts styles cbrTotals+      }++instance HasAmounts b => HasAmounts (Text, PeriodicReport a b, Bool) where+  styleAmounts styles (a,b,c) = (a,styleAmounts styles b,c)++-- | Description of one subreport within a compound balance report.+-- Part of a "CompoundBalanceCommandSpec", but also used in hledger-lib.+data CBCSubreportSpec a = CBCSubreportSpec+  { cbcsubreporttitle          :: Text                      -- ^ The title to use for the subreport+  , cbcsubreportquery          :: Query                     -- ^ The Query to use for the subreport+  , cbcsubreportoptions        :: ReportOpts -> ReportOpts  -- ^ A function to transform the ReportOpts used to produce the subreport+  , cbcsubreporttransform      :: PeriodicReport DisplayName MixedAmount -> PeriodicReport a MixedAmount  -- ^ A function to transform the result of the subreport+  , cbcsubreportincreasestotal :: Bool                      -- ^ Whether the subreport and overall report total are of the same sign (e.g. Assets are normally+                                                            --   positive in a balance sheet report, as is the overall total. Liabilities are normally of the+                                                            --   opposite sign.)+  }+++-- | The number of indentation steps with which to display a report item.+-- 0 means no indentation. 1 means one indent step, which is normally rendered+-- as two spaces in text output, or two no-break spaces in csv/html output.+type NumberOfIndents = Int++-- | A full name, display name, and indent level for an account.+data DisplayName = DisplayName+    { displayFull   :: AccountName+    , displayName   :: AccountName+    , displayIndent :: NumberOfIndents+    } deriving (Show, Eq, Ord)++instance ToJSON DisplayName where+    toJSON = toJSON . displayFull+    toEncoding = toEncoding . displayFull++-- | Construct a display name for a list report, where full names are shown unindented.+flatDisplayName :: AccountName -> DisplayName+flatDisplayName a = DisplayName a a 0++-- | Construct a display name for a tree report, where leaf names (possibly prefixed by+-- boring parents) are shown indented).+treeDisplayName :: AccountName -> DisplayName+treeDisplayName a = DisplayName a (accountLeafName a) (accountNameLevel a)++-- | Get the full canonical account name from a PeriodicReportRow containing a DisplayName.+prrFullName :: PeriodicReportRow DisplayName a -> AccountName+prrFullName = displayFull . prrName++-- | Get the account display name from a PeriodicReportRow containing a DisplayName.+prrDisplayName :: PeriodicReportRow DisplayName a -> AccountName+prrDisplayName = displayName . prrName++-- | Get the indent level from a PeriodicReportRow containing a DisplayName.+prrIndent :: PeriodicReportRow DisplayName a -> Int+prrIndent = displayIndent . prrName
− Hledger/Reports/TransactionsReports.hs 
@@ -1,282 +0,0 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}-{-|--Here are several variants of a transactions report.-Transactions reports are like a postings report, but more-transaction-oriented, and (in the account-centric variant) relative to-a some base account.  They are used by hledger-web.---}--module Hledger.Reports.TransactionsReports (-  TransactionsReport,-  TransactionsReportItem,-  AccountTransactionsReport,-  AccountTransactionsReportItem,-  triOrigTransaction,-  triDate,-  triAmount,-  triBalance,-  triCommodityAmount,-  triCommodityBalance,-  journalTransactionsReport,-  accountTransactionsReport,-  transactionsReportByCommodity,-  transactionRegisterDate,-  tests_TransactionsReports-)-where--import Data.List-import Data.Ord--- import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Calendar--import Hledger.Data-import Hledger.Query-import Hledger.Reports.ReportOptions-import Hledger.Utils----- | A transactions report includes a list of transactions--- (posting-filtered and unfiltered variants), a running balance, and some--- other information helpful for rendering a register view (a flag--- indicating multiple other accounts and a display string describing--- them) with or without a notion of current account(s).--- Two kinds of report use this data structure, see journalTransactionsReport--- and accountTransactionsReport below for details.-type TransactionsReport = (String                   -- label for the balance column, eg "balance" or "total"-                          ,[TransactionsReportItem] -- line items, one per transaction-                          )-type TransactionsReportItem = (Transaction -- the original journal transaction, unmodified-                              ,Transaction -- the transaction as seen from a particular account, with postings maybe filtered-                              ,Bool        -- is this a split, ie more than one other account posting-                              ,String      -- a display string describing the other account(s), if any-                              ,MixedAmount -- the amount posted to the current account(s) by the filtered postings (or total amount posted)-                              ,MixedAmount -- the running total of item amounts, starting from zero;-                                           -- or with --historical, the running total including items-                                           -- (matched by the report query) preceding the report period-                              )--triOrigTransaction (torig,_,_,_,_,_) = torig-triDate (_,tacct,_,_,_,_) = tdate tacct-triAmount (_,_,_,_,a,_) = a-triBalance (_,_,_,_,_,a) = a-triCommodityAmount c = filterMixedAmountByCommodity c  . triAmount-triCommodityBalance c = filterMixedAmountByCommodity c  . triBalance------------------------------------------------------------------------------------- | Select transactions from the whole journal. This is similar to a--- "postingsReport" except with transaction-based report items which--- are ordered most recent first. XXX Or an EntriesReport - use that instead ?--- This is used by hledger-web's journal view.-journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport-journalTransactionsReport opts j q = (totallabel, items)-   where-     -- XXX items' first element should be the full transaction with all postings-     items = reverse $ accountTransactionsReportItems q None nullmixedamt id ts-     ts    = sortBy (comparing date) $ filter (q `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts opts j-     date  = transactionDateFn opts------------------------------------------------------------------------------------- | An account transactions report represents transactions affecting--- a particular account (or possibly several accounts, but we don't--- use that). It is used eg by hledger-ui's and hledger-web's account--- register view, where we want to show one row per transaction, in--- the context of the current account. Report items consist of:------ - the transaction, unmodified------ - the transaction as seen in the context of the current account and query,---   which means:------   - the transaction date is set to the "transaction context date",---     which can be different from the transaction's general date:---     if postings to the current account (and matched by the report query)---     have their own dates, it's the earliest of these dates.------   - the transaction's postings are filtered, excluding any which are not---     matched by the report query------ - a text description of the other account(s) posted to/from------ - a flag indicating whether there's more than one other account involved------ - the total increase/decrease to the current account------ - the report transactions' running total after this transaction;---   or if historical balance is requested (-H), the historical running total.---   The historical running total includes transactions from before the---   report start date if one is specified, filtered by the report query.---   The historical running total may or may not be the account's historical---   running balance, depending on the report query.------ Items are sorted by transaction register date (the earliest date the transaction--- posts to the current account), most recent first.--- Reporting intervals are currently ignored.----type AccountTransactionsReport =-  (String                          -- label for the balance column, eg "balance" or "total"-  ,[AccountTransactionsReportItem] -- line items, one per transaction-  )--type AccountTransactionsReportItem =-  (-   Transaction -- the transaction, unmodified-  ,Transaction -- the transaction, as seen from the current account-  ,Bool        -- is this a split (more than one posting to other accounts) ?-  ,String      -- a display string describing the other account(s), if any-  ,MixedAmount -- the amount posted to the current account(s) (or total amount posted)-  ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction-  )--accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> AccountTransactionsReport-accountTransactionsReport opts j reportq thisacctq = (label, items)-  where-    -- a depth limit does not affect the account transactions report-    -- seems unnecessary for some reason XXX-    reportq' = -- filterQuery (not . queryIsDepth)-               reportq-    -- get all transactions, with amounts converted to cost basis if -B-    ts1 = jtxns $ journalSelectingAmountFromOpts opts j-    -- apply any cur:SYM filters in reportq'-    symq  = filterQuery queryIsSym reportq'-    ts2 = (if queryIsNull symq then id else map (filterTransactionAmounts symq)) ts1-    -- keep just the transactions affecting this account (via possibly realness or status-filtered postings)-    realq = filterQuery queryIsReal reportq'-    statusq = filterQuery queryIsStatus reportq'-    ts3 = filter (matchesTransaction thisacctq . filterTransactionPostings (And [realq, statusq])) ts2-    -- sort by the transaction's register date, for accurate starting balance-    ts = sortBy (comparing (transactionRegisterDate reportq' thisacctq)) ts3--    (startbal,label)-      | balancetype_ opts == HistoricalBalance = (sumPostings priorps, balancelabel)-      | otherwise                              = (nullmixedamt,        totallabel)-      where-        priorps = dbg1 "priorps" $-                  filter (matchesPosting-                          (dbg1 "priorq" $-                           And [thisacctq, tostartdateq, datelessreportq]))-                         $ transactionsPostings ts-        tostartdateq =-          case mstartdate of-            Just _  -> Date (DateSpan Nothing mstartdate)-            Nothing -> None  -- no start date specified, there are no prior postings-        mstartdate = queryStartDate (date2_ opts) reportq'-        datelessreportq = filterQuery (not . queryIsDateOrDate2) reportq'--    items = reverse $ -- see also registerChartHtml-            accountTransactionsReportItems reportq' thisacctq startbal negate ts--totallabel = "Period Total"-balancelabel = "Historical Total"---- | Generate transactions report items from a list of transactions,--- using the provided user-specified report query, a query specifying--- which account to use as the focus, a starting balance, a sign-setting--- function and a balance-summing function. Or with a None current account--- query, this can also be used for the journalTransactionsReport.-accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]-accountTransactionsReportItems _ _ _ _ [] = []-accountTransactionsReportItems reportq thisacctq bal signfn (torig:ts) =-    case i of Just i' -> i':is-              Nothing -> is-    -- 201403: This is used for both accountTransactionsReport and journalTransactionsReport, which makes it a bit overcomplicated-    -- 201407: I've lost my grip on this, let's just hope for the best-    -- 201606: we now calculate change and balance from filtered postings, check this still works well for all callers XXX-    where-      tfiltered@Transaction{tpostings=reportps} = filterTransactionPostings reportq torig-      tacct = tfiltered{tdate=transactionRegisterDate reportq thisacctq tfiltered}-      (i,bal') = case reportps of-           [] -> (Nothing,bal)  -- no matched postings in this transaction, skip it-           _  -> (Just (torig, tacct, numotheraccts > 1, otheracctstr, a, b), b)-                 where-                  (thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps-                  numotheraccts = length $ nub $ map paccount otheracctps-                  otheracctstr | thisacctq == None  = summarisePostingAccounts reportps     -- no current account ? summarise all matched postings-                               | numotheraccts == 0 = summarisePostingAccounts thisacctps   -- only postings to current account ? summarise those-                               | otherwise          = summarisePostingAccounts otheracctps  -- summarise matched postings to other account(s)-                  a = signfn $ negate $ sum $ map pamount thisacctps-                  b = bal + a-      is = accountTransactionsReportItems reportq thisacctq bal' signfn ts---- | What is the transaction's date in the context of a particular account--- (specified with a query) and report query, as in an account register ?--- It's normally the transaction's general date, but if any posting(s)--- matched by the report query and affecting the matched account(s) have--- their own earlier dates, it's the earliest of these dates.--- Secondary transaction/posting dates are ignored.-transactionRegisterDate :: Query -> Query -> Transaction -> Day-transactionRegisterDate reportq thisacctq t-  | null thisacctps = tdate t-  | otherwise       = minimum $ map postingDate thisacctps-  where-    reportps   = tpostings $ filterTransactionPostings reportq t-    thisacctps = filter (matchesPosting thisacctq) reportps---- -- | Generate a short readable summary of some postings, like--- -- "from (negatives) to (positives)".--- summarisePostings :: [Posting] -> String--- summarisePostings ps =---     case (summarisePostingAccounts froms, summarisePostingAccounts tos) of---        ("",t) -> "to "++t---        (f,"") -> "from "++f---        (f,t)  -> "from "++f++" to "++t---     where---       (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps---- | Generate a simplified summary of some postings' accounts.--- To reduce noise, if there are both real and virtual postings, show only the real ones.-summarisePostingAccounts :: [Posting] -> String-summarisePostingAccounts ps =-  (intercalate ", " . map (T.unpack . accountSummarisedName) . nub . map paccount) displayps -- XXX pack-  where-    realps = filter isReal ps-    displayps | null realps = ps-              | otherwise   = realps------------------------------------------------------------------------------------- | Split a transactions report whose items may involve several commodities,--- into one or more single-commodity transactions reports.-transactionsReportByCommodity :: TransactionsReport -> [(CommoditySymbol, TransactionsReport)]-transactionsReportByCommodity tr =-  [(c, filterTransactionsReportByCommodity c tr) | c <- transactionsReportCommodities tr]-  where-    transactionsReportCommodities (_,items) =-      nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items---- Remove transaction report items and item amount (and running--- balance amount) components that don't involve the specified--- commodity. Other item fields such as the transaction are left unchanged.-filterTransactionsReportByCommodity :: CommoditySymbol -> TransactionsReport -> TransactionsReport-filterTransactionsReportByCommodity c (label,items) =-  (label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items])-  where-    filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal)-      | c `elem` cs = [item']-      | otherwise   = []-      where-        cs = map acommodity $ amounts a-        item' = (t,t2,s,o,a',bal)-        a' = filterMixedAmountByCommodity c a--    fixTransactionsReportItemBalances [] = []-    fixTransactionsReportItemBalances [i] = [i]-    fixTransactionsReportItemBalances items = reverse $ i:(go startbal is)-      where-        i:is = reverse items-        startbal = filterMixedAmountByCommodity c $ triBalance i-        go _ [] = []-        go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is-          where bal' = bal + amt------------------------------------------------------------------------------------- tests--tests_TransactionsReports = tests "TransactionsReports" [- ]
Hledger/Utils.hs view
@@ -1,136 +1,103 @@ {-|--Standard imports and utilities which are useful everywhere, or needed low-in the module hierarchy. This is the bottom of hledger's module graph.-+Utilities used throughout hledger, or needed low in the module hierarchy.+These are the bottom of hledger's module graph. -}-{-# LANGUAGE OverloadedStrings, LambdaCase #-} -module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:-                          -- module Control.Monad,-                          -- module Data.List,-                          -- module Data.Maybe,-                          -- module Data.Time.Calendar,-                          -- module Data.Time.Clock,-                          -- module Data.Time.LocalTime,-                          -- module Data.Tree,-                          -- module Text.RegexPR,-                          -- module Text.Printf,-                          ---- all of this one:-                          module Hledger.Utils,-                          module Hledger.Utils.Debug,-                          module Hledger.Utils.Parse,-                          module Hledger.Utils.Regex,-                          module Hledger.Utils.String,-                          module Hledger.Utils.Text,-                          module Hledger.Utils.Test,-                          module Hledger.Utils.Color,-                          module Hledger.Utils.Tree,-                          -- Debug.Trace.trace,-                          -- module Data.PPrint,-                          -- module Hledger.Utils.UTF8IOCompat-                          SystemString,fromSystemString,toSystemString,error',userError',usageError,-                          -- the rest need to be done in each module I think-                          )-where+{-# LANGUAGE CPP #-} -import Control.Monad (liftM, when)--- import Data.Char-import Data.Default-import Data.FileEmbed (makeRelativeToProject, embedStringFile)-import Data.List--- import Data.Maybe--- import Data.PPrint--- import Data.String.Here (hereFile)-import Data.Text (Text)-import qualified Data.Text.IO as T-import Data.Time.Clock-import Data.Time.LocalTime--- import Data.Text (Text)--- import qualified Data.Text as T--- import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Language.Haskell.TH.Syntax (Q, Exp)-import System.Directory (getHomeDirectory)-import System.FilePath((</>), isRelative)-import System.IO--- import Text.Printf--- import qualified Data.Map as Map+module Hledger.Utils ( -import Hledger.Utils.Debug-import Hledger.Utils.Parse-import Hledger.Utils.Regex-import Hledger.Utils.String-import Hledger.Utils.Text-import Hledger.Utils.Test-import Hledger.Utils.Color-import Hledger.Utils.Tree--- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn)--- import Hledger.Utils.UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn)-import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError',usageError)+  -- * Functions+  applyN,+  mapM',+  sequence',+  curry2,+  uncurry2,+  curry3,+  uncurry3,+  curry4,+  uncurry4, +  divideSafe, --- tuples+  -- * Lists+  maximum',+  maximumStrict,+  minimumStrict,+  splitAtElement,+  sumStrict,+  all1,+  takeUntilFails,+  takeUntilFailsNE, -first3  (x,_,_) = x-second3 (_,x,_) = x-third3  (_,_,x) = x+  -- * Trees+  treeLeaves, -first4  (x,_,_,_) = x-second4 (_,x,_,_) = x-third4  (_,_,x,_) = x-fourth4 (_,_,_,x) = x+  -- * Tuples+  first3,+  second3,+  third3,+  first4,+  second4,+  third4,+  fourth4,+  first5,+  second5,+  third5,+  fourth5,+  fifth5,+  first6,+  second6,+  third6,+  fourth6,+  fifth6,+  sixth6, -first5  (x,_,_,_,_) = x-second5 (_,x,_,_,_) = x-third5  (_,_,x,_,_) = x-fourth5 (_,_,_,x,_) = x-fifth5  (_,_,_,_,x) = x+  -- * Misc+  multicol,+  numDigitsInt,+  numDigitsInteger,+  makeHledgerClassyLenses, -first6  (x,_,_,_,_,_) = x-second6 (_,x,_,_,_,_) = x-third6  (_,_,x,_,_,_) = x-fourth6 (_,_,_,x,_,_) = x-fifth6  (_,_,_,_,x,_) = x-sixth6  (_,_,_,_,_,x) = x+  -- * Other+  module Hledger.Utils.Debug,+  module Hledger.Utils.Parse,+  module Hledger.Utils.IO,+  module Hledger.Utils.Regex,+  module Hledger.Utils.String,+  module Hledger.Utils.Text, --- lists+  -- * Tests+  tests_Utils,+  module Hledger.Utils.Test, -splitAtElement :: Eq a => a -> [a] -> [[a]]-splitAtElement x l =-  case l of-    []          -> []-    e:es | e==x -> split es-    es          -> split es-  where-    split es = let (first,rest) = break (x==) es-               in first : splitAtElement x rest+)+where --- text+import Data.Char (toLower)+import Data.List (intersperse)+import Data.List.Extra (chunksOf, foldl1', uncons, unsnoc)+import qualified Data.List.NonEmpty as NE+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Set qualified as Set+import Data.Text qualified as T (pack, unpack)+import Data.Tree (foldTree, Tree (Node, subForest))+import Language.Haskell.TH (DecsQ, Name, mkName, nameBase)+import Lens.Micro ((&), (.~))+import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules) --- time+import Hledger.Utils.Debug+import Hledger.Utils.Parse+import Hledger.Utils.IO+import Hledger.Utils.Regex+import Hledger.Utils.String+import Hledger.Utils.Text+import Hledger.Utils.Test -getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t -getCurrentZonedTime :: IO ZonedTime-getCurrentZonedTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToZonedTime tz t---- misc--instance Default Bool where def = False--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _        = False--isRight :: Either a b -> Bool-isRight = not . isLeft+-- Functions  -- | Apply a function the specified number of times, -- which should be > 0 (otherwise does nothing).@@ -142,58 +109,57 @@ -- applyN :: Int -> (a -> a) -> a -> a -- applyN n f = X.foldr (.) identity (X.replicate n f) --- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,--- given the current directory. ~username is not supported. Leave "-" unchanged.--- Can raise an error.-expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers-expandPath _ "-" = return "-"-expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p+-- | Like mapM but uses sequence'.+{-# INLINABLE mapM' #-}+mapM' :: Monad f => (a -> f b) -> [a] -> f [b]+mapM' f = sequence' . map f --- | Expand user home path indicated by tilde prefix-expandHomePath :: FilePath -> IO FilePath-expandHomePath = \case-    ('~':'/':p)  -> (</> p) <$> getHomeDirectory-    ('~':'\\':p) -> (</> p) <$> getHomeDirectory-    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"-    p            -> return p+-- | This is a version of sequence based on difference lists. It is+-- slightly faster but we mostly use it because it uses the heap+-- instead of the stack. This has the advantage that Neil Mitchell’s+-- trick of limiting the stack size to discover space leaks doesn’t+-- show this as a false positive.+{-# INLINABLE sequence' #-}+sequence' :: Monad f => [f a] -> f [a]+sequence' ms = do+  h <- go id ms+  return (h [])+  where+    go h [] = return h+    go h (m:ms') = do+      x <- m+      go (h . (x :)) ms' -firstJust ms = case dropWhile (==Nothing) ms of-    [] -> Nothing-    (md:_) -> md+curry2 :: ((a, b) -> c) -> a -> b -> c+curry2 f x y = f (x, y) --- | Read text from a file, --- handling any of the usual line ending conventions,--- using the system locale's text encoding,--- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8. -readFilePortably :: FilePath -> IO Text-readFilePortably f =  openFile f ReadMode >>= readHandlePortably+uncurry2 :: (a -> b -> c) -> (a, b) -> c+uncurry2 f (x, y) = f x y --- | Like readFilePortably, but read from standard input if the path is "-". -readFileOrStdinPortably :: String -> IO Text-readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably-  where-    openFileOrStdin :: String -> IOMode -> IO Handle-    openFileOrStdin "-" _ = return stdin-    openFileOrStdin f m   = openFile f m+curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 f x y z = f (x, y, z) -readHandlePortably :: Handle -> IO Text-readHandlePortably h = do-  hSetNewlineMode h universalNewlineMode-  menc <- hGetEncoding h-  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show-    hSetEncoding h utf8_bom-  T.hGetContents h+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z +curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e+curry4 f w x y z = f (w, x, y, z)++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (w, x, y, z) = f w x y z++-- | Division, returning 0 when the denominator is 0.+divideSafe :: (Eq a, Fractional a) => a -> a -> a+divideSafe _ 0 = 0+divideSafe a b = a / b++-- Lists+ -- | Total version of maximum, for integral types, giving 0 for an empty list. maximum' :: Integral a => [a] -> a maximum' [] = 0 maximum' xs = maximumStrict xs --- | Strict version of sum that doesn’t leak space-{-# INLINABLE sumStrict #-}-sumStrict :: Num a => [a] -> a-sumStrict = foldl' (+) 0- -- | Strict version of maximum that doesn’t leak space {-# INLINABLE maximumStrict #-} maximumStrict :: Ord a => [a] -> a@@ -204,39 +170,164 @@ minimumStrict :: Ord a => [a] -> a minimumStrict = foldl1' min --- | This is a version of sequence based on difference lists. It is--- slightly faster but we mostly use it because it uses the heap--- instead of the stack. This has the advantage that Neil Mitchell’s--- trick of limiting the stack size to discover space leaks doesn’t--- show this as a false positive.-{-# INLINABLE sequence' #-}-sequence' :: Monad f => [f a] -> f [a]-sequence' ms = do-  h <- go id ms-  return (h [])+splitAtElement :: Eq a => a -> [a] -> [[a]]+splitAtElement x l =+  case l of+    []          -> []+    e:es | e==x -> split es+    es          -> split es   where-    go h [] = return h-    go h (m:ms) = do-      x <- m-      go (h . (x :)) ms+    split es = let (first,rest) = break (x==) es+               in first : splitAtElement x rest --- | Like mapM but uses sequence'.-{-# INLINABLE mapM' #-}-mapM' :: Monad f => (a -> f b) -> [a] -> f [b]-mapM' f = sequence' . map f+-- | Strict version of sum that doesn’t leak space+{-# INLINABLE sumStrict #-}+sumStrict :: Num a => [a] -> a+sumStrict = foldl' (+) 0 --- | Like embedFile, but takes a path relative to the package directory.--- Similar to embedFileRelative ?-embedFileRelative :: FilePath -> Q Exp-embedFileRelative f = makeRelativeToProject f >>= embedStringFile+-- | Version of all that fails on an empty list.+{-# INLINABLE all1 #-}+all1 :: (a -> Bool) -> [a] -> Bool+all1 _ [] = False+all1 p as = all p as --- -- | Like hereFile, but takes a path relative to the package directory.--- -- Similar to embedFileRelative ?--- hereFileRelative :: FilePath -> Q Exp--- hereFileRelative f = makeRelativeToProject f >>= hereFileExp---   where---     QuasiQuoter{quoteExp=hereFileExp} = hereFile-    -tests_Utils = tests "Utils" [+-- | Take elements from a non-empty list until a predicate fails, and then keep+-- the first failing element as well.+takeUntilFailsNE :: (a -> Bool) -> NE.NonEmpty a -> NE.NonEmpty a+takeUntilFailsNE p = NE.fromList . takeUntilFails p . NE.toList  -- Result guaranteed to be non-empty++-- | Take elements from a list until a predicate fails, and then keep the first+-- failing element as well.+takeUntilFails :: (a -> Bool) -> [a] -> [a]+takeUntilFails p = foldr (\x -> if p x then (x :) else const [x]) []++-- Trees++-- | Get the leaves of this tree as a list. +-- The topmost node ("root" in hledger account trees) is not counted as a leaf.+treeLeaves :: Tree a -> [a]+treeLeaves Node{subForest=[]} = []+treeLeaves t = foldTree (\a bs -> (if null bs then (a:) else id) $ concat bs) t++-- Tuples++first3  (x,_,_) = x+second3 (_,x,_) = x+third3  (_,_,x) = x++first4  (x,_,_,_) = x+second4 (_,x,_,_) = x+third4  (_,_,x,_) = x+fourth4 (_,_,_,x) = x++first5  (x,_,_,_,_) = x+second5 (_,x,_,_,_) = x+third5  (_,_,x,_,_) = x+fourth5 (_,_,_,x,_) = x+fifth5  (_,_,_,_,x) = x++first6  (x,_,_,_,_,_) = x+second6 (_,x,_,_,_,_) = x+third6  (_,_,x,_,_,_) = x+fourth6 (_,_,_,x,_,_) = x+fifth6  (_,_,_,_,x,_) = x+sixth6  (_,_,_,_,_,x) = x++-- Misc++-- | Convert a list of strings to a multi-line multi-column list+-- fitting within the given width. Not wide character aware.+multicol :: Int -> [String] -> String+multicol _ [] = []+multicol width strs =+  let+    maxwidth = maximum' $ map length strs+    numcols = min (length strs) (width `div` (maxwidth+2))+    itemspercol = length strs `div` numcols+    colitems = chunksOf itemspercol strs+    cols = map unlines colitems+    sep = " "+  in+    T.unpack $ textConcatBottomPadded $ map T.pack $ intersperse sep cols++-- | Find the number of digits of an 'Int'.+{-# INLINE numDigitsInt #-}+numDigitsInt :: Integral a => Int -> a+numDigitsInt n+    | n == minBound = 19  -- negate minBound is out of the range of Int+    | n < 0         = go (negate n)+    | otherwise     = go n+  where+    go a | a < 10                 = 1+         | a < 100                = 2+         | a < 1000               = 3+         | a < 10000              = 4+         | a >= 10000000000000000 = 16 + go (a `quot` 10000000000000000)+         | a >= 100000000         = 8  + go (a `quot` 100000000)+         | otherwise              = 4  + go (a `quot` 10000)++-- | Find the number of digits of an Integer.+-- The integer should not have more digits than an Int can count.+-- This is probably inefficient.+numDigitsInteger :: Integer -> Int+numDigitsInteger = length . dropWhile (=='-') . show++-- | Make classy lenses for Hledger options fields.+-- This is intended to be used with BalancingOpts, InputOpt, ReportOpts,+-- ReportSpec, and CliOpts.+-- When run on X, it will create a typeclass named HasX (except for ReportOpts,+-- which will be named HasReportOptsNoUpdate) containing all the lenses for that type.+-- If the field name starts with an underscore, the lens name will be created+-- by stripping the underscore from the front on the name. If the field name ends with+-- an underscore, the field name ends with an underscore, the lens name will be+-- mostly created by stripping the underscore, but a few names for which this+-- would create too many conflicts instead have a second underscore appended.+-- ReportOpts fields for which updating them requires updating the query in+-- ReportSpec are instead names by dropping the trailing underscore and+-- appending NoUpdate to the name, e.g. querystring_ -> querystringNoUpdate.+--+-- There are a few reasons for the complicated rules.+-- - We have some legacy field names ending in an underscore (e.g. value_)+--   which we want to temporarily accommodate, before eventually switching to+--   a more modern style (e.g. _rsReportOpts)+-- - Certain fields in ReportOpts need to update the enclosing ReportSpec when+--   they are updated, and it is a common programming error to forget to do+--   this. We append NoUpdate to those lenses which will not update the+--   enclosing field, and reserve the shorter name for manually define lenses+--   (or at least something lens-like) which will update the ReportSpec.+-- cf. the lengthy discussion here and in surrounding comments:+-- https://github.com/simonmichael/hledger/pull/1545#issuecomment-881974554+makeHledgerClassyLenses :: Name -> DecsQ+makeHledgerClassyLenses x = flip makeLensesWith x $ classyRules+    & lensField .~ (\_ _ n -> fieldName $ nameBase n)+    & lensClass .~ (className . nameBase)+  where+    fieldName n | Just ('_', name) <- uncons n   = [TopName (mkName name)]+                | Just (name, '_') <- unsnoc n,+                  name `Set.member` queryFields  = [TopName (mkName $ name ++ "NoUpdate")]+                | Just (name, '_') <- unsnoc n,+                  name `Set.member` commonFields = [TopName (mkName $ name ++ "__")]+                | Just (name, '_') <- unsnoc n   = [TopName (mkName name)]+                | otherwise                      = []++    -- Fields which would cause too many conflicts if we exposed lenses with these names.+    commonFields = Set.fromList+        [ "empty", "drop", "color", "transpose"  -- ReportOpts+        , "anon", "new", "auto"                  -- InputOpts+        , "rawopts", "file", "debug", "width"    -- CliOpts+        ]++    -- When updating some fields of ReportOpts within a ReportSpec, we need to+    -- update the rsQuery term as well. To do this we implement a special+    -- HasReportOpts class with some special behaviour. We therefore give the+    -- basic lenses a special NoUpdate name to avoid conflicts.+    className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate")+    className (x':xs)       = Just (mkName ("Has" ++ x':xs), mkName (toLower x' : xs))+    className []           = Nothing++    -- Fields of ReportOpts which need to update the Query when they are updated.+    queryFields = Set.fromList ["period", "statuses", "depth", "date2", "real", "querystring"]++tests_Utils = testGroup "Utils" [   tests_Text   ]
− Hledger/Utils/Color.hs 
@@ -1,23 +0,0 @@--- | Basic color helpers for prettifying console output.--{-# LANGUAGE OverloadedStrings #-}--module Hledger.Utils.Color -(-  color,-  bgColor,-  Color(..),-  ColorIntensity(..)-)-where--import System.Console.ANSI----- | Wrap a string in ANSI codes to set and reset foreground colour.-color :: ColorIntensity -> Color -> String -> String-color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []---- | Wrap a string in ANSI codes to set and reset background colour.-bgColor :: ColorIntensity -> Color -> String -> String-bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []
Hledger/Utils/Debug.hs view
@@ -1,21 +1,164 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}--- | Debugging helpers+{- |  +Here are debug tracing/logging helpers built on Debug.Trace, extracted from the hledger project.+Features:++- they can be built in to your program permanently, and activated by a --debug [LEVEL] option+- they can optionally log to a file instead of stderr (for TUI apps)+- they can be used in IO, pure, or startup code+- values are printed with a label, and pretty-printed (using pretty-simple)+- ANSI colour is used when appropriate.++Insert these @dbg*@ helpers at points of interest in your code,+either temporarily while debugging,+or permanently in production code, and activate them with @--debug [1-9]@ on the command line+(@--debug@ with no value means level 1).+For example, this expression:++> dbg4 "foo" foo++will pretty-print foo with a "foo:" label when it is evaluated, but only if --debug's value is 4 or greater.+In other words: use dbg1 for the most useful debug output, dbg9 for the most specialised/verbose.++They are intended to be easy to use and to find in your code, with a consistent naming scheme:++> dbg<LEVEL>Msg   STR    VAL  -- trace/log a string in pure code+> dbg<LEVEL>MsgIO STR         -- trace/log a string in IO+>+> dbg<LEVEL>      STR    VAL  -- trace/log a showable value in pure code+> dbg<LEVEL>IO    STR    VAL  -- trace/log a showable value in IO+>+> dbg<LEVEL>With  SHOWFN VAL  -- trace/log any value++Or if you prefer you can ignore the numbered variants and write an extra argument:++> dbgMsg   LEVEL  STR    VAL+> dbgMsgIO LEVEL  STR+>+> dbg      LEVEL  STR    VAL+> dbgIO    LEVEL  STR    VAL+>+> dbgWith  LEVEL  SHOWFN VAL++Haskell values will be pretty-printed by default, using pretty-simple.++ANSI color will also be used if appropriate,+respecting output capabilities, @NO_COLOR@, and/or a @--color [YNA]@ (or @--colour@) command line option.++These helpers normally print output on stderr, but can automatically log to a file instead,+which can be useful for TUI apps which are redrawing the screen.+To enable this logging mode, use @withProgName@ to add a ".log" suffix to the program name:++> main = withProgName "PROGRAM.log" $ do ...++Now all dbg calls will log to @PROGRAM.log@ in the current directory.++Logging, and reading the command line\/program name\/output context use unsafePerformIO,+so that these can be used anywhere, including early in your program before command line parsing is complete.+As a consequence, if you are testing in GHCI and want to change the debug level, you'll need to reload this module.++The @dbg@ function name clashes with the one in Text.Megaparsec.Debug, unfortunately; sorry about that.+If you are also using that, use qualified imports, or our @dbg_@ alias, to avoid the clash.++The meaning of debug levels is up to you. Eg hledger uses them as follows:++@+Debug level:  What to show:+------------  ---------------------------------------------------------+0             normal program output only+1             useful warnings, most common troubleshooting info+2             common troubleshooting info, more detail+3             report options selection+4             report generation+5             report generation, more detail+6             input file reading+7             input file reading, more detail+8             command line parsing+9             any other rarely needed / more in-depth info+@++It's not yet possible to select debug output by topic; that would be useful.++-}++-- Disabled until 0.1.2.0 is released with windows support:+--  This module also exports Debug.Trace and the breakpoint package's Debug.Breakpoint.+ -- more: -- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html -- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html+-- https://hackage.haskell.org/package/debug +-- internal helpers, currently not exported:++-- * Tracing to stderr+-- These print to stderr.+-- This output will be interleaved with the program's normal output,+-- which can be helpful for understanding code execution.+--+-- ,traceWith+-- ,traceAt+-- ,traceAtWith+-- ,ptrace+-- ,ptraceAt+-- ,ptraceAtIO++-- * Logging to a log file+-- These append to a PROGRAM.log file in the current directory.+-- PROGRAM is normally the name of the executable, but it can change+-- eg when running in GHCI. So when using these, you should call+-- @withProgName@ to ensure a stable program name.+-- Eg: @main = withProgName "PROGRAM" $ do ...@.+--+-- ,log'+-- ,logAt+-- ,logIO+-- ,logAtIO+-- ,logWith+-- ,logAtWith+-- ,plogAt+-- ,plogAtIO++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+ module Hledger.Utils.Debug (-   pprint-  ,pshow-  ,ptrace-  ,traceWith-  ,debugLevel-  ,ptraceAt++  -- * Debug level+  debugLevel++  -- * Trace/log a string+  ,dbgMsg+  ,dbg0Msg+  ,dbg1Msg+  ,dbg2Msg+  ,dbg3Msg+  ,dbg4Msg+  ,dbg5Msg+  ,dbg6Msg+  ,dbg7Msg+  ,dbg8Msg+  ,dbg9Msg++  -- * Trace/log a string in IO+  ,dbgMsgIO+  ,dbg0MsgIO+  ,dbg1MsgIO+  ,dbg2MsgIO+  ,dbg3MsgIO+  ,dbg4MsgIO+  ,dbg5MsgIO+  ,dbg6MsgIO+  ,dbg7MsgIO+  ,dbg8MsgIO+  ,dbg9MsgIO++  -- * Trace/log a value+  ,dbg+  ,dbg_   ,dbg0-  ,dbgExit   ,dbg1   ,dbg2   ,dbg3@@ -25,7 +168,9 @@   ,dbg7   ,dbg8   ,dbg9-  ,ptraceAtIO++  -- * Trace/log a value in IO+  ,dbgIO   ,dbg0IO   ,dbg1IO   ,dbg2IO@@ -36,213 +181,473 @@   ,dbg7IO   ,dbg8IO   ,dbg9IO-  ,plog-  ,plogAt-  ,traceParse-  ,dbgparse++  -- * Trace/log a value with a show function+  ,dbgWith+  ,dbg0With+  ,dbg1With+  ,dbg2With+  ,dbg3With+  ,dbg4With+  ,dbg5With+  ,dbg6With+  ,dbg7With+  ,dbg8With+  ,dbg9With++  -- * Utilities+  ,lbl_+  ,progName++  -- * ghc-debug helpers+  ,ghcDebugSupportedInLib+  ,GhcDebugMode(..)+  ,ghcDebugMode+  ,withGhcDebug'+  ,ghcDebugPause'++  -- * Re-exports: Debug.Trace+  -- ,module Debug.Breakpoint   ,module Debug.Trace-)++  ) where -import           Control.Monad (when)-import           Control.Monad.IO.Class-import           Data.List hiding (uncons)-import qualified Data.Text as T-import           Debug.Trace-import           Hledger.Utils.Parse-import           Safe (readDef)-import           System.Environment (getArgs)-import           System.Exit-import           System.IO.Unsafe (unsafePerformIO)-import           Text.Megaparsec-import           Text.Printf-import           Text.Show.Pretty (ppShow, pPrint)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List hiding (uncons)+import Debug.Trace (trace, traceIO, traceShowId)+#ifdef GHCDEBUG+import GHC.Debug.Stub (pause, withGhcDebug)+#endif+import Safe (readDef)+import System.Environment (getProgName)+-- import System.Exit (exitFailure)+import System.IO.Unsafe (unsafePerformIO) --- | Pretty print. Easier alias for pretty-show's pPrint.-pprint :: Show a => a -> IO ()-pprint = pPrint+import Hledger.Utils.IO (progArgs, pshow, pshow') --- | Pretty show. Easier alias for pretty-show's ppShow.-pshow :: Show a => a -> String-pshow = ppShow --- | Pretty trace. Easier alias for traceShowId + ppShow.-ptrace :: Show a => a -> a-ptrace = traceWith pshow+-- | The program name as returned by @getProgName@.+-- It's best to set this explicitly at program startup with @withProgName@,+-- otherwise when running in GHCI (eg) it will change to "<interactive>".+-- Setting it with a ".log" suffix causes some functions below+-- to log instead of trace.+{-# NOINLINE modifiedProgName #-}+modifiedProgName :: String+modifiedProgName = unsafePerformIO getProgName --- | Trace (print to stderr) a showable value using a custom show function.-traceWith :: (a -> String) -> a -> a-traceWith f a = trace (f a) a+-- | The progam name, with any ".log" suffix removed.+progName :: String+progName =+  if ".log" `isSuffixOf` modifiedProgName+  then reverse $ drop 4 $ reverse modifiedProgName+  else modifiedProgName --- | Global debug level, which controls the verbosity of debug output--- on the console. The default is 0 meaning no debug output. The--- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to--- a higher value (note: not @--debug N@ for some reason).  This uses--- unsafePerformIO and can be accessed from anywhere and before normal--- command-line processing. When running with :main in GHCI, you must--- touch and reload this module to see the effect of a new --debug option.--- After command-line processing, it is also available as the @debug_@--- field of 'Hledger.Cli.CliOptions.CliOpts'.--- {-# OPTIONS_GHC -fno-cse #-} --- {-# NOINLINE debugLevel #-}+-- | The program's debug output verbosity, from 0 to 9.+-- The default is 0 meaning no debug output.+-- This can be overridden by running the program with a --debug [1-9] command line option;+-- a --debug flag with no value means 1.+-- Uses unsafePerformIO to read the command line.+-- When running in GHCI, changing this requires reloading this module. debugLevel :: Int-debugLevel = case snd $ break (=="--debug") args of-               "--debug":[]  -> 1+debugLevel = case dropWhile (/="--debug") progArgs of+               ["--debug"]   -> 1                "--debug":n:_ -> readDef 1 n                _             ->-                 case take 1 $ filter ("--debug" `isPrefixOf`) args of+                 case take 1 $ filter ("--debug" `isPrefixOf`) progArgs of                    ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v                    _                                   -> 0 -    where-      args = unsafePerformIO getArgs+-- | Trace (print to stderr) a string if the program debug level is at+-- or above the specified level. At level 0, always prints. Otherwise,+-- uses unsafePerformIO.+traceAt :: Int -> String -> a -> a+traceAt level+    | level > 0 && debugLevel < level = const id+    | otherwise = trace +-- | Like traceAt, but sequences properly in IO.+traceAtIO :: (MonadIO m) => Int -> String -> m ()+traceAtIO level msg =+  if level > 0 && debugLevel < level+  then return ()+  else liftIO $ traceIO msg++-- -- | Trace a value with the given show function before returning it.+-- traceWith :: (a -> String) -> a -> a+-- traceWith f a = trace (f a) a++-- | Trace (print to stderr) a showable value using a custom show function,+-- if the program debug level is at or above the specified level.+-- At level 0, always prints. Otherwise, uses unsafePerformIO.+traceAtWith :: Int -> (a -> String) -> a -> a+traceAtWith level f a = traceAt level (f a) a++-- -- | Pretty-trace a showable value before returning it.+-- -- Like Debug.Trace.traceShowId, but pretty-printing and easier to type.+-- ptrace :: Show a => a -> a+-- ptrace = traceWith pshow+ -- | Pretty-print a label and a showable value to the console--- if the global debug level is at or above the specified level.+-- if the program debug level is at or above the specified level. -- At level 0, always prints. Otherwise, uses unsafePerformIO. ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level-    | level > 0 && debugLevel < level = flip const-    | otherwise = \s a -> let p = ppShow a-                              ls = lines p-                              nlorspace | length ls > 1 = "\n"-                                        | otherwise     = " " ++ take (10 - length s) (repeat ' ')-                              ls' | length ls > 1 = map (" "++) ls-                                  | otherwise     = ls-                          in trace (s++":"++nlorspace++intercalate "\n" ls') a+    | level > 0 && debugLevel < level = const id+    | otherwise = \lbl a -> trace (labelledPretty True lbl a) a --- | Pretty-print a message and the showable value to the console, then return it.-dbg0 :: Show a => String -> a -> a-dbg0 = ptraceAt 0--- "dbg" would clash with megaparsec+-- Pretty-print a showable value with a label, with or without allowing ANSI color.+labelledPretty :: Show a => Bool -> String -> a -> String+labelledPretty allowcolour lbl a = lbl ++ ":" ++ nlorspace ++ intercalate "\n" ls'+  where+    ls = lines $ (if allowcolour then pshow else pshow') a+    nlorspace | length ls > 1 = "\n"+              | otherwise     = replicate (max 1 $ 11 - length lbl) ' '+    ls' | length ls > 1 = map (' ':) ls+        | otherwise     = ls --- | Like dbg0, but also exit the program. Uses unsafePerformIO.-dbgExit :: Show a => String -> a -> a-dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg+-- | Like ptraceAt, but sequences properly in IO.+ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()+ptraceAtIO level label a =+  if level > 0 && debugLevel < level+  then return ()+  else liftIO $ traceIO (labelledPretty True label a) --- | Pretty-print a message and the showable value to the console when the global debug level is >= 1, then return it.++-- | The debug log file: PROGNAME.log in the current directory.+-- See modifiedProgName.+debugLogFile :: FilePath+debugLogFile = progName ++ ".log"++-- | Log a string to the debug log before returning the second argument. -- Uses unsafePerformIO.+log' :: String -> a -> a+log' s x = unsafePerformIO $ do+  evaluate (force s)  -- to complete any previous logging before we attempt more+  appendFile debugLogFile (s ++ "\n")+  return x++-- | Log a string to the debug log before returning the second argument,+-- if the program debug level is at or above the specified level.+-- At level 0, always logs. Otherwise, uses unsafePerformIO.+logAt :: Int -> String -> a -> a+logAt level str+  | level > 0 && debugLevel < level = id+  | otherwise = log' str++-- | Like log' but sequences properly in IO.+logIO :: MonadIO m => String -> m ()+logIO s = do+  liftIO $ evaluate (force s)  -- to complete any previous logging before we attempt more+  liftIO $ appendFile debugLogFile (s ++ "\n")++-- | Like logAt, but convenient to use in IO.+logAtIO :: (MonadIO m) => Int -> String -> m ()+logAtIO level str+  | level > 0 && debugLevel < level = return ()+  | otherwise = logIO str++-- -- | Log a value to the debug log with the given show function before returning it.+-- logWith :: (a -> String) -> a -> a+-- logWith f a = log' (f a) a++-- | Log a string to the debug log before returning the second argument,+-- if the program debug level is at or above the specified level.+-- At level 0, always logs. Otherwise, uses unsafePerformIO.+logAtWith :: Int -> (a -> String) -> a -> a+logAtWith level f a = logAt level (f a) a++-- | Pretty-log a label and showable value to the debug log,+-- if the program debug level is at or above the specified level. +-- At level 0, always prints. Otherwise, uses unsafePerformIO.+plogAt :: (Show a) => Int -> String -> a -> a+plogAt level+  | level > 0 && debugLevel < level = const id+  | otherwise = \lbl a -> log' (labelledPretty False lbl a) a++-- | Like ptraceAt, but sequences properly in IO.+plogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()+plogAtIO level label a =+  if level > 0 && debugLevel < level+  then return ()+  else logIO (labelledPretty False label a)+++-- | Should dbg* log to a file instead of tracing to stderr ?+-- True if the (internal) program name ends with ".log".+shouldLog :: Bool+shouldLog = ".log" `isSuffixOf` modifiedProgName+++-- | Trace or log a string if the program debug level is at or above the specified level,+-- then return the second argument.+dbgMsg :: Int -> String -> a -> a+dbgMsg = if shouldLog then logAt else traceAt++dbg0Msg :: String -> a -> a+dbg0Msg = dbgMsg 0++dbg1Msg :: String -> a -> a+dbg1Msg = dbgMsg 1++dbg2Msg :: String -> a -> a+dbg2Msg = dbgMsg 2++dbg3Msg :: String -> a -> a+dbg3Msg = dbgMsg 3++dbg4Msg :: String -> a -> a+dbg4Msg = dbgMsg 4++dbg5Msg :: String -> a -> a+dbg5Msg = dbgMsg 5++dbg6Msg :: String -> a -> a+dbg6Msg = dbgMsg 6++dbg7Msg :: String -> a -> a+dbg7Msg = dbgMsg 7++dbg8Msg :: String -> a -> a+dbg8Msg = dbgMsg 8++dbg9Msg :: String -> a -> a+dbg9Msg = dbgMsg 9+++-- | Like dbgMsg, but sequences properly in IO.+dbgMsgIO :: (MonadIO m) => Int -> String -> m ()+dbgMsgIO = if shouldLog then logAtIO else traceAtIO++dbg0MsgIO :: (MonadIO m) => String -> m ()+dbg0MsgIO = dbgMsgIO 0++dbg1MsgIO :: (MonadIO m) => String -> m ()+dbg1MsgIO = dbgMsgIO 1++dbg2MsgIO :: (MonadIO m) => String -> m ()+dbg2MsgIO = dbgMsgIO 2++dbg3MsgIO :: (MonadIO m) => String -> m ()+dbg3MsgIO = dbgMsgIO 3++dbg4MsgIO :: (MonadIO m) => String -> m ()+dbg4MsgIO = dbgMsgIO 4++dbg5MsgIO :: (MonadIO m) => String -> m ()+dbg5MsgIO = dbgMsgIO 5++dbg6MsgIO :: (MonadIO m) => String -> m ()+dbg6MsgIO = dbgMsgIO 6++dbg7MsgIO :: (MonadIO m) => String -> m ()+dbg7MsgIO = dbgMsgIO 7++dbg8MsgIO :: (MonadIO m) => String -> m ()+dbg8MsgIO = dbgMsgIO 8++dbg9MsgIO :: (MonadIO m) => String -> m ()+dbg9MsgIO = dbgMsgIO 9+++-- | Trace or log a label and showable value, pretty-printed,+-- if the program debug level is at or above the specified level;+-- then return the value.+dbg :: (Show a) => Int -> String -> a -> a+dbg = if shouldLog then plogAt else ptraceAt++-- | Alias for dbg, can be used to avoid namespace clashes.+dbg_ :: (Show a) => Int -> String -> a -> a+dbg_ = dbg++dbg0 :: Show a => String -> a -> a+dbg0 = dbg 0+ dbg1 :: Show a => String -> a -> a-dbg1 = ptraceAt 1+dbg1 = dbg 1  dbg2 :: Show a => String -> a -> a-dbg2 = ptraceAt 2+dbg2 = dbg 2  dbg3 :: Show a => String -> a -> a-dbg3 = ptraceAt 3+dbg3 = dbg 3  dbg4 :: Show a => String -> a -> a-dbg4 = ptraceAt 4+dbg4 = dbg 4  dbg5 :: Show a => String -> a -> a-dbg5 = ptraceAt 5+dbg5 = dbg 5  dbg6 :: Show a => String -> a -> a-dbg6 = ptraceAt 6+dbg6 = dbg 6  dbg7 :: Show a => String -> a -> a-dbg7 = ptraceAt 7+dbg7 = dbg 7  dbg8 :: Show a => String -> a -> a-dbg8 = ptraceAt 8+dbg8 = dbg 8  dbg9 :: Show a => String -> a -> a-dbg9 = ptraceAt 9+dbg9 = dbg 9 --- | Like ptraceAt, but convenient to insert in an IO monad (plus--- convenience aliases).--- XXX These have a bug; they should use--- traceIO, not trace, otherwise GHC can occasionally over-optimise--- (cf lpaste a few days ago where it killed/blocked a child thread).-ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()-ptraceAtIO lvl lbl x = liftIO $ ptraceAt lvl lbl x `seq` return () --- XXX Could not deduce (a ~ ())--- ptraceAtM :: (Monad m, Show a) => Int -> String -> a -> m a--- ptraceAtM lvl lbl x = ptraceAt lvl lbl x `seq` return x+-- | Like dbg, but sequences properly in IO.+dbgIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()+dbgIO = if shouldLog then plogAtIO else ptraceAtIO  dbg0IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg0IO = ptraceAtIO 0+dbg0IO = dbgIO 0  dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg1IO = ptraceAtIO 1+dbg1IO = dbgIO 1  dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg2IO = ptraceAtIO 2+dbg2IO = dbgIO 2  dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg3IO = ptraceAtIO 3+dbg3IO = dbgIO 3  dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg4IO = ptraceAtIO 4+dbg4IO = dbgIO 4  dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg5IO = ptraceAtIO 5+dbg5IO = dbgIO 5  dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg6IO = ptraceAtIO 6+dbg6IO = dbgIO 6  dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg7IO = ptraceAtIO 7+dbg7IO = dbgIO 7  dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg8IO = ptraceAtIO 8+dbg8IO = dbgIO 8  dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg9IO = ptraceAtIO 9+dbg9IO = dbgIO 9 --- | Log a message and a pretty-printed showable value to ./debug.log, then return it.--- Can fail, see plogAt.-plog :: Show a => String -> a -> a-plog = plogAt 0 --- | Log a message and a pretty-printed showable value to ./debug.log, --- if the global debug level is at or above the specified level.--- At level 0, always logs. Otherwise, uses unsafePerformIO.--- Tends to fail if called more than once, at least when built with -threaded--- (Exception: debug.log: openFile: resource busy (file is locked)).-plogAt :: Show a => Int -> String -> a -> a-plogAt lvl-    | lvl > 0 && debugLevel < lvl = flip const-    | otherwise = \s a -> -        let p = ppShow a-            ls = lines p-            nlorspace | length ls > 1 = "\n"-                      | otherwise     = " " ++ take (10 - length s) (repeat ' ')-            ls' | length ls > 1 = map (" "++) ls-                | otherwise     = ls-            output = s++":"++nlorspace++intercalate "\n" ls'++"\n"-        in unsafePerformIO $ appendFile "debug.log" output >> return a+-- | Like dbg, but with a custom show function.+dbgWith :: Int -> (a -> String) -> a -> a+dbgWith = if shouldLog then logAtWith else traceAtWith --- XXX redundant ? More/less robust than plogAt ?--- -- | Like dbg, but writes the output to "debug.log" in the current directory.--- dbglog :: Show a => String -> a -> a--- dbglog label a =---   (unsafePerformIO $---     appendFile "debug.log" $ label ++ ": " ++ ppShow a ++ "\n")---   `seq` a+dbg0With :: (a -> String) -> a -> a+dbg0With = dbgWith 0 --- | Print the provided label (if non-null) and current parser state--- (position and next input) to the console. (See also megaparsec's dbg.)-traceParse :: String -> TextParser m ()-traceParse msg = do-  pos <- getSourcePos-  next <- (T.take peeklength) `fmap` getInput-  let (l,c) = (sourceLine pos, sourceColumn pos)-      s  = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String-      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg-  trace s' $ return ()-  where-    peeklength = 30+dbg1With :: (a -> String) -> a -> a+dbg1With = dbgWith 1 --- | Print the provided label (if non-null) and current parser state--- (position and next input) to the console if the global debug level--- is at or above the specified level. Uses unsafePerformIO.--- (See also megaparsec's dbg.)-traceParseAt :: Int -> String -> TextParser m ()-traceParseAt level msg = when (level <= debugLevel) $ traceParse msg+dbg2With :: (a -> String) -> a -> a+dbg2With = dbgWith 2 --- | Convenience alias for traceParseAt-dbgparse :: Int -> String -> TextParser m ()-dbgparse level msg = traceParseAt level msg+dbg3With :: (a -> String) -> a -> a+dbg3With = dbgWith 3 +dbg4With :: (a -> String) -> a -> a+dbg4With = dbgWith 4++dbg5With :: (a -> String) -> a -> a+dbg5With = dbgWith 5++dbg6With :: (a -> String) -> a -> a+dbg6With = dbgWith 6++dbg7With :: (a -> String) -> a -> a+dbg7With = dbgWith 7++dbg8With :: (a -> String) -> a -> a+dbg8With = dbgWith 8++dbg9With :: (a -> String) -> a -> a+dbg9With = dbgWith 9++-- | Helper for producing debug messages:+-- concatenates a name (eg a function name),+-- short description of the value being logged,+-- and string representation of the value.+--+-- Eg: @let lbl = lbl_ "print"@,+-- @dbg1With (lbl "part 1".show) ...@.+--+lbl_ :: String -> String -> String -> String+lbl_ name desc val = name <> ": " <> desc <> ":" <> " " <> val++-- XXX the resulting function is constrained to only one value type+-- -- | A helper for defining a local "dbg" function.+-- -- Given a debug level and a topic string (eg, a function name),+-- -- it generates a function which takes+-- -- - a description string,+-- -- - a value-to-string show function,+-- -- - and a value to be inspected,+-- -- debug-logs the topic, description and result of calling the show function on the value,+-- -- formatted nicely, at the specified debug level or above,+-- -- then returns the value.+-- dbg_ :: forall a. Int -> String -> (String -> (a -> String) -> a -> a)+-- dbg_ level topic =+--   \desc showfn val ->+--     dbgWith level (lbl_ topic desc . showfn) val+-- {-# HLINT ignore "Redundant lambda" #-}+++-- | Whether ghc-debug support is included in this build, and if so, how it will behave.+-- When hledger is built with the @ghcdebug@ cabal flag (off by default, because of extra deps),+-- it can listen (on unix ?) for connections from ghc-debug clients like ghc-debug-brick,+-- for pausing/resuming the program and inspecting memory usage and profile information.+--+-- With a ghc-debug-supporting build, ghc-debug can be enabled by running hledger with+-- a negative --debug level. There are three different modes:+-- --debug=-1 - run normally (can be paused/resumed by a ghc-debug client),+-- --debug=-2 - pause and await client commands at program start (not useful currently),+-- --debug=-3 - pause and await client commands at program end.+data GhcDebugMode =+    GDNotSupported+  | GDDisabled+  | GDNoPause+  | GDPauseAtStart+  | GDPauseAtEnd+  -- keep synced with ghcDebugMode+  deriving (Eq,Ord,Show)++-- | Is the hledger-lib package built with ghc-debug support ?+ghcDebugSupportedInLib :: Bool+ghcDebugSupportedInLib =+#ifdef GHCDEBUG+  True+#else+  False+#endif++-- | Should the program open a socket allowing control by ghc-debug-brick or similar ghc-debug client ?+-- See GhcDebugMode.+ghcDebugMode :: GhcDebugMode+ghcDebugMode =+#ifdef GHCDEBUG+  case debugLevel of+    _ | not ghcDebugSupportedInLib -> GDNotSupported+    (-1) -> GDNoPause+    (-2) -> GDPauseAtStart+    (-3) -> GDPauseAtEnd+    _    -> GDDisabled+    -- keep synced with GhcDebugMode+#else+  GDNotSupported+#endif++-- | When ghc-debug support has been built into the program and enabled at runtime with --debug=-N,+-- this calls ghc-debug's withGhcDebug; otherwise it's a no-op.+withGhcDebug' =+#ifdef GHCDEBUG+  if ghcDebugMode > GDDisabled then withGhcDebug else id+#else+  id+#endif++-- | When ghc-debug support has been built into the program, this calls ghc-debug's pause, otherwise it's a no-op.+ghcDebugPause' :: IO ()+ghcDebugPause' =+#ifdef GHCDEBUG+  pause+#else+  return ()+#endif
+ Hledger/Utils/IO.hs view
@@ -0,0 +1,980 @@+{- | +General and hledger-specific input/output-related helpers for+pretty-printing haskell values, error reporting, time, files, command line parsing,+terminals, pager output, ANSI colour/styles, etc.+-}++{-# LANGUAGE ImplicitParams      #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}++module Hledger.Utils.IO (++  -- * Pretty showing/printing+  pshow,+  pshow',+  pprint,+  pprint',++  -- * Errors+  error',+  usageError,+  warn,+  warnIO,+  ansiFormatError,+  ansiFormatWarning,+  printError,+  exitWithErrorMessage,+  handleExit,++  -- * Time+  getCurrentLocalTime,+  getCurrentZonedTime,++  -- * Files+  getHomeSafe,+  embedFileRelative,+  expandHomePath,+  expandPath,+  expandGlob,+  expandPathOrGlob,+  sortByModTime,+  openFileOrStdin,+  readFileOrStdinPortably,+  readFileOrStdinPortably',+  readFileStrictly,+  readFilePortably,+  hGetContentsPortably,+  -- hereFileRelative,+  textToHandle,++  -- * Command line parsing+  progArgs,+  getFlag,+  getOpt,+  parseYN,+  parseYNA,+  YNA(..),+  -- hasOutputFile,+  -- outputFileOption,++  -- * Terminal size+  getTerminalHeightWidth,+  getTerminalHeight,+  getTerminalWidth,++  -- * Pager output+  findPager,+  runPager,+  lessVarValue,+  lessIsWorking,++  -- * ANSI colour/styles++  -- ** hledger-specific++  colorOption,+  useColorOnStdout,+  useColorOnStderr,+  useColorOnStdoutUnsafe,+  useColorOnStderrUnsafe,+  bold',+  faint',+  black',+  red',+  green',+  yellow',+  blue',+  magenta',+  cyan',+  white',+  brightBlack',+  brightRed',+  brightGreen',+  brightYellow',+  brightBlue',+  brightMagenta',+  brightCyan',+  brightWhite',+  rgb',+  sgrresetall,++  -- ** Generic++  color,+  bgColor,+  colorB,+  bgColorB,+  -- XXX Types used with color/bgColor/colorB/bgColorB,+  -- not re-exported because clashing with UIUtils:+  -- Color(..),+  -- ColorIntensity(..),++  terminalIsLight,+  terminalLightness,+  terminalFgColor,+  terminalBgColor,++  )+where++import           Control.Concurrent (forkIO)+import           Control.Exception+import           Control.Monad (when, forM, guard, void)+import           Data.Char (toLower, isSpace)+import           Data.Colour.RGBSpace (RGB(RGB))+import           Data.Colour.RGBSpace.HSL (lightness)+import           Data.Colour.SRGB (sRGB)+import           Data.Encoding (DynEncoding)+import           Data.FileEmbed (makeRelativeToProject, embedStringFile)+import           Data.Functor ((<&>))+import           Data.List hiding (uncons)+import           Data.Maybe (isJust, catMaybes)+import Data.Text qualified as T+import           Data.Text.Encoding.Error (UnicodeException)+import Data.Text.IO qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import           Data.Time.Clock (getCurrentTime)+import           Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime)+import           Data.Word (Word16)+import           Debug.Trace+import           Foreign.C.Error (Errno(..), ePIPE)+import           GHC.IO.Encoding (getLocaleEncoding, textEncodingName)+import           GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished))+import           Language.Haskell.TH.Syntax (Q, Exp)+import           Safe (headMay, maximumDef)+import           System.Console.ANSI (Color(..),ColorIntensity(..), ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode, getLayerColor, ConsoleIntensity (..))+import           System.Console.Terminal.Size (Window (Window), size)+import           System.Directory (getHomeDirectory, getModificationTime, findExecutable)+import           System.Environment (getArgs, getEnvironment, lookupEnv, getProgName)+import           System.Exit (ExitCode(ExitSuccess), exitFailure)+import           System.FilePath (isRelative, (</>), takeBaseName)+import "Glob"    System.FilePath.Glob (glob)+import           System.Info (os)+import           System.IO (Handle, IOMode (..), hClose, hGetEncoding, hIsTerminalDevice, hPutStr, hPutStrLn, hSetNewlineMode, hSetEncoding, openFile, stderr, stdin, stdout, universalNewlineMode, utf8_bom, utf8)+import System.IO.Encoding qualified as Enc+import           System.IO.Unsafe (unsafePerformIO)+import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, proc, readCreateProcessWithExitCode, shell, waitForProcess, withCreateProcess)+import           System.Timeout (timeout)+import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)++import Hledger.Utils.Text (WideBuilder(WideBuilder))+import Control.Monad.IO.Class (MonadIO, liftIO)+++-- Pretty showing/printing+-- using pretty-simple++-- https://hackage.haskell.org/package/pretty-simple/docs/Text-Pretty-Simple.html#t:OutputOptions++-- | pretty-simple options with colour enabled if allowed.+prettyopts =+  (if useColorOnStderrUnsafe then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)+    { outputOptionsIndentAmount = 2+    -- , outputOptionsCompact      = True  -- fills lines, but does not respect page width (https://github.com/cdepillabout/pretty-simple/issues/126)+    -- , outputOptionsPageWidth    = fromMaybe 80 $ unsafePerformIO getTerminalWidth+    }++-- | pretty-simple options with colour disabled.+prettyoptsNoColor =+  defaultOutputOptionsNoColor+    { outputOptionsIndentAmount=2+    }++-- | Pretty show. An easier alias for pretty-simple's pShow.+-- This will probably show in colour if useColorOnStderrUnsafe is true.+pshow :: Show a => a -> String+pshow = TL.unpack . pShowOpt prettyopts++-- | Monochrome version of pshow. This will never show in colour.+pshow' :: Show a => a -> String+pshow' = TL.unpack . pShowOpt prettyoptsNoColor++-- | Pretty print a showable value. An easier alias for pretty-simple's pPrint.+-- This will print in colour if useColorOnStderrUnsafe is true.+pprint :: Show a => a -> IO ()+pprint = pPrintOpt (if useColorOnStderrUnsafe then CheckColorTty else NoCheckColorTty) prettyopts++-- | Monochrome version of pprint. This will never print in colour.+pprint' :: Show a => a -> IO ()+pprint' = pPrintOpt NoCheckColorTty prettyoptsNoColor++-- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)++++-- Errors++-- | Call errorWithoutStackTrace, prepending a "Error:" label.+error' :: String -> a+error' = errorWithoutStackTrace . ("Error: "<>)++-- | Like error', but add a hint about using -h.+usageError :: String -> a+usageError = error' . (++ " (use -h to see usage)")++-- | Apply standard ANSI SGR formatting (red, bold) suitable for console error text.+ansiFormatError :: String -> String+ansiFormatError = (<> sgrresetall) . ((sgrbrightred <> sgrbold) <>)++-- | Show a warning message on stderr before returning the given value.+-- Like trace, but prepends a "Warning:" label, and does some ANSI styling of the first line when allowed (using unsafe IO).+-- Currently we use this very sparingly in hledger; we prefer to either quietly work, or loudly raise an error.+-- Varying output can make scripting harder. But on stderr, it shouldn't cause much hassle.+warn :: String -> a -> a+warn = trace . formatWarning++-- | Like warn, but take extra care to sequence properly in IO.+warnIO :: MonadIO m => String -> m ()+warnIO = liftIO . traceIO . formatWarning++formatWarning =+  (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) .+  ("Warning: " <>)++-- | Apply standard ANSI SGR formatting (yellow, bold) suitable for console warning text.+ansiFormatWarning :: String -> String+ansiFormatWarning = (<> sgrresetall) . ((sgrbrightyellow <> sgrbold) <>)++-- Transform a string's first line.+-- Note, this won't add a trailing newline if there isn't one,+-- and it will remove one if there is one or more.+modifyFirstLine :: (String -> String) -> String -> String+modifyFirstLine f s = intercalate "\n" $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total++-- | Print an error message to stderr, with a consistent "programname: " prefix,+-- and applying ANSI styling (bold bright red) to the first line if that is supported and allowed.+printError :: String -> IO ()+printError msg = do+  progname <- getProgName+  usecolor <- useColorOnStderr+  let+    style = if usecolor then modifyFirstLine ansiFormatError else id+    prefix =+      progname+        <> ": "+        -- error' prepends an "Error: " prefix. But that seems to have been removed when I catch the ErrorCall exception - unless I'm running in GHCI.+        -- Is it possible something in GHC or base is removing it ?+        -- Use a stupid heuristic for now: add it again unless already there.+        <> (if "Error:" `isPrefixOf` msg then "" else "Error: ")+  hPutStrLn stderr $ style $ prefix <> msg++-- | Print an error message with printError,+-- then exit the program with a non-zero exit code.+exitWithErrorMessage :: String -> IO ()+exitWithErrorMessage msg = printError msg >> exitFailure++-- | This wraps a program's main routine so as to display more consistent,+-- useful, and GHC-version-independent error output when the program exits+-- because of certain common exceptions. It+--+-- 1. disables SIGPIPE errors, which are usually harmless,+--    caused when our output is truncated in a piped command.+--+-- 2. catches these common exceptions:+--+--    - UnicodeException, caused eg by text decoding errors in pure code+--+--    - IOException, caused by I/O errors, including text decoding errors during I/O+--+--    - ErrorCall - @error@ / @errorWithoutStackTrace@ calls+--+-- 3. compensates for GHC output bugs:+--+--    - removes the trailing newlines added by some GHC 9.10.* versions+--+--    - removes "uncaught exception" output added by some GHC 9.12.* versions+--+--    - ensures a consistent "PROGNAME: " prefix+--+-- 4. applies bold bright red ANSI styling to the first line of error output,+--    if that is supported and allowed+--+-- 5. for unicode exceptions and I/O exceptions which look like they were+--    unicode-related, it adds a message (in english) explaining the problem and what to do.+--+-- Some exceptions this does not catch are ExitCode (exitSuccess/exitFailure/exitWith)+-- and UserInterrupt (control-C).+--+handleExit :: IO () -> IO ()+handleExit = flip catches [+   -- Handler (\(e::SomeException) -> error' $ pshow e),  -- debug+   Handler (\(e::UnicodeException) -> exitUnicode e)+  ,Handler (\(e::IOException) -> if+    | isUnicodeError e    -> exitUnicode e+    | otherwise           -> exitOther e)+  ,Handler (\(e::ErrorCall) -> exitOther e)+  ] . ignoreSigPipe++  where+    -- | Ignore SIGPIPE errors.+    -- This is copied from System.Process.Internals in process 1.6.20.0+,+    -- since that version of process comes only with ghc 9.10.2+.+    ignoreSigPipe :: IO () -> IO ()+    ignoreSigPipe = handle $ \e -> case e of+      IOError { ioe_type  = ResourceVanished+              , ioe_errno = Just ioe }+        | Errno ioe == ePIPE -> return ()+      _ -> throwIO e++    -- Many decoding failures do not produce a UnicodeException, unfortunately.+    -- So this fragile hack detects them from the error message.+    -- But there are many variant wordings and they probably change over time.+    -- It's not ideal.+    isUnicodeError :: Exception e => e -> Bool+    isUnicodeError ex =+      let msg = map toLower (show ex) in any (`isInfixOf` msg) [+          "illegal byte sequence"+        , "invalid byte sequence"+        , "cannot decode byte sequence"+        , "invalid character"+        , "invalid or incomplete multibyte"+        , "mkTextEncoding: invalid argument"+        ]++    exitUnicode :: Exception e => e -> IO ()+    exitUnicode ex = do+      enc <- getSystemEncoding+      let+        noencoding = map toLower enc == "ascii"+        msg = unlines $ [+            rstrip $ show ex+          , "Some text could not be decoded with the system's text encoding, " <> enc+          , "(or, the text encoding specified by CSV rules)."+          ] +++          if noencoding+          then [+            "Please configure a system locale which can decode this text."+          ]+          else [+            "Please either convert the text to this encoding,"+          , "or configure a system locale which can decode this text."+          ]+      exitWithErrorMessage msg++    exitOther :: Exception e => e -> IO ()+    exitOther = exitWithErrorMessage . rstrip . show++    rstrip = reverse . dropWhile isSpace . reverse++-- I18n++-- encoding has a similar getSystemEncoding :: IO (Maybe DynEncoding)+-- but it returns Nothing on Windows or if there's an error.++-- | Get the name of the text encoding used by the current locale, using GHC's API.+getSystemEncoding :: IO String+getSystemEncoding = do+  localeEncoding <- getLocaleEncoding+  return $ textEncodingName localeEncoding++-- -- | Get the name of the text encoding currently configured for stdout, using GHC's API.+-- getStdoutEncoding :: IO (Maybe String)+-- getStdoutEncoding = do+--   mEncoding <- hGetEncoding stdout+--   return $ fmap textEncodingName mEncoding++-- Time++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToLocalTime tz t++getCurrentZonedTime :: IO ZonedTime+getCurrentZonedTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToZonedTime tz t++++-- Files++-- | Like getHomeDirectory, but in case of IO error (home directory not found, not understood, etc.), returns "".+getHomeSafe :: IO (Maybe FilePath)+getHomeSafe = fmap Just getHomeDirectory `catch` (\(_ :: IOException) -> return Nothing)++-- | Expand a single tilde (representing home directory) at the start of a file path.+-- ~username is not supported. This can raise an IO error.+expandHomePath :: FilePath -> IO FilePath+expandHomePath = \case+    "~"          -> getHomeDirectory+    ('~':'/':p)  -> (</> p) <$> getHomeDirectory+    ('~':'\\':p) -> (</> p) <$> getHomeDirectory+    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"+    p            -> return p++-- | Given a current directory, convert a possibly relative, possibly tilde-prefixed+-- file path to an absolute one.+-- ~username is not supported.+-- If the file path is "-", it is left as-is.+-- This can an raise an IO error.+expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers+expandPath _ "-" = return "-"+expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL:++-- | Like @expandPath@, but treats the expanded path as a glob, and returns+-- zero or more matched absolute file paths, alphabetically sorted.+-- Can raise an error.+-- For a more elaborate glob expander, see 'findMatchedFiles' (used by the include directive).+expandGlob :: FilePath -> FilePath -> IO [FilePath]+expandGlob curdir p = expandPath curdir p >>= glob <&> sort  -- PARTIAL:++-- | Like expandPath, but if the path contains glob metacharacters (* ? [ {),+-- treats it as a glob pattern and expands it, returning the first match.+-- Raises an error if the glob pattern matches no files.+-- If the path contains no glob metacharacters, just expands ~ and returns the path,+-- even if the file doesn't exist yet.+-- This is useful for options like -f and LEDGER_FILE that should:+-- - accept non-existent files (for commands like add/import that create them)+-- - expand glob patterns and error if they don't match anything+expandPathOrGlob :: FilePath -> FilePath -> IO FilePath+expandPathOrGlob curdir p = do+  let hasGlobChars = any (`elem` p) ("*?[{" :: [Char])+  if hasGlobChars+    then do+      matches <- expandGlob curdir p `catch` (\(_::IOException) -> return [])+      case headMay matches of+        Just f -> return f+        Nothing -> error' $ "glob pattern \"" <> p <> "\" matched no files"+    else+      expandPath curdir p++-- | Given a list of existing file paths, sort them by modification time (from oldest to newest).+sortByModTime :: [FilePath] -> IO [FilePath]+sortByModTime fs = do+  ftimes <- forM fs $ \f -> do {t <- getModificationTime f; return (t,f)}+  return $ map snd $ sort ftimes++-- | Like readFilePortably, but read all of the file before proceeding.+readFileStrictly :: FilePath -> IO T.Text+readFileStrictly f = readFilePortably f >>= \t -> evaluate (T.length t) >> return t++-- | Read text from a file,+-- converting any \r\n line endings to \n,,+-- using the system locale's text encoding,+-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.+readFilePortably :: FilePath -> IO T.Text+readFilePortably f = openFile f ReadMode >>= hGetContentsPortably Nothing++-- | Like readFilePortably, but read from standard input if the path is "-".+readFileOrStdinPortably :: String -> IO T.Text+readFileOrStdinPortably = readFileOrStdinPortably' Nothing++-- | Like readFileOrStdinPortably, but take an optional converter.+readFileOrStdinPortably' :: Maybe DynEncoding -> String -> IO T.Text+readFileOrStdinPortably' c f = openFileOrStdin f >>= hGetContentsPortably c++-- | Open a file for reading, using the standard System.IO.openFile.+-- This opens the handle in text mode, using the initial system locale's text encoding.+openFileOrStdin :: String -> IO Handle+openFileOrStdin "-" = return stdin+openFileOrStdin f' = openFile f' ReadMode++-- | Read text from a handle, perhaps using a specified encoding from the encoding package.+-- Or if no encoding is specified, using the handle's current encoding,+-- changing it to UTF-8BOM if it was UTF-8, to ignore any Byte Order Mark at the start.+-- Also it converts Windows line endings to newlines.+-- If decoding fails, this throws an IOException (or possibly a UnicodeException or something else from the encoding package).+hGetContentsPortably :: Maybe DynEncoding -> Handle -> IO T.Text+hGetContentsPortably Nothing h = do+  hSetNewlineMode h universalNewlineMode+  menc <- hGetEncoding h+  when (fmap show menc == Just "UTF-8") $ hSetEncoding h utf8_bom+  T.hGetContents h+hGetContentsPortably (Just e) h =+  -- convert newlines manually, because Enc.hGetContents uses bytestring's hGetContents+  T.replace "\r\n" "\n" . T.pack <$> let ?enc = e in Enc.hGetContents h++-- | Create a handle from which the given text can be read. Its encoding will be UTF-8.+textToHandle :: T.Text -> IO Handle+textToHandle t = do+  (r, w) <- createPipe+  hSetEncoding r utf8+  hSetEncoding w utf8+  -- use a separate thread so that we don't deadlock if we can't write all of the text at once+  forkIO $ T.hPutStr w t >> hClose w+  return r++-- | Like embedFile, but takes a path relative to the package directory.+embedFileRelative :: FilePath -> Q Exp+embedFileRelative f = makeRelativeToProject f >>= embedStringFile++-- -- | Like hereFile, but takes a path relative to the package directory.+-- -- Similar to embedFileRelative ?+-- hereFileRelative :: FilePath -> Q Exp+-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp+--   where+--     QuasiQuoter{quoteExp=hereFileExp} = hereFile++++-- Command line parsing++-- | The program's command line arguments.+-- Uses unsafePerformIO; tends to stick in GHCI until reloaded,+-- and may or may not detect args provided by a hledger config file.+{-# NOINLINE progArgs #-}+progArgs :: [String]+progArgs = unsafePerformIO getArgs+-- XX currently this affects:+--  the enabling of orderdates and assertions checks in journalFinalise+--  a few cases involving --color (see useColorOnStdoutUnsafe)+--  --debug++-- | Given one or more long or short flag names,+-- report whether this flag is present in the command line.+-- Concatenated short flags (-a -b written as -ab) are not supported.+getFlag :: [String] -> IO Bool+getFlag names = do+  let flags = map toFlag names+  args <- getArgs+  return $ any (`elem` args) flags++-- | Given one or more long or short option names, read the rightmost value of this option from the command line arguments.+-- If the value is missing raise an error.+-- Concatenated short flags (-a -b written as -ab) are not supported.+getOpt :: [String] -> IO (Maybe String)+getOpt names = do+  rargs <- reverse . splitFlagsAndVals <$> getArgs+  let flags = map toFlag names+  return $+    case break ((`elem` flags)) rargs of+      (_,[])        -> Nothing+      ([],flag:_)   -> error' $ flag <> " requires a value"+      (argsafter,_) -> Just $ last argsafter++-- | Given a list of command line arguments, split any of the form --flag=VAL or -fVAL into two list items.+-- Concatenated short flags (-a -b written as -ab) are not supported.+splitFlagsAndVals :: [String] -> [String]+splitFlagsAndVals = concatMap $+  \case+    a@('-':'-':_) | '=' `elem` a -> let (x,y) = break (=='=') a in [x, drop 1 y]+    a@('-':f:_:_) | not $ f=='-' -> [take 2 a, drop 2 a]+    a -> [a]++-- | Convert a short or long flag name to a flag with leading hyphen(s).+toFlag [c] = ['-',c]+toFlag s   = '-':'-':s++-- | Parse y/yes/always or n/no/never to true or false, or return an error message.+parseYN :: String -> Either String Bool+parseYN s+  | l `elem` ["y","yes","always"] = Right True+  | l `elem` ["n","no","never"]   = Right False+  | otherwise = Left $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])+  where l = map toLower s++data YNA = Yes | No | Auto deriving (Eq,Show)++-- | Parse y/yes/always or n/no/never or a/auto to a YNA choice, or return an error message.+parseYNA :: String -> Either String YNA+parseYNA s+  | l `elem` ["y","yes","always"] = Right Yes+  | l `elem` ["n","no","never"]   = Right No+  | l `elem` ["a","auto"]         = Right Auto+  | otherwise = Left $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])+  where l = map toLower s++-- | Is there a --output-file or -o option in the command line arguments ?+-- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.+hasOutputFile :: IO Bool+hasOutputFile = do+  mv <- getOpt ["output-file","o"]+  return $+    case mv of+      Nothing  -> False+      Just "-" -> False+      _        -> True++-- -- | Get the -o/--output-file option's value, if any, from the command line arguments.+-- -- Uses getOpt; sticky in GHCI until reloaded, may not always be affected by a hledger config file, etc.+-- outputFileOption :: IO (Maybe String)+-- outputFileOption = getOpt ["output-file","o"]++++-- Terminal size++-- [NOTE: Alternative methods of getting the terminal size]+-- terminal-size uses the TIOCGWINSZ ioctl to get the window size on Unix+-- systems, which may not be completely portable according to people in+-- #linux@liberachat.+--+-- If this turns out to be the case, supplementary coverage can be given by+-- using the terminfo package.+--+-- Conversely, terminfo on its own is not a full solution, firstly because it+-- only works on Unix (not Windows), and secondly since in some scenarios (eg+-- stripped-down build systems) the terminfo database may be limited and lack+-- the correct entries. (A hack that sometimes works but which isn't robust+-- enough to be relied upon is to set TERM=dumb -- while this advice does appear+-- in some places, it's not guaranteed to work)+--+-- In any case, $LINES/$COLUMNS should not be used as a source for the terminal+-- size - they are not available or do not update reliably in all shells.+--+-- See #2332 for details++-- | An alternative to ansi-terminal's getTerminalSize, based on+-- the more robust-looking terminal-size package.+--+-- Tries to get stdout's terminal's current height and width.+getTerminalHeightWidth :: IO (Maybe (Int,Int))+getTerminalHeightWidth = fmap (fmap unwindow) size+  where unwindow (Window h w) = (h,w)++getTerminalHeight :: IO (Maybe Int)+getTerminalHeight = fmap fst <$> getTerminalHeightWidth++getTerminalWidth :: IO (Maybe Int)+getTerminalWidth  = fmap snd <$> getTerminalHeightWidth++++-- Pager output+-- somewhat hledger-specific++-- | Try to find a pager executable robustly, safely handling various error conditions+-- like an unset PATH var or the specified pager not being found as an executable.+-- The pager can be specified by a path or program name in the PAGER environment variable.+-- If that is unset or has a problem, "less" is tried, then "more".+-- If successful, the pager's path or program name is returned.+findPager :: IO (Maybe String)  -- XXX probably a ByteString in fact ?+findPager = do+  mpagervar <- lookupEnv "PAGER"+  let pagers = [p | Just p <- [mpagervar]] <> ["less", "more"]+  headMay . catMaybes <$> mapM findExecutable pagers++-- | Should a pager be used for displaying the given text on stdout, and if so, which one ?+-- Uses a pager if findPager finds one and none of the following conditions are true:+-- We're running in a native MS Windows environment like cmd or powershell.+-- Or the --pager=n|no option is in effect.+-- Or the -o/--output-file option is in effect.+-- Or INSIDE_EMACS is set, to something other than "vterm".+-- Or the terminal's current height and width can't be detected.+-- Or the output text is less wide and less tall than the terminal.+-- Throws an error if the --pager option's value could not be parsed.+maybePagerFor :: String -> IO (Maybe String)+maybePagerFor output = do+  let+    ls = lines output+    oh = length ls+    ow = maximumDef 0 $ map length ls+    windows = os == "mingw32"+  pagerno    <- maybe False (not . either error' id . parseYN) <$> getOpt ["pager"]+  outputfile <- hasOutputFile+  emacsterm  <- lookupEnv "INSIDE_EMACS" <&> (`notElem` [Nothing, Just "vterm"])+  mhw        <- getTerminalHeightWidth+  mpager     <- findPager+  return $ do+    guard $ not $ windows || pagerno || outputfile || emacsterm+    (th,tw) <- mhw+    guard $ oh > th || ow > tw+    mpager++-- | Display the given text on the terminal, trying to use a pager ($PAGER, less, or more)+-- when appropriate (see maybePagerFor), otherwise printing to standard output.+-- Also, if the pager is less, we modify the LESS environment variable (see lessVarValue)+-- and check for problems which could cause confusing output (see lessIsWorking).+runPager :: String -> IO ()+runPager s = do+  mpager <- maybePagerFor s+  case mpager of+    Nothing -> putStr s+    Just pager -> do++      -- If using less, customise the LESS environment variable and check if it works+      let pagerIsLess = map toLower (takeBaseName pager) == "less"+      (mCustomEnv, shouldUsePager) <- if not pagerIsLess+        then return (Nothing, True)+        else do+          mHLEDGER_LESS <- lookupEnv "HLEDGER_LESS"+          mLESS         <- lookupEnv "LESS"+          usecolor      <- useColorOnStdout+          let newlessvar = lessVarValue mHLEDGER_LESS mLESS usecolor+          env <- getEnvironment+          let customEnv = ("LESS", newlessvar) : filter ((/= "LESS") . fst) env+          -- Check that less --version is working (using our custom LESS) (#2544)+          lessHasError <- lessIsWorking (Just customEnv) `catch` \(_::IOException) -> return True+          when lessHasError $ warnIO $+            "less --version fails with current LESS settings; disabling. Check 'hledger setup' for details.\n"+          return (Just customEnv, not lessHasError)++      -- Run the pager, providing the text as input. Or if we found a problem already, just print.+      if not shouldUsePager+        then putStr s+        else (withCreateProcess (shell pager){std_in=CreatePipe, env=mCustomEnv} $+          \mhin _ _ p -> do+            case mhin of+              Nothing  -> fail "Failed to create pipe to pager"+              Just hin -> void $ forkIO $   -- Write from another thread to avoid deadlock ? Maybe unneeded, but just in case.+                (hPutStr hin s >> hClose hin)  -- Be sure to close the pipe so the pager knows we're done.+                  -- If the pager quits early, we'll receive an EPIPE error; hide that.+                  `catch` \(e::IOException) -> case e of+                    IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe, ioe_handle=Just hdl} | Errno ioe==ePIPE, hdl==hin -> return ()+                    _ -> throwIO e+            void $ waitForProcess p)+          `catch` \(_::IOException) -> putStr s++-- | Test @less@, by running less --version and looking for a nonzero exit, timeout, or stderr output.+-- Uses the provided environment, containing a LESS variable, if any.+-- We do this because various LESS settings can cause some less versions to fail or cause confusing output without failing.+lessIsWorking :: Maybe [(String, String)] -> IO Bool+lessIsWorking mCustomEnv = do+  result <- timeout 300000 $ readCreateProcessWithExitCode (proc "less" ["--version"]){env=mCustomEnv} ""+  return $ case result of+    Nothing -> True  -- Timeout+    Just (exitCode, _, stderrOut) -> exitCode /= ExitSuccess || not (null stderrOut)++-- | Compute the LESS environment variable value that hledger will use for the less pager.+-- This used in runPager when invoking less, and also in the setup command for display.+-- It takes the current HLEDGER_LESS and LESS env var values, and whether we are showing colour on stdout,+-- and returns the adjusted LESS value that should be used. Specifically:+--+-- - If HLEDGER_LESS is defined, we use it in place of the LESS environment variable.+--+-- - Otherwise, if LESS is defined, append some preferred options (lessOptions and maybe lessColourOptions) to it.+--+-- - Otherwise, we set LESS to just use those preferred options.+--+lessVarValue :: Maybe String -> Maybe String -> Bool -> String+lessVarValue mHLEDGER_LESS mLESS usecolor =+  let extralessopts = unwords $ [lessOptions] <> [lessColourOptions | usecolor]+  in case (mHLEDGER_LESS, mLESS) of+       (Just hledgerlessvar, _) -> hledgerlessvar+       (_, Just lessvar) -> if extralessopts `isInfixOf` lessvar then lessvar else unwords [lessvar, extralessopts]+       _ -> extralessopts++-- keep synced: hledger.m4.md > Paging+-- | hledger's preferred less options, which it will append to the user's LESS environment variable.+-- The thinking here is: "Many people don't have their LESS optimised to get the best experience from modern less, as I didn't.+-- Also as they use hledger on different machines, LESS is likely not consistent. +-- So let's add some settings that I have found reasonably robust, compatible, and good for usability.+-- That will help provide a consistent good experience when viewing hledger's long outputs.+-- And power users can prevent this by setting exactly the options they want in HLEDGER_LESS."+-- Here's what they mean: https://manned.org/man/less#head5+--+-- Flags that might break older less versions (causing hledger to fall back to unpaged output) are avoided here.+-- Such as --mouse and --wheel-lines (less >=530, 2018) and --use-color (less >=551, 2019).+-- --hilite-unread (less >=443, 2011) is useful and considered old enough.+--+lessOptions = unwords [+   "--chop-long-lines"+  ,"--hilite-unread"+  ,"--ignore-case"+  ,"--no-init"+  ,"--quit-if-one-screen"+  ,"--shift=8"+  ,"--squeeze-blank-lines"+  ,"--use-backslash"+  ] ++-- | Additional less options to use if we are showing colour on stdout.+lessColourOptions = unwords [+   "--RAW-CONTROL-CHARS"+  ]+++-- ANSI colour/styles+-- Some of these use unsafePerformIO to read info.++-- hledger-specific:++-- | Get the value of the rightmost --color or --colour option from the program's command line arguments.+-- Throws an error if the option's value could not be parsed.+colorOption :: IO YNA+colorOption = maybe Auto (either error' id . parseYNA) <$> getOpt ["color","colour"]++-- | Should ANSI color and styles be used with this output handle ?+-- Considers colorOption, the NO_COLOR environment variable, and hSupportsANSIColor.+useColorOnHandle :: Handle -> IO Bool+useColorOnHandle h = do+  no_color       <- isJust <$> lookupEnv "NO_COLOR"+  supports_color <- hSupportsANSIColor h+  yna            <- colorOption+  return $ yna==Yes || (yna==Auto && not no_color && supports_color)++-- | Should ANSI color and styles be used for standard output ?+-- Considers useColorOnHandle stdout and hasOutputFile.+useColorOnStdout :: IO Bool+useColorOnStdout = do+  nooutputfile <- not <$> hasOutputFile+  usecolor <- useColorOnHandle stdout+  return $ nooutputfile && usecolor++-- | Should ANSI color and styles be used for standard error output ?+-- Considers useColorOnHandle stderr; is not affected by an --output-file option.+useColorOnStderr :: IO Bool+useColorOnStderr = useColorOnHandle stderr++-- | Like useColorOnStdout, but using unsafePerformIO. Useful eg for low-level debug code.+-- Sticky in GHCI until reloaded, may not always be affected by --color in a hledger config file, etc.+useColorOnStdoutUnsafe :: Bool+useColorOnStdoutUnsafe = unsafePerformIO useColorOnStdout++-- | Like useColorOnStdoutUnsafe, but for stderr.+useColorOnStderrUnsafe :: Bool+useColorOnStderrUnsafe = unsafePerformIO useColorOnStderr++-- | Detect whether ANSI should be used on stdout using useColorOnStdoutUnsafe,+-- and if so prepend and append the given SGR codes to a string.+-- Currently used in a few places (the commands list, the recentassertions error message, add, demo);+-- see useColorOnStdoutUnsafe's limitations.+ansiWrapUnsafe :: SGRString -> SGRString -> String -> String+ansiWrapUnsafe pre post s = if useColorOnStdoutUnsafe then pre<>s<>post else s++type SGRString = String++sgrbold          = setSGRCode [SetConsoleIntensity BoldIntensity]+sgrfaint         = setSGRCode [SetConsoleIntensity FaintIntensity]+sgrnormal        = setSGRCode [SetConsoleIntensity NormalIntensity]+sgrresetfg       = setSGRCode [SetDefaultColor Foreground]+sgrresetbg       = setSGRCode [SetDefaultColor Background]+sgrresetall      = sgrresetfg <> sgrresetbg <> sgrnormal+sgrblack         = setSGRCode [SetColor Foreground Dull Black]+sgrred           = setSGRCode [SetColor Foreground Dull Red]+sgrgreen         = setSGRCode [SetColor Foreground Dull Green]+sgryellow        = setSGRCode [SetColor Foreground Dull Yellow]+sgrblue          = setSGRCode [SetColor Foreground Dull Blue]+sgrmagenta       = setSGRCode [SetColor Foreground Dull Magenta]+sgrcyan          = setSGRCode [SetColor Foreground Dull Cyan]+sgrwhite         = setSGRCode [SetColor Foreground Dull White]+sgrbrightblack   = setSGRCode [SetColor Foreground Vivid Black]+sgrbrightred     = setSGRCode [SetColor Foreground Vivid Red]+sgrbrightgreen   = setSGRCode [SetColor Foreground Vivid Green]+sgrbrightyellow  = setSGRCode [SetColor Foreground Vivid Yellow]+sgrbrightblue    = setSGRCode [SetColor Foreground Vivid Blue]+sgrbrightmagenta = setSGRCode [SetColor Foreground Vivid Magenta]+sgrbrightcyan    = setSGRCode [SetColor Foreground Vivid Cyan]+sgrbrightwhite   = setSGRCode [SetColor Foreground Vivid White]+sgrrgb r g b     = setSGRCode [SetRGBColor Foreground $ sRGB r g b]++-- | Set various ANSI styles/colours in a string, only if useColorOnStdoutUnsafe says we should.+bold' :: String -> String+bold'  = ansiWrapUnsafe sgrbold sgrnormal++faint' :: String -> String+faint'  = ansiWrapUnsafe sgrfaint sgrnormal++black' :: String -> String+black'  = ansiWrapUnsafe sgrblack sgrresetfg++red' :: String -> String+red'  = ansiWrapUnsafe sgrred sgrresetfg++green' :: String -> String+green'  = ansiWrapUnsafe sgrgreen sgrresetfg++yellow' :: String -> String+yellow'  = ansiWrapUnsafe sgryellow sgrresetfg++blue' :: String -> String+blue'  = ansiWrapUnsafe sgrblue sgrresetfg++magenta' :: String -> String+magenta'  = ansiWrapUnsafe sgrmagenta sgrresetfg++cyan' :: String -> String+cyan'  = ansiWrapUnsafe sgrcyan sgrresetfg++white' :: String -> String+white'  = ansiWrapUnsafe sgrwhite sgrresetfg++brightBlack' :: String -> String+brightBlack'  = ansiWrapUnsafe sgrbrightblack sgrresetfg++brightRed' :: String -> String+brightRed'  = ansiWrapUnsafe sgrbrightred sgrresetfg++brightGreen' :: String -> String+brightGreen'  = ansiWrapUnsafe sgrbrightgreen sgrresetfg++brightYellow' :: String -> String+brightYellow'  = ansiWrapUnsafe sgrbrightyellow sgrresetfg++brightBlue' :: String -> String+brightBlue'  = ansiWrapUnsafe sgrbrightblue sgrresetfg++brightMagenta' :: String -> String+brightMagenta'  = ansiWrapUnsafe sgrbrightmagenta sgrresetfg++brightCyan' :: String -> String+brightCyan'  = ansiWrapUnsafe sgrbrightcyan sgrresetfg++brightWhite' :: String -> String+brightWhite'  = ansiWrapUnsafe sgrbrightwhite sgrresetfg++rgb' :: Float -> Float -> Float -> String -> String+rgb' r g b  = ansiWrapUnsafe (sgrrgb r g b) sgrresetfg++-- Generic:++-- | Wrap a string in ANSI codes to set and reset foreground colour.+-- ColorIntensity is @Dull@ or @Vivid@ (ie normal and bold).+-- Color is one of @Black@, @Red@, @Green@, @Yellow@, @Blue@, @Magenta@, @Cyan@, @White@.+-- Eg: @color Dull Red "text"@.+color :: ColorIntensity -> Color -> String -> String+color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []++-- | Wrap a string in ANSI codes to set and reset background colour.+bgColor :: ColorIntensity -> Color -> String -> String+bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []++-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.+colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder+colorB int col (WideBuilder s w) =+    WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w++-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.+bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder+bgColorB int col (WideBuilder s w) =+    WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w+++-- | Detect whether the terminal currently has a light background colour,+-- if possible, using unsafePerformIO.+-- If the terminal is transparent, its apparent light/darkness may be different.+terminalIsLight :: Maybe Bool+terminalIsLight = (> 0.5) <$> terminalLightness++-- | Detect the terminal's current background lightness (0..1), if possible, using unsafePerformIO.+-- If the terminal is transparent, its apparent lightness may be different.+terminalLightness :: Maybe Float+terminalLightness = lightness <$> terminalColor Background++-- | Detect the terminal's current background colour, if possible, using unsafePerformIO.+terminalBgColor :: Maybe (RGB Float)+terminalBgColor = terminalColor Background++-- | Detect the terminal's current foreground colour, if possible, using unsafePerformIO.+terminalFgColor :: Maybe (RGB Float)+terminalFgColor = terminalColor Foreground++-- | Detect the terminal's current foreground or background colour, if possible, using unsafePerformIO.+{-# NOINLINE terminalColor #-}+terminalColor :: ConsoleLayer -> Maybe (RGB Float)+terminalColor = unsafePerformIO . getLayerColor'++-- A version of ansi-terminal's getLayerColor that is less likely to leak escape sequences to output,+-- and that returns a RGB of Floats (0..1) that is more compatible with the colour package.+-- This does nothing in a non-interactive context (eg when piping stdout to another command),+-- inside emacs (emacs shell buffers show the escape sequence for some reason),+-- or in a non-colour-supporting terminal.+getLayerColor' :: ConsoleLayer -> IO (Maybe (RGB Float))+getLayerColor' l = do+  inemacs       <- not.null <$> lookupEnv "INSIDE_EMACS"+  interactive   <- hIsTerminalDevice stdout+  supportscolor <- hSupportsANSIColor stdout+  if inemacs || not interactive || not supportscolor then return Nothing+  else fmap fractionalRGB <$> getLayerColor l+  where+    fractionalRGB :: (Fractional a) => RGB Word16 -> RGB a+    fractionalRGB (RGB r g b) = RGB (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)  -- chatgpt+
Hledger/Utils/Parse.hs view
@@ -1,17 +1,34 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Hledger.Utils.Parse (++  -- * Some basic hledger parser flavours   SimpleStringParser,   SimpleTextParser,   TextParser,-  JournalParser,-  ErroringJournalParser, +  -- * SourcePos+  SourcePos(..),+  mkPos,+  unPos,+  initialPos,+  sourcePosPretty,+  sourcePosPairPretty,++  -- * Parsers and helpers   choice',   choiceInState,   surroundedBy,   parsewith,+  runTextParser,+  rtp,   parsewithString,   parseWithState,   parseWithState',@@ -19,47 +36,117 @@   parseerror,   showDateParseError,   nonspace,+  isNewline,   isNonNewlineSpace,-  spacenonewline,   restofline,   eolof,+  spacenonewline,+  skipNonNewlineSpaces,+  skipNonNewlineSpaces1,+  skipNonNewlineSpaces', -  -- * re-exports-  CustomErr+  -- ** Trace the state of hledger parsers+  dbgparse,++  -- * More helpers, previously in Text.Megaparsec.Custom++  -- ** Custom parse error types+  HledgerParseErrorData,+  HledgerParseErrors,++  -- ** Failing with an arbitrary source position+  parseErrorAt,+  parseErrorAtRegion,++  -- ** Re-parsing+  SourceExcerpt,+  getExcerptText,+  excerpt_,+  reparseExcerpt,++  -- ** Pretty-printing custom parse errors+  customErrorBundlePretty,++  -- ** "Final" parse errors+  FinalParseError,+  FinalParseError',+  FinalParseErrorBundle,+  FinalParseErrorBundle',++  -- *** Constructing "final" parse errors+  finalError,+  finalFancyFailure,+  finalFail,+  finalCustomFailure,++  -- *** Pretty-printing "final" parse errors+  finalErrorBundlePretty,+  attachSource,++  -- *** Handling parse errors from include files with "final" parse errors+  parseIncludeFile,+ ) where -import Control.Monad.Except (ExceptT)+import Control.Monad (when)+import Data.Text qualified as T+import Safe (tailErr)+import Text.Megaparsec+import Text.Printf import Control.Monad.State.Strict (StateT, evalStateT) import Data.Char+import Data.Functor (void) import Data.Functor.Identity (Identity(..)) import Data.List import Data.Text (Text)-import Text.Megaparsec import Text.Megaparsec.Char-import Text.Megaparsec.Custom-import Text.Printf+-- import Text.Megaparsec.Debug (dbg) -import Hledger.Data.Types-import Hledger.Utils.UTF8IOCompat (error')+import Control.Monad.Except (ExceptT, MonadError, catchError, throwError)+import Control.Monad.Trans.Class (lift)+import Data.List.NonEmpty qualified as NE+import Data.Monoid (Alt(..))+import Data.Set qualified as S +import Hledger.Utils.Debug (debugLevel, dbg0Msg)+ -- | A parser of string to some type.-type SimpleStringParser a = Parsec CustomErr String a+type SimpleStringParser a = Parsec HledgerParseErrorData String a  -- | A parser of strict text to some type.-type SimpleTextParser = Parsec CustomErr Text  -- XXX an "a" argument breaks the CsvRulesParser declaration somehow+type SimpleTextParser = Parsec HledgerParseErrorData Text  -- XXX an "a" argument breaks the CsvRulesParser declaration somehow --- | A parser of text in some monad.-type TextParser m a = ParsecT CustomErr Text m a+-- | A parser of text that runs in some monad.+type TextParser m a = ParsecT HledgerParseErrorData Text m a --- | A parser of text in some monad, with a journal as state.-type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a+-- class (Stream s, MonadPlus m) => MonadParsec e s m +-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m () --- | A parser of text in some monad, with a journal as state, that can throw a--- "final" parse error that does not backtrack.-type ErroringJournalParser m a =-  StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a+-- | Trace to stderr or log to debug log the provided label (if non-null)+-- and current parser state (position and next input),+-- if the global debug level is at or above the specified level.+-- See also: Hledger.Utils.Debug, megaparsec's dbg.+-- Uses unsafePerformIO.+-- XXX Can be hard to make this evaluate.+dbgparse :: Int -> String -> TextParser m ()+dbgparse level msg = when (level <= debugLevel) $ do+  pos <- getSourcePos+  next <- (T.take peeklength) `fmap` getInput+  let (l,c) = (sourceLine pos, sourceColumn pos)+      s  = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String+      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg+  dbg0Msg s' $ return ()+  where+    peeklength = 30 +-- | Render a pair of source positions in human-readable form, only displaying the range of lines.+sourcePosPairPretty :: (SourcePos, SourcePos) -> String+sourcePosPairPretty (SourcePos fp l1 _, SourcePos _ l2 c2) =+    fp ++ ":" ++ show (unPos l1) ++ "-" ++ show l2'+  where+    l2' = if unPos c2 == 1 then unPos l2 - 1 else unPos l2  -- might be at end of file with a final new line+ -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail. choice' :: [TextParser m a] -> TextParser m a@@ -67,7 +154,7 @@  -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail.-choiceInState :: [StateT s (ParsecT CustomErr Text m) a] -> StateT s (ParsecT CustomErr Text m) a+choiceInState :: [StateT s (ParsecT HledgerParseErrorData Text m) a] -> StateT s (ParsecT HledgerParseErrorData Text m) a choiceInState = choice . map try  surroundedBy :: Applicative m => m openclose -> m a -> m a@@ -76,8 +163,12 @@ parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a parsewith p = runParser p "" -parsewithString-  :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a+-- | Run a text parser in the identity monad. See also: parseWithState.+runTextParser, rtp :: TextParser Identity a -> Text -> Either HledgerParseErrors a+runTextParser = parsewith+rtp = runTextParser++parsewithString :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a parsewithString p = runParser p ""  -- | Run a stateful parser with some initial state on a text.@@ -85,10 +176,10 @@ parseWithState   :: Monad m   => st-  -> StateT st (ParsecT CustomErr Text m) a+  -> StateT st (ParsecT HledgerParseErrorData Text m) a   -> Text-  -> m (Either (ParseErrorBundle Text CustomErr) a)-parseWithState ctx p s = runParserT (evalStateT p ctx) "" s+  -> m (Either HledgerParseErrors a)+parseWithState ctx p = runParserT (evalStateT p ctx) ""  parseWithState'   :: (Stream s)@@ -96,35 +187,407 @@   -> StateT st (ParsecT e s Identity) a   -> s   -> (Either (ParseErrorBundle s e) a)-parseWithState' ctx p s = runParser (evalStateT p ctx) "" s+parseWithState' ctx p = runParser (evalStateT p ctx) "" -fromparse-  :: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a+fromparse :: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a fromparse = either parseerror id  parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a-parseerror e = error' $ showParseError e+parseerror e = errorWithoutStackTrace $ showParseError e  -- PARTIAL: -showParseError-  :: (Show t, Show (Token t), Show e)-  => ParseErrorBundle t e -> String+showParseError :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String showParseError e = "parse error at " ++ show e -showDateParseError-  :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String-showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)+showDateParseError :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String+showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tailErr $ lines $ show e)  -- PARTIAL tailError won't be null because showing a parse error +isNewline :: Char -> Bool +isNewline '\n' = True+isNewline _    = False+ nonspace :: TextParser m Char nonspace = satisfy (not . isSpace)  isNonNewlineSpace :: Char -> Bool-isNonNewlineSpace c = c /= '\n' && isSpace c+isNonNewlineSpace c = not (isNewline c) && isSpace c -spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char+spacenonewline :: (Stream s, Char ~ Token s) => ParsecT HledgerParseErrorData s m Char spacenonewline = satisfy isNonNewlineSpace+{-# INLINABLE spacenonewline #-}  restofline :: TextParser m String-restofline = anySingle `manyTill` newline+restofline = anySingle `manyTill` eolof +-- Skip many non-newline spaces.+skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()+skipNonNewlineSpaces = void $ takeWhileP Nothing isNonNewlineSpace+{-# INLINABLE skipNonNewlineSpaces #-}++-- Skip many non-newline spaces, failing if there are none.+skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()+skipNonNewlineSpaces1 = void $ takeWhile1P Nothing isNonNewlineSpace+{-# INLINABLE skipNonNewlineSpaces1 #-}++-- Skip many non-newline spaces, returning True if any have been skipped.+skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m Bool+skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False+{-# INLINABLE skipNonNewlineSpaces' #-}+ eolof :: TextParser m ()-eolof = (newline >> return ()) <|> eof+eolof = void newline <|> eof++++-- A bunch of megaparsec helpers, eg for re-parsing (formerly in Text.Megaparsec.Custom).+-- I think these are generic apart from the HledgerParseError name.++--- * Custom parse error types++-- | Custom error data for hledger parsers. Specialised for a 'Text' parse stream.+-- ReparseableTextParseErrorData ?+data HledgerParseErrorData+  -- | Fail with a message at a specific source position interval. The+  -- interval must be contained within a single line.+  = ErrorFailAt Int -- Starting offset+                Int -- Ending offset+                String -- Error message+  -- | Re-throw parse errors obtained from the "re-parsing" of an excerpt+  -- of the source text.+  | ErrorReparsing+      (NE.NonEmpty (ParseError Text HledgerParseErrorData)) -- Source fragment parse errors+  deriving (Show, Eq, Ord)++-- | A specialised version of ParseErrorBundle: +-- a non-empty collection of hledger parse errors, +-- equipped with PosState to help pretty-print them.+-- Specialised for a 'Text' parse stream.+type HledgerParseErrors = ParseErrorBundle Text HledgerParseErrorData++-- We require an 'Ord' instance for 'CustomError' so that they may be+-- stored in a 'Set'. The actual instance is inconsequential, so we just+-- derive it, but the derived instance requires an (orphan) instance for+-- 'ParseError'. Hopefully this does not cause any trouble.++deriving instance Ord (ParseError Text HledgerParseErrorData)++-- Note: the pretty-printing of our 'HledgerParseErrorData' type is only partally+-- defined in its 'ShowErrorComponent' instance; we perform additional+-- adjustments in 'customErrorBundlePretty'.++instance ShowErrorComponent HledgerParseErrorData where+  showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg+  showErrorComponent (ErrorReparsing _) = "" -- dummy value++  errorComponentLen (ErrorFailAt startOffset endOffset _) =+    endOffset - startOffset+  errorComponentLen (ErrorReparsing _) = 1 -- dummy value+++--- * Failing with an arbitrary source position++-- | Fail at a specific source position, given by the raw offset from the+-- start of the input stream (the number of tokens processed at that+-- point).+parseErrorAt :: Int -> String -> HledgerParseErrorData+parseErrorAt offset = ErrorFailAt offset (offset+1)++-- | Fail at a specific source interval, given by the raw offsets of its+-- endpoints from the start of the input stream (the numbers of tokens+-- processed at those points).+--+-- Note that care must be taken to ensure that the specified interval does+-- not span multiple lines of the input source. This will not be checked.+parseErrorAtRegion+  :: Int    -- ^ Start offset+  -> Int    -- ^ End end offset+  -> String -- ^ Error message+  -> HledgerParseErrorData+parseErrorAtRegion startOffset endOffset msg =+  if startOffset < endOffset+    then ErrorFailAt startOffset endOffset msg'+    else ErrorFailAt startOffset (startOffset+1) msg'+  where+    msg' = "\n" ++ msg+++--- * Re-parsing++-- | A fragment of source suitable for "re-parsing". The purpose of this+-- data type is to preserve the content and source position of the excerpt+-- so that parse errors raised during "re-parsing" may properly reference+-- the original source.+data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt+                                   Text -- Fragment of source file++-- | Get the raw text of a source excerpt.+getExcerptText :: SourceExcerpt -> Text+getExcerptText (SourceExcerpt _ txt) = txt++-- | 'excerpt_ p' applies the given parser 'p' and extracts the portion of+-- the source consumed by 'p', along with the source position of this+-- portion. This is the only way to create a source excerpt suitable for+-- "re-parsing" by 'reparseExcerpt'.++-- This function could be extended to return the result of 'p', but we don't+-- currently need this.++excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt+excerpt_ p = do+  offset <- getOffset+  (!txt, _) <- match p+  pure $ SourceExcerpt offset txt++-- | 'reparseExcerpt s p' "re-parses" the source excerpt 's' using the+-- parser 'p'. Parse errors raised by 'p' will be re-thrown at the source+-- position of the source excerpt.+--+-- In order for the correct source file to be displayed when re-throwing+-- parse errors, we must ensure that the source file during the use of+-- 'reparseExcerpt s p' is the same as that during the use of 'excerpt_'+-- that generated the source excerpt 's'. However, we can usually expect+-- this condition to be satisfied because, at the time of writing, the+-- only changes of source file in the codebase take place through include+-- files, and the parser for include files neither accepts nor returns+-- 'SourceExcerpt's.++reparseExcerpt+  :: Monad m+  => SourceExcerpt+  -> ParsecT HledgerParseErrorData Text m a+  -> ParsecT HledgerParseErrorData Text m a+reparseExcerpt (SourceExcerpt offset txt) p = do+  (_, res) <- lift $ runParserT' p (offsetInitialState offset txt)+  case res of+    Right result -> pure result+    Left errBundle -> customFailure $ ErrorReparsing $ bundleErrors errBundle++  where+    offsetInitialState :: Int -> s ->+#if MIN_VERSION_megaparsec(8,0,0)+      State s e+#else+      State s+#endif+    offsetInitialState initialOffset s = State+      { stateInput  = s+      , stateOffset = initialOffset+      , statePosState = PosState+        { pstateInput = s+        , pstateOffset = initialOffset+        , pstateSourcePos = initialPos ""+        , pstateTabWidth = defaultTabWidth+        , pstateLinePrefix = ""+        }+#if MIN_VERSION_megaparsec(8,0,0)+      , stateParseErrors = []+#endif+      }++--- * Pretty-printing custom parse errors++-- | Pretty-print our custom parse errors. It is necessary to use this+-- instead of 'errorBundlePretty' when custom parse errors are thrown.+--+-- This function intercepts our custom parse errors and applies final+-- adjustments ('finalizeCustomError') before passing them to+-- 'errorBundlePretty'. These adjustments are part of the implementation+-- of the behaviour of our custom parse errors.+--+-- Note: We must ensure that the offset of the 'PosState' of the provided+-- 'ParseErrorBundle' is no larger than the offset specified by a+-- 'ErrorFailAt' constructor. This is guaranteed if this offset is set to+-- 0 (that is, the beginning of the source file), which is the+-- case for 'ParseErrorBundle's returned from 'runParserT'.++customErrorBundlePretty :: HledgerParseErrors -> String+customErrorBundlePretty errBundle =+  let errBundle' = errBundle { bundleErrors =+        NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets+        bundleErrors errBundle >>= finalizeCustomError }+  in  errorBundlePretty errBundle'++  where+    finalizeCustomError+      :: ParseError Text HledgerParseErrorData -> NE.NonEmpty (ParseError Text HledgerParseErrorData)+    finalizeCustomError err = case findCustomError err of+      Nothing -> pure err++      Just errFailAt@(ErrorFailAt startOffset _ _) ->+        -- Adjust the offset+        pure $ FancyError startOffset $ S.singleton $ ErrorCustom errFailAt++      Just (ErrorReparsing errs) ->+        -- Extract and finalize the inner errors+        errs >>= finalizeCustomError++    -- If any custom errors are present, arbitrarily take the first one+    -- (since only one custom error should be used at a time).+    findCustomError :: ParseError Text HledgerParseErrorData -> Maybe HledgerParseErrorData+    findCustomError err = case err of+      FancyError _ errSet ->+        finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet+      _ -> Nothing++    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b+    finds f = getAlt . foldMap (Alt . f)+++--- * "Final" parse errors+--+-- | A type representing "final" parse errors that cannot be backtracked+-- from and are guaranteed to halt parsing. The anti-backtracking+-- behaviour is implemented by an 'ExceptT' layer in the parser's monad+-- stack, using this type as the 'ExceptT' error type.+--+-- We have three goals for this type:+-- (1) it should be possible to convert any parse error into a "final"+-- parse error,+-- (2) it should be possible to take a parse error thrown from an include+-- file and re-throw it in the context of the parent file, and+-- (3) the pretty-printing of "final" parse errors should be consistent+-- with that of ordinary parse errors, but should also report the stack of+-- parent files when errors are thrown from included files.+--+-- In order to pretty-print a "final" parse error (goal 3), it must be+-- bundled with include filepaths and its full source text. When a "final"+-- parse error is thrown from within a parser, we do not have access to+-- the full source, so we must hold the parse error ('FinalParseError') +-- until it can be combined with the full source (and any parent file paths)+-- by the parser's caller ('FinalParseErrorBundle').++data FinalParseError' e+  -- a parse error thrown as a "final" parse error+  = FinalError           (ParseError Text e)+  -- a parse error obtained from running a parser, e.g. using 'runParserT'+  | FinalBundle          (ParseErrorBundle Text e)+  -- a parse error thrown from an include file+  | FinalBundleWithStack (FinalParseErrorBundle' e)+  deriving (Show)++type FinalParseError = FinalParseError' HledgerParseErrorData++-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT+-- FinalParseError m' is an instance of Alternative and MonadPlus, which+-- is needed to use some parser combinators, e.g. 'many'.+--+-- This monoid instance simply takes the first (left-most) error.++instance Semigroup (FinalParseError' e) where+  e <> _ = e++instance Monoid (FinalParseError' e) where+  mempty = FinalError $ FancyError 0 $+            S.singleton (ErrorFail "default parse error")+  mappend = (<>)++-- | A type bundling a 'ParseError' with its full source text, filepath,+-- and stack of include files. Suitable for pretty-printing.+--+-- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with+-- its full source text and filepath, so we just add a stack of include+-- files.+data FinalParseErrorBundle' e = FinalParseErrorBundle'+  { finalErrorBundle :: ParseErrorBundle Text e+  , includeFileStack :: [FilePath]+  } deriving (Show)++type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData+++--- * Constructing and throwing final parse errors++-- | Convert a "regular" parse error into a "final" parse error.+finalError :: ParseError Text e -> FinalParseError' e+finalError = FinalError++-- | Like megaparsec's 'fancyFailure', but as a "final" parse error.+finalFancyFailure+  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)+  => S.Set (ErrorFancy e) -> m a+finalFancyFailure errSet = do+  offset <- getOffset+  throwError $ FinalError $ FancyError offset errSet++-- | Like 'fail', but as a "final" parse error.+finalFail :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a+finalFail = finalFancyFailure . S.singleton . ErrorFail++-- | Like megaparsec's 'customFailure', but as a "final" parse error.+finalCustomFailure :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a+finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom+++--- * Pretty-printing "final" parse errors++-- | Pretty-print a "final" parse error: print the stack of include files,+-- then apply the pretty-printer for parse error bundles.+-- Note that 'attachSource' must be used on a "final" parse error before it can be pretty-printed.+finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String+finalErrorBundlePretty bundle =+     concatMap showIncludeFilepath (includeFileStack bundle)+  <> customErrorBundlePretty (finalErrorBundle bundle)+  where+    showIncludeFilepath path = "in file included from " <> path <> ",\n"++-- | Attach a filepath and source text to a "final" parse error so that it can be pretty-printed.+-- You must ensure that you provide the appropriate source text and filepath.+attachSource :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e+attachSource filePath sourceText finalParseError = case finalParseError of++  -- A parse error thrown directly with the 'FinalError' constructor+  -- requires both source and filepath.+  FinalError err ->+    let bundle = ParseErrorBundle+          { bundleErrors = err NE.:| []+          , bundlePosState = initialPosState filePath sourceText }+    in  FinalParseErrorBundle'+          { finalErrorBundle = bundle+          , includeFileStack  = [] }++  -- A 'ParseErrorBundle' already has the appropriate source and filepath+  -- and so needs neither.+  FinalBundle peBundle -> FinalParseErrorBundle'+    { finalErrorBundle = peBundle+    , includeFileStack = [] }++  -- A parse error from a 'FinalParseErrorBundle' was thrown from an+  -- include file, so we add the filepath to the stack.+  FinalBundleWithStack fpeBundle -> fpeBundle+    { includeFileStack = filePath : includeFileStack fpeBundle }+++--- * Handling parse errors from include files with "final" parse errors++-- | Parse an include file with the given parser and initial state,+-- discarding the resulting state,+-- and re-throwing any parse errors as final parse errors with the file's info attached.+parseIncludeFile+  :: Monad m+  => StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a+  -> st+  -> FilePath+  -> Text+  -> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a+parseIncludeFile parser initialState filepath text = catchError parser' handler+  where+    parser' = do+      eResult <- lift $ lift $ runParserT (evalStateT parser initialState) filepath text+      case eResult of+        Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle+        Right result -> pure result+    -- Attach source and filepath of the include file to its parse errors+    handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e+++--- * Helpers++-- | Like megaparsec's 'initialState', but instead for 'PosState'.+-- Used when constructing 'ParseErrorBundle's.+-- The values for "tab width" and "line prefix" are taken from 'initialState'.+initialPosState :: FilePath -> Text -> PosState Text+initialPosState filePath sourceText = PosState+  { pstateInput      = sourceText+  , pstateOffset     = 0+  , pstateSourcePos  = initialPos filePath+  , pstateTabWidth   = defaultTabWidth+  , pstateLinePrefix = "" }
Hledger/Utils/Regex.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-|  Easy regular expression helpers, currently based on regex-tdfa. These should:@@ -19,129 +18,267 @@  - work with simple strings -Regex strings are automatically compiled into regular expressions the-first time they are seen, and these are cached. If you use a huge-number of unique regular expressions this might lead to increased-memory usage. Several functions have memoised variants (*Memo), which-also trade space for time.+Regex strings are automatically compiled into regular expressions the first+time they are seen, and these are cached. If you use a huge number of unique+regular expressions this might lead to increased memory usage. Several+functions have memoised variants (*Memo), which also trade space for time. +Currently two APIs are provided:++- The old partial one (with ' suffixes') which will call error on any problem+  (eg with malformed regexps). This comes from hledger's origin as a+  command-line tool.++- The new total one which will return an error message. This is better for+  long-running apps like hledger-web.+ Current limitations:  - (?i) and similar are not supported  -} +{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+ module Hledger.Utils.Regex (+  -- * Regexp type and constructors+   Regexp(reString)+  ,toRegex+  ,toRegexCI+  ,toRegex'+  ,toRegexCI'    -- * type aliases-   Regexp   ,Replacement-   -- * standard regex operations-  ,regexMatches-  ,regexMatchesCI+  ,RegexError+   -- * total regex operations+  ,regexMatch+  ,regexMatchText+  ,regexMatchTextGroups   ,regexReplace-  ,regexReplaceCI-  ,regexReplaceMemo-  ,regexReplaceCIMemo-  ,regexReplaceBy-  ,regexReplaceByCI+  ,regexReplaceUnmemo+  ,regexReplaceAllBy   ) where -import Data.Array-import Data.Char+import Control.DeepSeq (NFData(..), rwhnf)+import Control.Monad (foldM)+import Data.Aeson (ToJSON(..), Value(String))+import Data.Array ((!), elems, indices)+import Data.Char (isDigit)+#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif import Data.MemoUgly (memo)+import Data.Text (Text)+import Data.Text qualified as T import Text.Regex.TDFA (-  Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt,-  makeRegexOpts, AllMatches(getAllMatches), match, (=~), MatchText+  Regex, CompOption(..), defaultCompOpt, defaultExecOpt,+  makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,+  RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)   ) --- import Hledger.Utils.Debug-import Hledger.Utils.UTF8IOCompat (error') - -- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax.-type Regexp = String+data Regexp+  = Regexp   { reString :: Text, reCompiled :: Regex }+  | RegexpCI { reString :: Text, reCompiled :: Regex } --- | A replacement pattern. May include numeric backreferences (\N).-type Replacement = String+instance Eq Regexp where+  Regexp   s1 _ == Regexp   s2 _ = s1 == s2+  RegexpCI s1 _ == RegexpCI s2 _ = s1 == s2+  _ == _ = False --- | Convert our string-based regexps to real ones. Can fail if the--- string regexp is malformed.-toRegex :: Regexp -> Regex-toRegex = memo (makeRegexOpts compOpt execOpt)+instance Ord Regexp where+  Regexp   s1 _ `compare` Regexp   s2 _ = s1 `compare` s2+  RegexpCI s1 _ `compare` RegexpCI s2 _ = s1 `compare` s2+  Regexp _ _ `compare` RegexpCI _ _ = LT+  RegexpCI _ _ `compare` Regexp _ _ = GT -toRegexCI :: Regexp -> Regex-toRegexCI = memo (makeRegexOpts compOpt{caseSensitive=False} execOpt)+instance Show Regexp where+  showsPrec d r = showParen (d > app_prec) $ reCons . showsPrec (app_prec+1) (T.unpack $ reString r)+    where app_prec = 10+          reCons = case r of Regexp   _ _ -> showString "Regexp "+                             RegexpCI _ _ -> showString "RegexpCI " -compOpt :: CompOption-compOpt = defaultCompOpt+instance Read Regexp where+  readsPrec d r =  readParen (d > app_prec) (\r' -> [(toRegexCI' m,t) |+                                                    ("RegexCI",s) <- lex r',+                                                    (m,t) <- readsPrec (app_prec+1) s]) r+                ++ readParen (d > app_prec) (\r' -> [(toRegex' m, t) |+                                                    ("Regex",s) <- lex r',+                                                    (m,t) <- readsPrec (app_prec+1) s]) r+    where app_prec = 10 -execOpt :: ExecOption-execOpt = defaultExecOpt+instance ToJSON Regexp where+  toJSON (Regexp   s _) = String $ "Regexp "   <> s+  toJSON (RegexpCI s _) = String $ "RegexpCI " <> s --- regexMatch' :: RegexContext Regexp String a => Regexp -> String -> a--- regexMatch' r s = s =~ (toRegex r)+instance RegexLike Regexp String where+  matchOnce = matchOnce . reCompiled+  matchAll = matchAll . reCompiled+  matchCount = matchCount . reCompiled+  matchTest = matchTest . reCompiled+  matchAllText = matchAllText . reCompiled+  matchOnceText = matchOnceText . reCompiled -regexMatches :: Regexp -> String -> Bool-regexMatches = flip (=~)+instance RegexContext Regexp String String where+  match = match . reCompiled+  matchM = matchM . reCompiled -regexMatchesCI :: Regexp -> String -> Bool-regexMatchesCI r = match (toRegexCI r)+instance NFData Regexp where rnf = rwhnf --- | Replace all occurrences of the regexp, transforming each match with the given function.-regexReplaceBy :: Regexp -> (String -> String) -> String -> String-regexReplaceBy r = replaceAllBy (toRegex r)+-- Convert a Regexp string to a compiled Regex, or return an error message.+toRegex :: Text -> Either RegexError Regexp+toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM (T.unpack s))  -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1 -regexReplaceByCI :: Regexp -> (String -> String) -> String -> String-regexReplaceByCI r = replaceAllBy (toRegexCI r)+-- Like toRegex, but make a case-insensitive Regex.+toRegexCI :: Text -> Either RegexError Regexp+toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt (T.unpack s))  -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1 --- | Replace all occurrences of the regexp with the replacement--- pattern. The replacement pattern supports numeric backreferences--- (\N) but no other RE syntax.-regexReplace :: Regexp -> Replacement -> String -> String-regexReplace re = replaceRegex (toRegex re)+-- | Make a nice error message for a regexp error.+mkRegexErr :: Text -> Maybe a -> Either RegexError a+mkRegexErr s = maybe (Left errmsg) Right+  where errmsg = T.unpack $ "This regular expression is invalid or unsupported, please correct it:\n" <> s -regexReplaceCI :: Regexp -> Replacement -> String -> String-regexReplaceCI re = replaceRegex (toRegexCI re)+-- Convert a Regexp string to a compiled Regex, throw an error+toRegex' :: Text -> Regexp+toRegex' = either errorWithoutStackTrace id . toRegex --- | A memoising version of regexReplace. Caches the result for each--- search pattern, replacement pattern, target string tuple.-regexReplaceMemo :: Regexp -> Replacement -> String -> String-regexReplaceMemo re repl = memo (regexReplace re repl)+-- Like toRegex', but make a case-insensitive Regex.+toRegexCI' :: Text -> Regexp+toRegexCI' = either errorWithoutStackTrace id . toRegexCI -regexReplaceCIMemo :: Regexp -> Replacement -> String -> String-regexReplaceCIMemo re repl = memo (regexReplaceCI re repl)+-- | A replacement pattern. May include numeric backreferences (\N).+type Replacement = String +-- | An error message arising during a regular expression operation.+-- Eg: trying to compile a malformed regular expression, or+-- trying to apply a malformed replacement pattern.+type RegexError = String++-- helpers++-- | Test whether a Regexp matches a String. This is an alias for `matchTest` for consistent+-- naming.+regexMatch :: Regexp -> String -> Bool+regexMatch = matchTest++-- | Tests whether a Regexp matches a Text. --+-- This currently unpacks the Text to a String, to work around a performance bug+-- in regex-tdfa (#9), which may or may not be relevant here.+regexMatchText :: Regexp -> Text -> Bool+regexMatchText r = matchTest r . T.unpack -replaceRegex :: Regex -> Replacement -> String -> String-replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [MatchText String])+-- | Return a (possibly empty) list of match groups derived by applying the+-- Regex to a Text.+regexMatchTextGroups :: Regexp -> Text -> [Text]+regexMatchTextGroups r txt = let+    pat = reCompiled r+    (_,_,_,matches) = match pat txt :: (Text,Text,Text,[Text])+    in matches -replaceMatch :: Replacement -> String -> MatchText String -> String-replaceMatch replpat s matchgroups = pre ++ repl ++ post+--------------------------------------------------------------------------------+-- new total functions++-- | A memoising version of regexReplace. Caches the result for each+-- search pattern, replacement pattern, target string tuple.+-- This won't generate a regular expression parsing error since that+-- is pre-compiled nowadays, but there can still be a runtime error +-- from the replacement pattern, eg with a backreference referring +-- to a nonexistent match group.+regexReplace :: Regexp -> Replacement -> String -> Either RegexError String+regexReplace re repl = memo $ regexReplaceUnmemo re repl++-- helpers:++-- Replace this regular expression with this replacement pattern in this+-- string, or return an error message. (There should be no regexp+-- parsing errors these days since Regexp's compiled form is used,+-- but there can still be a runtime error from the replacement+-- pattern, eg a backreference referring to a nonexistent match group.)+regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String+regexReplaceUnmemo re repl str = foldM (replaceMatch repl) str (reverse $ match (reCompiled re) str :: [MatchText String])   where-    ((_,(off,len)):_) = elems matchgroups  -- groups should have 0-based indexes, and there should always be at least one, since this is a match-    (pre, post') = splitAt off s-    post = drop len post'-    repl = replaceAllBy (toRegex "\\\\[0-9]+") (replaceBackReference matchgroups) replpat+    -- Replace one match within the string with the replacement text+    -- appropriate for this match. Or return an error message.+    replaceMatch :: Replacement -> String -> MatchText String -> Either RegexError String+    replaceMatch replpat s matchgroups =+      case elems matchgroups of +        [] -> Right s+        ((_,(off,len)):_) ->   -- groups should have 0-based indexes, and there should always be at least one, since this is a match+          erpl >>= \rpl -> Right $ pre ++ rpl ++ post+          where+            (pre, post') = splitAt off s+            post = drop len post'+            -- The replacement text: the replacement pattern with all+            -- numeric backreferences replaced by the appropriate groups+            -- from this match. Or an error message.+            erpl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat+              where+                -- Given some match groups and a numeric backreference,+                -- return the referenced group text, or an error message.+                lookupMatchGroup :: MatchText String -> String -> Either RegexError String+                lookupMatchGroup grps ('\\':s2@(_:_)) | all isDigit s2 =+                  case read s2 of n | n `elem` indices grps -> Right $ fst (grps ! n)  -- PARTIAL: should not fail, all digits+                                  _                         -> Left $ "no match group exists for backreference \"\\"++s++"\""+                lookupMatchGroup _ s2 = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s2++"\", shouldn't happen"+    backrefRegex = toRegex' "\\\\[0-9]+"  -- PARTIAL: should not fail -replaceBackReference :: MatchText String -> String -> String-replaceBackReference grps ('\\':s@(_:_)) | all isDigit s =-  case read s of n | n `elem` indices grps -> fst (grps ! n)-                 _                         -> error' $ "no match group exists for backreference \"\\"++s++"\""-replaceBackReference _ s = error' $ "replaceBackReference called on non-numeric-backreference \""++s++"\", shouldn't happen"+-- regexReplace' :: Regexp -> Replacement -> String -> String+-- regexReplace' re repl s =+--     foldl (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])+--   where+--     replaceMatch :: Replacement -> String -> MatchText String -> String+--     replaceMatch replpat s matchgroups = pre ++ repl ++ post+--       where+--         ((_,(off,len)):_) = elems matchgroups  -- groups should have 0-based indexes, and there should always be at least one, since this is a match+--         (pre, post') = splitAt off s+--         post = drop len post'+--         repl = regexReplaceAllBy backrefRegex (lookupMatchGroup matchgroups) replpat+--           where+--             lookupMatchGroup :: MatchText String -> String -> String+--             lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =+--               case read s of n | n `elem` indices grps -> fst (grps ! n)+--               -- PARTIAL:+--                              _                         -> error' $ "no match group exists for backreference \"\\"++s++"\""+--             lookupMatchGroup _ s = error' $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen"+--     backrefRegex = toRegex' "\\\\[0-9]+"  -- PARTIAL: should not fail --- --- http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries :--- | Replace all occurrences of a regexp in a string, transforming each match with the given function.-replaceAllBy :: Regex -> (String -> String) -> String -> String-replaceAllBy re f s = start end+-- helpers++-- adapted from http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries:++-- Replace all occurrences of a regexp in a string, transforming each match+-- with the given pure function.+regexReplaceAllBy :: Regexp -> (String -> String) -> String -> String+regexReplaceAllBy re transform s = prependdone rest   where-    (_, end, start) = foldl' go (0, s, id) $ (getAllMatches $ match re s :: [(Int, Int)])-    go (ind,read,write) (off,len) =-      let (skip, start) = splitAt (off - ind) read-          (matched, remaining) = splitAt len start-      in (off + len, remaining, write . (skip++) . (f matched ++))+    (_, rest, prependdone) = foldl' go (0, s, id) matches+      where+        matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)]  -- offset and length+        go :: (Int,String,String->String) -> (Int,Int) ->  (Int,String,String->String)+        go (pos,todo,prepend) (off,len) =+          let (prematch, matchandrest) = splitAt (off - pos) todo+              (matched, rest2) = splitAt len matchandrest+          in (off + len, rest2, prepend . (prematch++) . (transform matched ++)) +-- Replace all occurrences of a regexp in a string, transforming each match+-- with the given monadic function. Eg if the monad is Either, a Left result+-- from the transform function short-circuits and is returned as the overall+-- result.+regexReplaceAllByM :: forall m. Monad m => Regexp -> (String -> m String) -> String -> m String+regexReplaceAllByM re transform s =+    foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest+  where+    matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)]  -- offset and length+    go :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String)+    go (pos,todo,prepend) (off,len) =+      let (prematch, matchandrest) = splitAt (off - pos) todo+          (matched, rest) = splitAt len matchandrest+      in transform matched >>= \matched' -> pure (off + len, rest, prepend . (prematch++) . (matched' ++))
Hledger/Utils/String.hs view
@@ -1,61 +1,66 @@ -- | String formatting helpers, starting to get a bit out of control.  module Hledger.Utils.String (+ takeEnd,  -- * misc+ capitalise,  lowercase,  uppercase,  underline,  stripbrackets,- unbracket,  -- quoting  quoteIfNeeded,  singleQuoteIfNeeded,+ quoteForCommandLine,  -- quotechars,  -- whitespacechars,- escapeQuotes,  words',- unwords',  stripAnsi,  -- * single-line layout  strip,  lstrip,  rstrip,+ strip1Char,+ stripBy,+ strip1By,  chomp,+ chomp1,+ singleline,  elideLeft,  elideRight,  formatString,- -- * multi-line layout- concatTopPadded,- concatBottomPadded,- concatOneLine,- vConcatLeftAligned,- vConcatRightAligned,- padtop,- padbottom,- padleft,- padright,- cliptopleft,- fitto,  -- * wide-character-aware layout  charWidth,  strWidth,+ strWidthAnsi,  takeWidth,- fitString,- fitStringMulti,- padLeftWide,- padRightWide  ) where  -import Data.Char-import Data.List-import Text.Megaparsec-import Text.Megaparsec.Char+import Data.Char (isSpace, toLower, toUpper)+import Data.List (intercalate, dropWhileEnd)+import Data.Text qualified as T+import Safe (headErr, tailErr)+import Text.Megaparsec ((<|>), between, many, noneOf, sepBy)+import Text.Megaparsec.Char (char) import Text.Printf (printf)  import Hledger.Utils.Parse-import Hledger.Utils.Regex+import Hledger.Utils.Regex (toRegex', regexReplace)+import Text.DocLayout (charWidth, realLength) ++-- | Take elements from the end of a list.+takeEnd n l = go (drop n l) l+  where+    go (_:xs) (_:ys) = go xs ys+    go []     r      = r+    go _      []     = []++capitalise :: String -> String+capitalise (c:cs) = toUpper c : cs+capitalise s = s+ lowercase, uppercase :: String -> String lowercase = map toLower uppercase = map toUpper@@ -72,16 +77,43 @@ rstrip :: String -> String rstrip = reverse . lstrip . reverse --- | Remove trailing newlines/carriage returns.+-- | Strip the given starting and ending character+-- from the start and end of a string if both are present.+strip1Char :: Char -> Char -> String -> String+strip1Char b e s = case s of+  (c:cs) | c==b, not $ null cs, last cs==e -> init cs+  _ -> s++-- | Strip a run of zero or more characters matching the predicate+-- from the start and end of a string.+stripBy :: (Char -> Bool) -> String -> String+stripBy f = dropWhileEnd f . dropWhile f++-- | Strip a single balanced enclosing pair of a character matching the predicate+-- from the start and end of a string.+strip1By :: (Char -> Bool) -> String -> String+strip1By f s = case s of+  (c:cs) | f c, not $ null cs, last cs==c -> init cs+  _ -> s++-- | Remove all trailing newlines/carriage returns. chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse +-- | Remove all trailing newline/carriage returns, leaving just one trailing newline.+chomp1 :: String -> String+chomp1 = (++"\n") . chomp++-- | Remove consecutive line breaks, replacing them with single space+singleline :: String -> String+singleline = unwords . filter (/="") . (map strip) . lines+ stripbrackets :: String -> String stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String  elideLeft :: Int -> String -> String elideLeft width s =-    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s+    if length s > width then ".." ++ takeEnd (width - 2) s else s  elideRight :: Int -> String -> String elideRight width s =@@ -106,208 +138,76 @@ -- | Double-quote this string if it contains whitespace, single quotes -- or double-quotes, escaping the quotes as needed. quoteIfNeeded :: String -> String-quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""+quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars++redirectchars) = showChar '"' $ escapeQuotes s "\""                 | otherwise = s+  where+    escapeQuotes []       x = x+    escapeQuotes ('"':cs) x = showString "\\\"" $ escapeQuotes cs x+    escapeQuotes (c:cs)   x = showChar c        $ escapeQuotes cs x+ -- | Single-quote this string if it contains whitespace or double-quotes.--- No good for strings containing single quotes.+-- Does not work for strings containing single quotes. singleQuoteIfNeeded :: String -> String-singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"+singleQuoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = singleQuote s                       | otherwise = s -quotechars, whitespacechars :: [Char]-quotechars      = "'\""-whitespacechars = " \t\n\r"+-- | Prepend and append single quotes to a string.+singleQuote :: String -> String+singleQuote s = "'"++s++"'" -escapeDoubleQuotes :: String -> String-escapeDoubleQuotes = regexReplace "\"" "\""+-- | Try to single- and backslash-quote a string as needed to make it usable+-- as an argument on a (sh/bash) shell command line. At least, well enough +-- to handle common currency symbols, like $. Probably broken in many ways.+--+-- >>> quoteForCommandLine "a"+-- "a"+-- >>> quoteForCommandLine "\""+-- "'\"'"+-- >>> quoteForCommandLine "$"+-- "'$'"+--+quoteForCommandLine :: String -> String+quoteForCommandLine s+  | any (`elem` s) (quotechars++whitespacechars++shellchars) = singleQuote $ escapeSingleQuotes s+  | otherwise = s -escapeQuotes :: String -> String-escapeQuotes = regexReplace "([\"'])" "\\1"+-- | Escape single quotes appearing in a string we're protecting by wrapping in single quotes+escapeSingleQuotes :: String -> String+escapeSingleQuotes = concatMap escapeSingleQuote+  where+    escapeSingleQuote c | c `elem` "'" = ['\\',c]+    escapeSingleQuote c = [c] +quotechars, whitespacechars, redirectchars, shellchars :: [Char]+quotechars      = "'\""+whitespacechars = " \t\n\r"+redirectchars   = "<>"+shellchars      = "<>(){}[]$&?#!~`*+\\"+ -- | Quote-aware version of words - don't split on spaces which are inside quotes. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. words' :: String -> [String] words' "" = []-words' s  = map stripquotes $ fromparse $ parsewithString p s+words' s  = map stripquotes $ fromparse $ parsewithString p s  -- PARTIAL     where-      p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` skipSome spacenonewline-             -- eof-             return ss-      pattern = many (noneOf whitespacechars)+      p = (singleQuotedPattern <|> doubleQuotedPattern <|> patterns) `sepBy` skipNonNewlineSpaces1+          -- eof+      patterns = many (noneOf whitespacechars)       singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")       doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") --- | Quote-aware version of unwords - single-quote strings which contain whitespace-unwords' :: [String] -> String-unwords' = unwords . map quoteIfNeeded- -- | Strip one matching pair of single or double quotes on the ends of a string. stripquotes :: String -> String-stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s+stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tailErr s else s  -- PARTIAL tailErr won't fail because isDoubleQuoted -isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''+isSingleQuoted s@(_:_:_) = headErr s == '\'' && last s == '\''  -- PARTIAL headErr, last will succeed because of pattern isSingleQuoted _ = False -isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'+isDoubleQuoted s@(_:_:_) = headErr s == '"' && last s == '"'  -- PARTIAL headErr, last will succeed because of pattern isDoubleQuoted _ = False -unbracket :: String -> String-unbracket s-    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s-    | otherwise = s---- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.--- Treats wide characters as double width.-concatTopPadded :: [String] -> String-concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = replicate (difforzero h (length ls)) "" ++ ls-      xpad ls = map (padLeftWide w) ls where w | null ls = 0-                                               | otherwise = maximum $ map strWidth ls-      padded = map (xpad . ypad) lss---- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.--- Treats wide characters as double width.-concatBottomPadded :: [String] -> String-concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = ls ++ replicate (difforzero h (length ls)) ""-      xpad ls = map (padRightWide w) ls where w | null ls = 0-                                                | otherwise = maximum $ map strWidth ls-      padded = map (xpad . ypad) lss----- | Join multi-line strings horizontally, after compressing each of--- them to a single line with a comma and space between each original line.-concatOneLine :: [String] -> String-concatOneLine strs = concat $ map ((intercalate ", ").lines) strs---- | Join strings vertically, left-aligned and right-padded.-vConcatLeftAligned :: [String] -> String-vConcatLeftAligned ss = intercalate "\n" $ map showfixedwidth ss-    where-      showfixedwidth = printf (printf "%%-%ds" width)-      width = maximum $ map length ss---- | Join strings vertically, right-aligned and left-padded.-vConcatRightAligned :: [String] -> String-vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss-    where-      showfixedwidth = printf (printf "%%%ds" width)-      width = maximum $ map length ss---- | Convert a multi-line string to a rectangular string top-padded to the specified height.-padtop :: Int -> String -> String-padtop h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = replicate (difforzero h sh) "" ++ ls-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.-padbottom :: Int -> String -> String-padbottom h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = ls ++ replicate (difforzero h sh) ""-      xpadded = map (padleft sw) ypadded--difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]---- | Convert a multi-line string to a rectangular string left-padded to the specified width.--- Treats wide characters as double width.-padleft :: Int -> String -> String-padleft w "" = concat $ replicate w " "-padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s---- | Convert a multi-line string to a rectangular string right-padded to the specified width.--- Treats wide characters as double width.-padright :: Int -> String -> String-padright w "" = concat $ replicate w " "-padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s---- | Clip a multi-line string to the specified width and height from the top left.-cliptopleft :: Int -> Int -> String -> String-cliptopleft w h = intercalate "\n" . take h . map (take w) . lines---- | Clip and pad a multi-line string to fill the specified width and height.-fitto :: Int -> Int -> String -> String-fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline-    where-      rows = map (fit w) $ lines s-      fit w = take w . (++ repeat ' ')-      blankline = replicate w ' '- -- Functions below treat wide (eg CJK) characters as double-width. --- | General-purpose wide-char-aware single-line string layout function.--- It can left- or right-pad a short string to a minimum width.--- It can left- or right-clip a long string to a maximum width, optionally inserting an ellipsis (the third argument).--- It clips and pads on the right when the fourth argument is true, otherwise on the left.--- It treats wide characters as double width.-fitString :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String-fitString mminwidth mmaxwidth ellipsify rightside s = (clip . pad) s-  where-    clip :: String -> String-    clip s =-      case mmaxwidth of-        Just w-          | strWidth s > w ->-            case rightside of-              True  -> takeWidth (w - length ellipsis) s ++ ellipsis-              False -> ellipsis ++ reverse (takeWidth (w - length ellipsis) $ reverse s)-          | otherwise -> s-          where-            ellipsis = if ellipsify then ".." else ""-        Nothing -> s-    pad :: String -> String-    pad s =-      case mminwidth of-        Just w-          | sw < w ->-            case rightside of-              True  -> s ++ replicate (w - sw) ' '-              False -> replicate (w - sw) ' ' ++ s-          | otherwise -> s-        Nothing -> s-      where sw = strWidth s---- | A version of fitString that works on multi-line strings,--- separate for now to avoid breakage.--- This will rewrite any line endings to unix newlines.-fitStringMulti :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String-fitStringMulti mminwidth mmaxwidth ellipsify rightside s =-  (intercalate "\n" . map (fitString mminwidth mmaxwidth ellipsify rightside) . lines) s---- | Left-pad a string to the specified width.--- Treats wide characters as double width.--- Works on multi-line strings too (but will rewrite non-unix line endings).-padLeftWide :: Int -> String -> String-padLeftWide w "" = replicate w ' '-padLeftWide w s  = intercalate "\n" $ map (fitString (Just w) Nothing False False) $ lines s--- XXX not yet replaceable by--- padLeftWide w = fitStringMulti (Just w) Nothing False False---- | Right-pad a string to the specified width.--- Treats wide characters as double width.--- Works on multi-line strings too (but will rewrite non-unix line endings).-padRightWide :: Int -> String -> String-padRightWide w "" = replicate w ' '-padRightWide w s  = intercalate "\n" $ map (fitString (Just w) Nothing False True) $ lines s--- XXX not yet replaceable by--- padRightWide w = fitStringMulti (Just w) Nothing False True- -- | Double-width-character-aware string truncation. Take as many -- characters as possible from a string without exceeding the -- specified width. Eg takeWidth 3 "りんご" = "り".@@ -318,65 +218,24 @@                    | otherwise = ""   where cw = charWidth c --- from Pandoc (copyright John MacFarlane, GPL)--- see also http://unicode.org/reports/tr11/#Description+-- | Like strWidth, but also strips ANSI escape sequences before+-- calculating the width.+--+-- This is no longer used in code, as widths are calculated before+-- adding ANSI escape sequences, but is being kept around for now.+strWidthAnsi :: String -> Int+strWidthAnsi = strWidth . stripAnsi --- | Calculate the render width of a string, considering--- wide characters (counted as double width), ANSI escape codes --- (not counted), and line breaks (in a multi-line string, the longest--- line determines the width). +-- | Alias for 'realLength'. strWidth :: String -> Int-strWidth "" = 0-strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s'-  where s' = stripAnsi s+strWidth = realLength +-- | Strip ANSI escape sequences from a string.+--+-- >>> stripAnsi "\ESC[31m-1\ESC[m"+-- "-1" stripAnsi :: String -> String-stripAnsi = regexReplace "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]" ""---- | Get the designated render width of a character: 0 for a combining--- character, 1 for a regular character, 2 for a wide character.--- (Wide characters are rendered as exactly double width in apps and--- fonts that support it.) (From Pandoc.)-charWidth :: Char -> Int-charWidth c =-  case c of-      _ | c <  '\x0300'                    -> 1-        | c >= '\x0300' && c <= '\x036F'   -> 0  -- combining-        | c >= '\x0370' && c <= '\x10FC'   -> 1-        | c >= '\x1100' && c <= '\x115F'   -> 2-        | c >= '\x1160' && c <= '\x11A2'   -> 1-        | c >= '\x11A3' && c <= '\x11A7'   -> 2-        | c >= '\x11A8' && c <= '\x11F9'   -> 1-        | c >= '\x11FA' && c <= '\x11FF'   -> 2-        | c >= '\x1200' && c <= '\x2328'   -> 1-        | c >= '\x2329' && c <= '\x232A'   -> 2-        | c >= '\x232B' && c <= '\x2E31'   -> 1-        | c >= '\x2E80' && c <= '\x303E'   -> 2-        | c == '\x303F'                    -> 1-        | c >= '\x3041' && c <= '\x3247'   -> 2-        | c >= '\x3248' && c <= '\x324F'   -> 1 -- ambiguous-        | c >= '\x3250' && c <= '\x4DBF'   -> 2-        | c >= '\x4DC0' && c <= '\x4DFF'   -> 1-        | c >= '\x4E00' && c <= '\xA4C6'   -> 2-        | c >= '\xA4D0' && c <= '\xA95F'   -> 1-        | c >= '\xA960' && c <= '\xA97C'   -> 2-        | c >= '\xA980' && c <= '\xABF9'   -> 1-        | c >= '\xAC00' && c <= '\xD7FB'   -> 2-        | c >= '\xD800' && c <= '\xDFFF'   -> 1-        | c >= '\xE000' && c <= '\xF8FF'   -> 1 -- ambiguous-        | c >= '\xF900' && c <= '\xFAFF'   -> 2-        | c >= '\xFB00' && c <= '\xFDFD'   -> 1-        | c >= '\xFE00' && c <= '\xFE0F'   -> 1 -- ambiguous-        | c >= '\xFE10' && c <= '\xFE19'   -> 2-        | c >= '\xFE20' && c <= '\xFE26'   -> 1-        | c >= '\xFE30' && c <= '\xFE6B'   -> 2-        | c >= '\xFE70' && c <= '\xFEFF'   -> 1-        | c >= '\xFF01' && c <= '\xFF60'   -> 2-        | c >= '\xFF61' && c <= '\x16A38'  -> 1-        | c >= '\x1B000' && c <= '\x1B001' -> 2-        | c >= '\x1D000' && c <= '\x1F1FF' -> 1-        | c >= '\x1F200' && c <= '\x1F251' -> 2-        | c >= '\x1F300' && c <= '\x1F773' -> 1-        | c >= '\x20000' && c <= '\x3FFFD' -> 2-        | otherwise                        -> 1-+stripAnsi s = either err id $ regexReplace ansire "" s+ where+   err    = errorWithoutStackTrace "stripAnsi: invalid replacement pattern"      -- PARTIAL, shouldn't happen+   ansire = toRegex' $ T.pack "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]"  -- PARTIAL, should succeed
Hledger/Utils/Test.hs view
@@ -1,232 +1,150 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}  module Hledger.Utils.Test (-   HasCallStack-  ,module EasyTest-  ,runEasytests-  ,tests-  ,_tests-  ,test-  ,_test-  ,it-  ,_it-  ,is-  ,expectEqPP-  ,expectParse-  ,expectParseE-  ,expectParseError-  ,expectParseErrorE-  ,expectParseEq-  ,expectParseEqE-  ,expectParseEqOn-  ,expectParseEqOnE-  ,expectParseStateOn-) +   module Test.Tasty+  ,module Test.Tasty.HUnit+  -- ,module QC+  -- ,module SC+  ,assertLeft+  ,assertRight+  ,assertParse+  ,assertParseEq+  ,assertParseEqOn+  ,assertParseError+  ,assertParseE+  ,assertParseEqE+  ,assertParseErrorE+  ,assertParseStateOn+) where -import Control.Exception-import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad (unless)+import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, withExceptT) import Control.Monad.State.Strict (StateT, evalStateT, execStateT)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import Data.CallStack-import Data.List-import qualified Data.Text as T-import Safe -import System.Exit+import Data.Default (Default(..))+import Data.List (isInfixOf)+import Data.Text qualified as T+import Test.Tasty hiding (defaultMain)+import Test.Tasty.HUnit+-- import Test.Tasty.QuickCheck as QC+-- import Test.Tasty.SmallCheck as SC import Text.Megaparsec-import Text.Megaparsec.Custom -import EasyTest hiding (char, char', tests)  -- reexported-import qualified EasyTest as E               -- used here--import Hledger.Utils.Debug (pshow)-import Hledger.Utils.UTF8IOCompat (error')---- * easytest helpers---- | Name the given test(s). A readability synonym for easytest's "scope".-test :: T.Text -> E.Test a -> E.Test a -test = E.scope+import Hledger.Utils.IO (pshow)+import Hledger.Utils.Parse+  ( HledgerParseErrorData,+    FinalParseError,+    attachSource,+    customErrorBundlePretty,+    finalErrorBundlePretty,+  ) --- | Skip the given test(s), with the same type signature as "test".--- If called in a monadic sequence of tests, also skips following tests.-_test :: T.Text -> E.Test a -> E.Test a -_test _name = (E.skip >>) +-- * tasty helpers --- | Name the given test(s). A synonym for "test".-it :: T.Text -> E.Test a -> E.Test a -it = test+-- TODO: pretty-print values in failure messages --- | Skip the given test(s), and any following tests in a monadic sequence. --- A synonym for "_test".-_it :: T.Text -> E.Test a -> E.Test a -_it = _test+-- | Assert any Left value.+assertLeft :: (HasCallStack, Eq b, Show b) => Either a b -> Assertion+assertLeft (Left _)  = return ()+assertLeft (Right b) = assertFailure $ "expected Left, got (Right " ++ show b ++ ")" --- | Name and group a list of tests. Combines easytest's "scope" and "tests".-tests :: T.Text -> [E.Test ()] -> E.Test () -tests name = E.scope name . E.tests+-- | Assert any Right value.+assertRight :: (HasCallStack, Eq a, Show a) => Either a b -> Assertion+assertRight (Right _) = return ()+assertRight (Left a)  = assertFailure $ "expected Right, got (Left " ++ show a ++ ")" --- | Skip the given list of tests, and any following tests in a monadic sequence,--- with the same type signature as "group".-_tests :: T.Text -> [E.Test ()] -> E.Test () -_tests _name = (E.skip >>) . E.tests+-- | Run a parser on the given text and display a helpful error.+parseHelper :: (HasCallStack, Default st, Monad m) =>+  StateT st (ParsecT HledgerParseErrorData T.Text m) a -> T.Text -> ExceptT String m a+parseHelper parser input =+  withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . ExceptT+  $ runParserT (evalStateT (parser <* eof) def) "" input --- | Run some easytest tests, catching easytest's ExitCode exception,--- returning True if there was a problem.--- With arguments, runs only the scope (or single test) named by the first argument--- (exact, case sensitive). --- If there is a second argument, it should be an integer and will be used--- as the seed for randomness. -runEasytests :: [String] -> E.Test () -> IO Bool-runEasytests args tests = (do-  case args of-    []    -> E.run tests-    [a]   -> E.runOnly (T.pack a) tests-    a:b:_ -> do-      case readMay b :: Maybe Int of-        Nothing   -> error' "the second argument should be an integer (a seed for easytest)"-        Just seed -> E.rerunOnly seed (T.pack a) tests-  return False-  )-  `catch` (\(_::ExitCode) -> return True)+-- | Run a stateful parser in IO and process either a failure or success to+-- produce an 'Assertion'. Suitable for hledger's JournalParser parsers.+assertParseHelper :: (HasCallStack, Default st) =>+  (String -> Assertion) -> (a -> Assertion)+  -> StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text+  -> Assertion+assertParseHelper onFailure onSuccess parser input =+  either onFailure onSuccess =<< runExceptT (parseHelper parser input) --- | Like easytest's expectEq (asserts the second (actual) value equals the first (expected) value)--- but pretty-prints the values in the failure output. -expectEqPP :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test ()-expectEqPP expected actual = if expected == actual then E.ok else E.crash $-  "\nexpected:\n" <> T.pack (pshow expected) <> "\nbut got:\n" <> T.pack (pshow actual) <> "\n"+-- | Assert that this stateful parser runnable in IO successfully parses+-- all of the given input text, showing the parse error if it fails.+-- Suitable for hledger's JournalParser parsers.+assertParse :: (HasCallStack, Default st) =>+  StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> Assertion+assertParse = assertParseHelper assertFailure (const $ return ()) --- | Shorter and flipped version of expectEqPP. The expected value goes last.-is :: (Eq a, Show a, HasCallStack) => a -> a -> Test ()-is = flip expectEqPP+-- | Assert a parser produces an expected value.+assertParseEq :: (HasCallStack, Eq a, Show a, Default st) =>+  StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> a -> Assertion+assertParseEq parser input = assertParseEqOn parser input id --- | Test that this stateful parser runnable in IO successfully parses --- all of the given input text, showing the parse error if it fails. --- Suitable for hledger's JournalParser parsers.-expectParse :: (Monoid st, Eq a, Show a, HasCallStack) => -  StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test ()-expectParse parser input = do-  ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input)-  either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)-         (const ok)-         ep+-- | Like assertParseEq, but transform the parse result with the given function+-- before comparing it.+assertParseEqOn :: (HasCallStack, Eq b, Show b, Default st) =>+  StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion+assertParseEqOn parser input f expected =+  assertParseHelper assertFailure (assertEqual "" expected . f) parser input --- Suitable for hledger's ErroringJournalParser parsers.-expectParseE-  :: (Monoid st, Eq a, Show a, HasCallStack)-  => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a-  -> T.Text-  -> E.Test ()-expectParseE parser input = do-  let filepath = ""-  eep <- E.io $ runExceptT $-           runParserT (evalStateT (parser <* eof) mempty) filepath input-  case eep of-    Left finalErr ->-      let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr-      in  fail $ "parse error at " <> prettyErr-    Right ep ->-      either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty)-             (const ok)-             ep+-- | Assert that this stateful parser runnable in IO fails to parse+-- the given input text, with a parse error containing the given string.+assertParseError :: (HasCallStack, Eq a, Show a, Default st) =>+  StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> String -> Assertion+assertParseError parser input errstr = assertParseHelper+  (\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)+  (\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")+  parser input --- | Test that this stateful parser runnable in IO fails to parse --- the given input text, with a parse error containing the given string. -expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) => -  StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> E.Test ()-expectParseError parser input errstr = do-  ep <- E.io (runParserT (evalStateT parser mempty) "" input)-  case ep of-    Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"-    Left e  -> do-      let e' = customErrorBundlePretty e-      if errstr `isInfixOf` e'-      then ok-      else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"+-- | Run a stateful parser in IO like assertParse, then assert that the+-- final state (the wrapped state, not megaparsec's internal state),+-- transformed by the given function, matches the given expected value.+assertParseStateOn :: (HasCallStack, Eq b, Show b, Default st) =>+     StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (st -> b) -> b -> Assertion+assertParseStateOn parser input f expected = do+  es <- runParserT (execStateT (parser <* eof) def) "" input+  case es of+    Left err -> assertFailure $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err+    Right s  -> assertEqual "" expected $ f s -expectParseErrorE-  :: (Monoid st, Eq a, Show a, HasCallStack)-  => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a-  -> T.Text-  -> String-  -> E.Test ()-expectParseErrorE parser input errstr = do-  let filepath = ""-  eep <- E.io $ runExceptT $ runParserT (evalStateT parser mempty) filepath input-  case eep of-    Left finalErr -> do-      let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr-      if errstr `isInfixOf` prettyErr-      then ok-      else fail $ "\nparse error is not as expected:\n" ++ prettyErr ++ "\n"-    Right ep -> case ep of-      Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"-      Left e  -> do-        let e' = customErrorBundlePretty e-        if errstr `isInfixOf` e'-        then ok-        else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n"+-- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers.+parseHelperE :: (HasCallStack, Default st, Monad m) =>+  StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError m)) a -> T.Text -> ExceptT String m a+parseHelperE parser input = do+  withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . liftEither+  =<< withExceptT (\e -> "parse error at " ++ finalErrorBundlePretty (attachSource "" input e))+        (runParserT (evalStateT (parser <* eof) def) "" input) --- | Like expectParse, but also test the parse result is an expected value,--- pretty-printing both if it fails. -expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) => -  StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()-expectParseEq parser input expected = expectParseEqOn parser input id expected+assertParseHelperE :: (HasCallStack, Default st) =>+  (String -> Assertion) -> (a -> Assertion)+  -> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text+  -> Assertion+assertParseHelperE onFailure onSuccess parser input =+  either onFailure onSuccess =<< runExceptT (parseHelperE parser input) -expectParseEqE-  :: (Monoid st, Eq a, Show a, HasCallStack)-  => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a-  -> T.Text-  -> a-  -> E.Test ()-expectParseEqE parser input expected = expectParseEqOnE parser input id expected+assertParseE+  :: (HasCallStack, Eq a, Show a, Default st)+  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion+assertParseE = assertParseHelperE assertFailure (const $ return ()) --- | Like expectParseEq, but transform the parse result with the given function --- before comparing it.-expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) => -  StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()-expectParseEqOn parser input f expected = do-  ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input-  either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)-         (expectEqPP expected . f)-         ep+assertParseEqE+  :: (Default st, Eq a, Show a, HasCallStack)+  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a -> Assertion+assertParseEqE parser input = assertParseEqOnE parser input id -expectParseEqOnE-  :: (Monoid st, Eq b, Show b, HasCallStack)-  => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a-  -> T.Text-  -> (a -> b)-  -> b-  -> E.Test ()-expectParseEqOnE parser input f expected = do-  let filepath = ""-  eep <- E.io $ runExceptT $-           runParserT (evalStateT (parser <* eof) mempty) filepath input-  case eep of-    Left finalErr ->-      let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr-      in  fail $ "parse error at " <> prettyErr-    Right ep ->-      either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)-             (expectEqPP expected . f)-             ep+assertParseEqOnE+  :: (HasCallStack, Eq b, Show b, Default st)+  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> (a -> b) -> b -> Assertion+assertParseEqOnE parser input f expected =+  assertParseHelperE assertFailure (assertEqual "" expected . f) parser input --- | Run a stateful parser in IO like expectParse, then compare the--- final state (the wrapped state, not megaparsec's internal state),--- transformed by the given function, with the given expected value.-expectParseStateOn :: (HasCallStack, Monoid st, Eq b, Show b) =>-     StateT st (ParsecT CustomErr T.Text IO) a-  -> T.Text-  -> (st -> b)-  -> b-  -> E.Test ()-expectParseStateOn parser input f expected = do-  es <- E.io $ runParserT (execStateT (parser <* eof) mempty) "" input-  case es of-    Left err -> fail $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err-    Right s  -> expectEqPP expected $ f s+assertParseErrorE+  :: (Default st, Eq a, Show a, HasCallStack)+  => StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion+assertParseErrorE parser input errstr = assertParseHelperE+  (\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)+  (\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")+  parser input
Hledger/Utils/Text.hs view
@@ -2,97 +2,72 @@ -- There may be better alternatives out there.  {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}  module Hledger.Utils.Text   (- -- -- * misc- -- lowercase,- -- uppercase,- -- underline,- -- stripbrackets,+  -- * misc+  textCapitalise,+  -- underline,+  -- stripbrackets,   textUnbracket,- -- -- quoting+  wrap,+  textChomp,+  -- quoting   quoteIfSpaced,- -- quoteIfNeeded,- -- singleQuoteIfNeeded,- -- -- quotechars,- -- -- whitespacechars,+  textQuoteIfNeeded,+  -- singleQuoteIfNeeded,+  -- quotechars,+  -- whitespacechars,   escapeDoubleQuotes,- -- escapeSingleQuotes,- -- escapeQuotes,- -- words',- -- unwords',+  escapeBackslash,+  -- escapeSingleQuotes,+  -- escapeQuotes,+  -- words',   stripquotes,- -- isSingleQuoted,- -- isDoubleQuoted,- -- -- * single-line layout-  textstrip,-  textlstrip,-  textrstrip,- -- chomp,- -- elideLeft,+  -- isSingleQuoted,+  -- isDoubleQuoted,+  -- * single-line layout+  -- elideLeft,   textElideRight,- -- formatString,- -- -- * multi-line layout+  formatText,+  -- * multi-line layout   textConcatTopPadded,- -- concatBottomPadded,- -- concatOneLine,- -- vConcatLeftAligned,- -- vConcatRightAligned,- -- padtop,- -- padbottom,- -- padleft,- -- padright,- -- cliptopleft,- -- fitto,+  textConcatBottomPadded,   fitText,- -- -- * wide-character-aware layout-  textWidth,+  linesPrepend,+  linesPrepend2,+  unlinesB,+  -- * wide-character-aware layout+  WideBuilder(..),+  wbToText,+  wbFromText,+  wbUnpack,   textTakeWidth,- -- fitString,- -- fitStringMulti,-  textPadLeftWide,-  textPadRightWide,-  -- -- * tests+  -- * Reading+  readDecimal,+  -- * tests   tests_Text   ) where --- import Data.Char-import Data.List-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid-#endif+import Data.Char (digitToInt)+import Data.Default (def)+import Data.Maybe (catMaybes) import Data.Text (Text)-import qualified Data.Text as T--- import Text.Parsec--- import Text.Printf (printf)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Text.DocLayout (charWidth, realLength) --- import Hledger.Utils.Parse--- import Hledger.Utils.Regex-import Hledger.Utils.String (charWidth)-import Hledger.Utils.Test+import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Text.Tabular.AsciiWide+  (Align(..), Header(..), Properties(..), TableOpts(..), renderRow, textCell)+import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack) --- lowercase, uppercase :: String -> String--- lowercase = map toLower--- uppercase = map toUpper --- | Remove leading and trailing whitespace.-textstrip :: Text -> Text-textstrip = textlstrip . textrstrip---- | Remove leading whitespace.-textlstrip :: Text -> Text-textlstrip = T.dropWhile (`elem` (" \t" :: String)) :: Text -> Text -- XXX isSpace ?---- | Remove trailing whitespace.-textrstrip = T.reverse . textlstrip . T.reverse-textrstrip :: Text -> Text---- -- | Remove trailing newlines/carriage returns.--- chomp :: String -> String--- chomp = reverse . dropWhile (`elem` "\r\n") . reverse+textCapitalise :: Text -> Text+textCapitalise t = T.toTitle c <> cs where (c,cs) = T.splitAt 1 t  -- stripbrackets :: String -> String -- stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String@@ -105,16 +80,24 @@ textElideRight width t =     if T.length t > width then T.take (width - 2) t <> ".." else t --- -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.--- -- Works on multi-line strings too (but will rewrite non-unix line endings).--- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String--- formatString leftJustified minwidth maxwidth s = intercalate "\n" $ map (printf fmt) $ lines s---     where---       justify = if leftJustified then "-" else ""---       minwidth' = maybe "" show minwidth---       maxwidth' = maybe "" (("."++).show) maxwidth---       fmt = "%" ++ justify ++ minwidth' ++ maxwidth' ++ "s"+-- | Wrap a Text with the surrounding Text.+wrap :: Text -> Text -> Text -> Text+wrap start end x = start <> x <> end +-- | Remove trailing newlines/carriage returns.+textChomp :: Text -> Text+textChomp = T.dropWhileEnd (`elem` ['\r', '\n'])++-- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.+-- Works on multi-line strings too (but will rewrite non-unix line endings).+formatText :: Bool -> Maybe Int -> Maybe Int -> Text -> Text+formatText leftJustified minwidth maxwidth t =+    T.intercalate "\n" . map (pad . clip) $ if T.null t then [""] else T.lines t+  where+    pad  = maybe id justify minwidth+    clip = maybe id T.take maxwidth+    justify n = if leftJustified then T.justifyLeft n ' ' else T.justifyRight n ' '+ -- underline :: String -> String -- underline s = s' ++ replicate (length s) '-' ++ "\n" --     where s'@@ -126,8 +109,8 @@ -- double-quoted. quoteIfSpaced :: T.Text -> T.Text quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s-                | not $ any (`elem` (T.unpack s)) whitespacechars = s-                | otherwise = quoteIfNeeded s+                | not $ any (\c -> T.any (==c) s) whitespacechars = s+                | otherwise = textQuoteIfNeeded s  -- -- | Wrap a string in double quotes, and \-prefix any embedded single -- -- quotes, if it contains whitespace and is not already single- or@@ -139,9 +122,9 @@  -- -- | Double-quote this string if it contains whitespace, single quotes -- -- or double-quotes, escaping the quotes as needed.-quoteIfNeeded :: T.Text -> T.Text-quoteIfNeeded s | any (`elem` T.unpack s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""-                | otherwise = s+textQuoteIfNeeded :: T.Text -> T.Text+textQuoteIfNeeded s | any (\c -> T.any (==c) s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""+                    | otherwise = s  -- -- | Single-quote this string if it contains whitespace or double-quotes. -- -- No good for strings containing single quotes.@@ -156,6 +139,9 @@ escapeDoubleQuotes :: T.Text -> T.Text escapeDoubleQuotes = T.replace "\"" "\\\"" +escapeBackslash :: T.Text -> T.Text+escapeBackslash = T.replace "\\" "\\\\"+ -- escapeSingleQuotes :: T.Text -> T.Text -- escapeSingleQuotes = T.replace "'" "\'" @@ -175,120 +161,41 @@ --       singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") --       doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") --- -- | Quote-aware version of unwords - single-quote strings which contain whitespace--- unwords' :: [Text] -> Text--- unwords' = T.unwords . map quoteIfNeeded- -- | Strip one matching pair of single or double quotes on the ends of a string. stripquotes :: Text -> Text stripquotes s = if isSingleQuoted s || isDoubleQuoted s then T.init $ T.tail s else s  isSingleQuoted :: Text -> Bool isSingleQuoted s =-  T.length (T.take 2 s) == 2 && T.head s == '\'' && T.last s == '\''+  T.length s >= 2 && T.head s == '\'' && T.last s == '\''  isDoubleQuoted :: Text -> Bool isDoubleQuoted s =-  T.length (T.take 2 s) == 2 && T.head s == '"' && T.last s == '"'+  T.length s >= 2 && T.head s == '"' && T.last s == '"' +-- | Remove all matching pairs of square brackets and parentheses from the text. textUnbracket :: Text -> Text-textUnbracket s-    | (T.head s == '[' && T.last s == ']') || (T.head s == '(' && T.last s == ')') = T.init $ T.tail s-    | otherwise = s+textUnbracket s = T.drop stripN $ T.dropEnd stripN s+  where+    matchBracket :: Char -> Maybe Char+    matchBracket '(' = Just ')'+    matchBracket '[' = Just ']'+    matchBracket _ = Nothing +    expectedClosingBrackets = catMaybes $ takeWhile (/= Nothing) $ matchBracket <$> T.unpack s+    stripN = length $ takeWhile (uncurry (==)) $ zip expectedClosingBrackets $ reverse $ T.unpack s+ -- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded. -- Treats wide characters as double width. textConcatTopPadded :: [Text] -> Text-textConcatTopPadded ts = T.intercalate "\n" $ map T.concat $ transpose padded-    where-      lss = map T.lines ts :: [[Text]]-      h = maximum $ map length lss-      ypad ls = replicate (difforzero h (length ls)) "" ++ ls-      xpad ls = map (textPadLeftWide w) ls-        where w | null ls = 0-                | otherwise = maximum $ map textWidth ls-      padded = map (xpad . ypad) lss :: [[Text]]---- -- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.--- -- Treats wide characters as double width.--- concatBottomPadded :: [String] -> String--- concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded---     where---       lss = map lines strs---       h = maximum $ map length lss---       ypad ls = ls ++ replicate (difforzero h (length ls)) ""---       xpad ls = map (padRightWide w) ls where w | null ls = 0---                                                 | otherwise = maximum $ map strWidth ls---       padded = map (xpad . ypad) lss----- -- | Join multi-line strings horizontally, after compressing each of--- -- them to a single line with a comma and space between each original line.--- concatOneLine :: [String] -> String--- concatOneLine strs = concat $ map ((intercalate ", ").lines) strs---- -- | Join strings vertically, left-aligned and right-padded.--- vConcatLeftAligned :: [String] -> String--- vConcatLeftAligned ss = intercalate "\n" $ map showfixedwidth ss---     where---       showfixedwidth = printf (printf "%%-%ds" width)---       width = maximum $ map length ss---- -- | Join strings vertically, right-aligned and left-padded.--- vConcatRightAligned :: [String] -> String--- vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss---     where---       showfixedwidth = printf (printf "%%%ds" width)---       width = maximum $ map length ss---- -- | Convert a multi-line string to a rectangular string top-padded to the specified height.--- padtop :: Int -> String -> String--- padtop h s = intercalate "\n" xpadded---     where---       ls = lines s---       sh = length ls---       sw | null ls = 0---          | otherwise = maximum $ map length ls---       ypadded = replicate (difforzero h sh) "" ++ ls---       xpadded = map (padleft sw) ypadded---- -- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.--- padbottom :: Int -> String -> String--- padbottom h s = intercalate "\n" xpadded---     where---       ls = lines s---       sh = length ls---       sw | null ls = 0---          | otherwise = maximum $ map length ls---       ypadded = ls ++ replicate (difforzero h sh) ""---       xpadded = map (padleft sw) ypadded--difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]---- -- | Convert a multi-line string to a rectangular string left-padded to the specified width.--- -- Treats wide characters as double width.--- padleft :: Int -> String -> String--- padleft w "" = concat $ replicate w " "--- padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s---- -- | Convert a multi-line string to a rectangular string right-padded to the specified width.--- -- Treats wide characters as double width.--- padright :: Int -> String -> String--- padright w "" = concat $ replicate w " "--- padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s---- -- | Clip a multi-line string to the specified width and height from the top left.--- cliptopleft :: Int -> Int -> String -> String--- cliptopleft w h = intercalate "\n" . take h . map (take w) . lines+textConcatTopPadded = TL.toStrict . renderRow def{tableBorders=False, borderSpaces=False}+                    . Group NoLine . map (Header . textCell BottomLeft) --- -- | Clip and pad a multi-line string to fill the specified width and height.--- fitto :: Int -> Int -> String -> String--- fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline---     where---       rows = map (fit w) $ lines s---       fit w = take w . (++ repeat ' ')---       blankline = replicate w ' '+-- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.+-- Treats wide characters as double width.+textConcatBottomPadded :: [Text] -> Text+textConcatBottomPadded = TL.toStrict . renderRow def{tableBorders=False, borderSpaces=False}+                       . Group NoLine . map (Header . textCell TopLeft)  -- -- Functions below treat wide (eg CJK) characters as double-width. @@ -304,10 +211,10 @@     clip s =       case mmaxwidth of         Just w-          | textWidth s > w ->-            case rightside of-              True  -> textTakeWidth (w - T.length ellipsis) s <> ellipsis-              False -> ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s)+          | realLength s > max 0 w ->+            if rightside+              then textTakeWidth (w - T.length ellipsis) s <> ellipsis+              else ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s)           | otherwise -> s           where             ellipsis = if ellipsify then ".." else ""@@ -317,37 +224,12 @@       case mminwidth of         Just w           | sw < w ->-            case rightside of-              True  -> s <> T.replicate (w - sw) " "-              False -> T.replicate (w - sw) " " <> s+            if rightside+              then s <> T.replicate (w - sw) " "+              else T.replicate (w - sw) " " <> s           | otherwise -> s         Nothing -> s-      where sw = textWidth s---- -- | A version of fitString that works on multi-line strings,--- -- separate for now to avoid breakage.--- -- This will rewrite any line endings to unix newlines.--- fitStringMulti :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String--- fitStringMulti mminwidth mmaxwidth ellipsify rightside s =---   (intercalate "\n" . map (fitString mminwidth mmaxwidth ellipsify rightside) . lines) s---- | Left-pad a text to the specified width.--- Treats wide characters as double width.--- Works on multi-line texts too (but will rewrite non-unix line endings).-textPadLeftWide :: Int -> Text -> Text-textPadLeftWide w "" = T.replicate w " "-textPadLeftWide w s  = T.intercalate "\n" $ map (fitText (Just w) Nothing False False) $ T.lines s--- XXX not yet replaceable by--- padLeftWide w = fitStringMulti (Just w) Nothing False False---- | Right-pad a string to the specified width.--- Treats wide characters as double width.--- Works on multi-line strings too (but will rewrite non-unix line endings).-textPadRightWide :: Int -> Text -> Text-textPadRightWide w "" = T.replicate w " "-textPadRightWide w s  = T.intercalate "\n" $ map (fitText (Just w) Nothing False True) $ T.lines s--- XXX not yet replaceable by--- padRightWide w = fitStringMulti (Just w) Nothing False True+      where sw = realLength s  -- | Double-width-character-aware string truncation. Take as many -- characters as possible from a string without exceeding the@@ -362,72 +244,52 @@                 = T.cons c $ textTakeWidth (w-cw) (T.tail t)               | otherwise = "" --- -- from Pandoc (copyright John MacFarlane, GPL)--- -- see also http://unicode.org/reports/tr11/#Description+-- | Add a prefix to each line of a string.+linesPrepend :: Text -> Text -> Text+linesPrepend prefix = T.unlines . map (prefix<>) . T.lines --- | Calculate the designated render width of a string, taking into--- account wide characters and line breaks (the longest line within a--- multi-line string determines the width ).-textWidth :: Text -> Int-textWidth "" = 0-textWidth s = maximum $ map (T.foldr (\a b -> charWidth a + b) 0) $ T.lines s+-- | Add a prefix to the first line of a string, +-- and a different prefix to the remaining lines.+linesPrepend2 :: Text -> Text -> Text -> Text+linesPrepend2 prefix1 prefix2 s = T.unlines $ case T.lines s of+    []   -> []+    l:ls -> (prefix1<>l) : map (prefix2<>) ls --- -- | Get the designated render width of a character: 0 for a combining--- -- character, 1 for a regular character, 2 for a wide character.--- -- (Wide characters are rendered as exactly double width in apps and--- -- fonts that support it.) (From Pandoc.)--- charWidth :: Char -> Int--- charWidth c =---   case c of---       _ | c <  '\x0300'                    -> 1---         | c >= '\x0300' && c <= '\x036F'   -> 0  -- combining---         | c >= '\x0370' && c <= '\x10FC'   -> 1---         | c >= '\x1100' && c <= '\x115F'   -> 2---         | c >= '\x1160' && c <= '\x11A2'   -> 1---         | c >= '\x11A3' && c <= '\x11A7'   -> 2---         | c >= '\x11A8' && c <= '\x11F9'   -> 1---         | c >= '\x11FA' && c <= '\x11FF'   -> 2---         | c >= '\x1200' && c <= '\x2328'   -> 1---         | c >= '\x2329' && c <= '\x232A'   -> 2---         | c >= '\x232B' && c <= '\x2E31'   -> 1---         | c >= '\x2E80' && c <= '\x303E'   -> 2---         | c == '\x303F'                    -> 1---         | c >= '\x3041' && c <= '\x3247'   -> 2---         | c >= '\x3248' && c <= '\x324F'   -> 1 -- ambiguous---         | c >= '\x3250' && c <= '\x4DBF'   -> 2---         | c >= '\x4DC0' && c <= '\x4DFF'   -> 1---         | c >= '\x4E00' && c <= '\xA4C6'   -> 2---         | c >= '\xA4D0' && c <= '\xA95F'   -> 1---         | c >= '\xA960' && c <= '\xA97C'   -> 2---         | c >= '\xA980' && c <= '\xABF9'   -> 1---         | c >= '\xAC00' && c <= '\xD7FB'   -> 2---         | c >= '\xD800' && c <= '\xDFFF'   -> 1---         | c >= '\xE000' && c <= '\xF8FF'   -> 1 -- ambiguous---         | c >= '\xF900' && c <= '\xFAFF'   -> 2---         | c >= '\xFB00' && c <= '\xFDFD'   -> 1---         | c >= '\xFE00' && c <= '\xFE0F'   -> 1 -- ambiguous---         | c >= '\xFE10' && c <= '\xFE19'   -> 2---         | c >= '\xFE20' && c <= '\xFE26'   -> 1---         | c >= '\xFE30' && c <= '\xFE6B'   -> 2---         | c >= '\xFE70' && c <= '\xFEFF'   -> 1---         | c >= '\xFF01' && c <= '\xFF60'   -> 2---         | c >= '\xFF61' && c <= '\x16A38'  -> 1---         | c >= '\x1B000' && c <= '\x1B001' -> 2---         | c >= '\x1D000' && c <= '\x1F1FF' -> 1---         | c >= '\x1F200' && c <= '\x1F251' -> 2---         | c >= '\x1F300' && c <= '\x1F773' -> 1---         | c >= '\x20000' && c <= '\x3FFFD' -> 2---         | otherwise                        -> 1+-- | Join a list of Text Builders with a newline after each item.+unlinesB :: [TB.Builder] -> TB.Builder+unlinesB = foldMap (<> TB.singleton '\n') +-- | Read a decimal number from a Text. Assumes the input consists only of digit+-- characters.+readDecimal :: Text -> Integer+readDecimal = T.foldl' step 0+  where step a c = a * 10 + toInteger (digitToInt c) -tests_Text = tests "Text" [-   tests "quoteIfSpaced" [-     quoteIfSpaced "a'a" `is` "a'a"-    ,quoteIfSpaced "a\"a" `is` "a\"a"              -    ,quoteIfSpaced "a a" `is` "\"a a\""               -    ,quoteIfSpaced "mimi's cafe" `is` "\"mimi's cafe\""       -    ,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\""     -    ,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\""    -    ,quoteIfSpaced "\"be'any's\" cafe" `is` "\"\\\"be'any's\\\" cafe\"" -    ] ++tests_Text = testGroup "Text" [+   testCase "quoteIfSpaced" $ do+     quoteIfSpaced "a'a" @?= "a'a"+     quoteIfSpaced "a\"a" @?= "a\"a"+     quoteIfSpaced "a a" @?= "\"a a\""+     quoteIfSpaced "mimi's cafe" @?= "\"mimi's cafe\""+     quoteIfSpaced "\"alex\" cafe" @?= "\"\\\"alex\\\" cafe\""+     quoteIfSpaced "le'shan's cafe" @?= "\"le'shan's cafe\""+     quoteIfSpaced "\"be'any's\" cafe" @?= "\"\\\"be'any's\\\" cafe\"",+   testCase "textUnbracket" $ do+     textUnbracket "()" @?= ""+     textUnbracket "(a)" @?= "a"+     textUnbracket "(ab)" @?= "ab"+     textUnbracket "[ab]" @?= "ab"+     textUnbracket "([ab])" @?= "ab"+     textUnbracket "(()b)" @?= "()b"+     textUnbracket "[[]b]" @?= "[]b"+     textUnbracket "[()b]" @?= "()b"+     textUnbracket "[([]())]" @?= "[]()"+     textUnbracket "[([[[()]]])]" @?= ""+     textUnbracket "[([[[(]]])]" @?= "("+     textUnbracket "[([[[)]]])]" @?= ")",+   testCase "fitText" $ do+     fitText Nothing (Just (-2)) True True "" @?= ""+     fitText Nothing (Just 0) True True "" @?= ""+     fitText Nothing (Just 6) True True "Test Text" @?= "Test.."   ]
− Hledger/Utils/Tree.hs 
@@ -1,87 +0,0 @@-module Hledger.Utils.Tree where---- import Data.Char-import Data.List (foldl')-import qualified Data.Map as M-import Data.Tree--- import Text.Megaparsec--- import Text.Printf--import Hledger.Utils.Regex--- import Hledger.Utils.UTF8IOCompat (error')---- standard tree helpers--root = rootLabel-subs = subForest-branches = subForest---- | List just the leaf nodes of a tree-leaves :: Tree a -> [a]-leaves (Node v []) = [v]-leaves (Node _ branches) = concatMap leaves branches---- | get the sub-tree rooted at the first (left-most, depth-first) occurrence--- of the specified node value-subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)-subtreeat v t-    | root t == v = Just t-    | otherwise = subtreeinforest v $ subs t---- | get the sub-tree for the specified node value in the first tree in--- forest in which it occurs.-subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)-subtreeinforest _ [] = Nothing-subtreeinforest v (t:ts) = case (subtreeat v t) of-                             Just t' -> Just t'-                             Nothing -> subtreeinforest v ts---- | remove all nodes past a certain depth-treeprune :: Int -> Tree a -> Tree a-treeprune 0 t = Node (root t) []-treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)---- | apply f to all tree nodes-treemap :: (a -> b) -> Tree a -> Tree b-treemap f t = Node (f $ root t) (map (treemap f) $ branches t)---- | remove all subtrees whose nodes do not fulfill predicate-treefilter :: (a -> Bool) -> Tree a -> Tree a-treefilter f t = Node-                 (root t)-                 (map (treefilter f) $ filter (treeany f) $ branches t)---- | is predicate true in any node of tree ?-treeany :: (a -> Bool) -> Tree a -> Bool-treeany f t = f (root t) || any (treeany f) (branches t)---- treedrop -- remove the leaves which do fulfill predicate.--- treedropall -- do this repeatedly.---- | show a compact ascii representation of a tree-showtree :: Show a => Tree a -> String-showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show---- | show a compact ascii representation of a forest-showforest :: Show a => Forest a -> String-showforest = concatMap showtree----- | An efficient-to-build tree suggested by Cale Gibbard, probably--- better than accountNameTreeFrom.-newtype FastTree a = T (M.Map a (FastTree a))-  deriving (Show, Eq, Ord)--emptyTree = T M.empty--mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a-mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')--treeFromPath :: [a] -> FastTree a-treeFromPath []     = T M.empty-treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs))--treeFromPaths :: (Ord a) => [[a]] -> FastTree a-treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath--
− Hledger/Utils/UTF8IOCompat.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE CPP #-}-{- |--UTF-8 aware string IO functions that will work across multiple platforms-and GHC versions. Includes code from Text.Pandoc.UTF8 ((C) 2010 John-MacFarlane).--Example usage:-- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn)- import UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn)- import UTF8IOCompat   (SystemString,fromSystemString,toSystemString,error',userError')--2013/4/10 update: we now trust that current GHC versions & platforms-do the right thing, so this file is a no-op and on its way to being removed.-Not carefully tested.---}--- TODO obsolete ? --module Hledger.Utils.UTF8IOCompat (-  readFile,-  writeFile,-  appendFile,-  getContents,-  hGetContents,-  putStr,-  putStrLn,-  hPutStr,-  hPutStrLn,-  ---  SystemString,-  fromSystemString,-  toSystemString,-  error',-  userError',-  usageError,-)-where---- import Control.Monad (liftM)--- import qualified Data.ByteString.Lazy as B--- import qualified Data.ByteString.Lazy.Char8 as B8--- import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString)-import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn)-import System.IO -- (Handle)---- bom :: B.ByteString--- bom = B.pack [0xEF, 0xBB, 0xBF]---- stripBOM :: B.ByteString -> B.ByteString--- stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s--- stripBOM s = s---- readFile :: FilePath -> IO String--- readFile = liftM (U8.toString . stripBOM) . B.readFile---- writeFile :: FilePath -> String -> IO ()--- writeFile f = B.writeFile f . U8.fromString---- appendFile :: FilePath -> String -> IO ()--- appendFile f = B.appendFile f . U8.fromString---- getContents :: IO String--- getContents = liftM (U8.toString . stripBOM) B.getContents---- hGetContents :: Handle -> IO String--- hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h)---- putStr :: String -> IO ()--- putStr = bs_putStr . U8.fromString---- putStrLn :: String -> IO ()--- putStrLn = bs_putStrLn . U8.fromString---- hPutStr :: Handle -> String -> IO ()--- hPutStr h = bs_hPutStr h . U8.fromString---- hPutStrLn :: Handle -> String -> IO ()--- hPutStrLn h = bs_hPutStrLn h . U8.fromString---- -- span GHC versions including 6.12.3 - 7.4.1:--- bs_putStr         = B8.putStr--- bs_putStrLn       = B8.putStrLn--- bs_hPutStr        = B8.hPut--- bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a)----- | A string received from or being passed to the operating system, such--- as a file path, command-line argument, or environment variable name or--- value. With GHC versions before 7.2 on some platforms (posix) these are--- typically encoded. When converting, we assume the encoding is UTF-8 (cf--- <http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html#UTF8>).-type SystemString = String---- | Convert a system string to an ordinary string, decoding from UTF-8 if--- it appears to be UTF8-encoded and GHC version is less than 7.2.-fromSystemString :: SystemString -> String-fromSystemString = id---- | Convert a unicode string to a system string, encoding with UTF-8 if--- we are on a posix platform with GHC < 7.2.-toSystemString :: String -> SystemString-toSystemString = id---- | A SystemString-aware version of error.-error' :: String -> a-error' =-#if __GLASGOW_HASKELL__ < 800--- (easier than if base < 4.9)-  error . toSystemString-#else-  errorWithoutStackTrace . toSystemString-#endif---- | A SystemString-aware version of userError.-userError' :: String -> IOError-userError' = userError . toSystemString---- | A SystemString-aware version of error that adds a usage hint.-usageError :: String -> a-usageError = error' . (++ " (use -h to see usage)")  -
+ Hledger/Write/Beancount.hs view
@@ -0,0 +1,399 @@+{-|+Helpers for beancount output.+-}++{-# LANGUAGE OverloadedStrings    #-}++module Hledger.Write.Beancount (+  showTransactionBeancount,+  -- postingsAsLinesBeancount,+  -- postingAsLinesBeancount,+  -- showAccountNameBeancount,+  tagsToBeancountMetadata,+  showBeancountMetadata,+  accountNameToBeancount,+  commodityToBeancount,+  -- beancountTopLevelAccounts,++  -- * Tests+  tests_WriteBeancount+)+where++-- import Prelude hiding (Applicative(..))+import Data.Char+import Data.Default (def)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Safe (maximumBound)+import Text.DocLayout (realLength)+import Text.Printf+import Text.Tabular.AsciiWide hiding (render)++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Amount+import Hledger.Data.Currency (currencySymbolToCode)+import Hledger.Data.Dates (showDate)+import Hledger.Data.Posting (renderCommentLines, showBalanceAssertion, postingIndent)+import Hledger.Data.Transaction (payeeAndNoteFromDescription')+import Data.Function ((&))+import Data.List.Extra (groupOnKey)+import Data.Bifunctor (first)+import Data.List (intersperse, sort)+import Data.Maybe (catMaybes)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++-- | Like showTransaction, but applies various adjustments to produce valid Beancount journal data.+showTransactionBeancount :: Transaction -> Text+showTransactionBeancount t =+  -- https://beancount.github.io/docs/beancount_language_syntax.html+  -- similar to showTransactionHelper, but I haven't bothered with Builder+     firstline <> nl+  <> foldMap ((<> nl).postingIndent.showBeancountMetadata (Just maxmdnamewidth)) mds+  <> foldMap ((<> nl)) newlinecomments+  <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t)+  <> nl+  where+    firstline = T.concat [date, status, payee, note, samelinecomment]+    date = showDate $ tdate t+    status = if tstatus t == Pending then " !" else " *"+    (payee,note) =+      case payeeAndNoteFromDescription' $ tdescription t of+        ("","") -> ("",      ""      )+        ("",n ) -> (""     , wrapq n )+        (p ,"") -> (wrapq p, wrapq "")+        (p ,n ) -> (wrapq p, wrapq n )+      where+        wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash+    mds = tagsToBeancountMetadata $ ttags t+    maxmdnamewidth = maximum' $ map (T.length . fst) mds+    (samelinecomment, newlinecomments) =+      case renderCommentLines (tcomment t) of []   -> ("",[])+                                              c:cs -> (c,cs)++nl = "\n"++type BMetadata = Tag++-- https://beancount.github.io/docs/beancount_language_syntax.html#metadata-1+-- | Render a Beancount metadata as a metadata line (without the indentation or newline).+-- If a maximum name length is provided, space will be left after the colon+-- so that successive metadata values will all start at the same column.+showBeancountMetadata :: Maybe Int -> BMetadata -> Text+showBeancountMetadata mmaxnamewidth (n,v) =+  fitText (fmap (+2) mmaxnamewidth) Nothing False True (n <> ": ")+  <> toBeancountMetadataValue v++-- | Make a list of tags ready to be rendered as Beancount metadata:+-- Encode and lengthen names, encode values, and combine repeated tags into one.+-- Metadatas will be sorted by (encoded) name and then value.+tagsToBeancountMetadata :: [Tag] -> [BMetadata]+tagsToBeancountMetadata = sort . map (first toBeancountMetadataName) . uniquifyTags . filter (not.isHiddenTagName.fst)++-- | In a list of tags, replace each tag that appears more than once+-- with a single tag with all of the values combined into one, comma-and-space-separated.+-- This function also sorts all tags by name and then value.+uniquifyTags :: [Tag] -> [Tag]+uniquifyTags ts = [(k, T.intercalate ", " $ map snd $ tags) | (k, tags) <- groupOnKey fst $ sort ts]++toBeancountMetadataName :: TagName -> Text+toBeancountMetadataName name =+  prependStartCharIfNeeded $+  case T.uncons name of+    Nothing -> ""+    Just (c,cs) ->+      T.concatMap (\d -> if isBeancountMetadataNameChar d then T.singleton d else toBeancountMetadataNameChar d) $ T.cons c cs+  where+    -- If the name is empty, make it "mm".+    -- If it has only one character, prepend "m".+    -- If the first character is not a valid one, prepend "m".+    prependStartCharIfNeeded t =+      case T.uncons t of+        Nothing -> T.replicate 2 $ T.singleton beancountMetadataDummyNameStartChar+        Just (c,cs) | T.null cs || not (isBeancountMetadataNameStartChar c) -> T.cons beancountMetadataDummyNameStartChar t+        _ -> t++-- | Is this a valid character to start a Beancount metadata name (lowercase letter) ?+isBeancountMetadataNameStartChar :: Char -> Bool+isBeancountMetadataNameStartChar c = isLetter c && islowercase c++-- | Dummy valid starting character to prepend to a Beancount metadata name if needed.+beancountMetadataDummyNameStartChar :: Char+beancountMetadataDummyNameStartChar = 'm'++-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?+isBeancountMetadataNameChar :: Char -> Bool+isBeancountMetadataNameChar c = (isLetter c && islowercase c) || isDigit c || c `elem` ['_', '-']++-- | Convert a character to one or more characters valid inside a Beancount metadata name.+-- Letters are lowercased, spaces are converted to dashes, and unsupported characters are encoded as c<HEXBYTES>.+toBeancountMetadataNameChar :: Char -> Text+toBeancountMetadataNameChar c+  | isBeancountMetadataNameChar c = T.singleton c+  | isLetter c = T.singleton $ toLower c+  | isSpace c = "-"+  | otherwise = T.pack $ printf "c%x" c++toBeancountMetadataValue :: TagValue -> Text+toBeancountMetadataValue = ("\"" <>) . (<> "\"") . T.concatMap toBeancountMetadataValueChar++-- | Is this a valid character in the middle of a Beancount metadata name (a lowercase letter, digit, _ or -) ?+isBeancountMetadataValueChar :: Char -> Bool+isBeancountMetadataValueChar c = c `notElem` ['"']++-- | Convert a character to one or more characters valid inside a Beancount metadata value:+-- a double quote is encoded as c<HEXBYTES>.+toBeancountMetadataValueChar :: Char -> Text+toBeancountMetadataValueChar c+  | isBeancountMetadataValueChar c = T.singleton c+  | otherwise = T.pack $ printf "c%x" c+++-- | Render a transaction's postings as indented lines, suitable for `print -O beancount` output.+-- See also Posting.postingsAsLines.+postingsAsLinesBeancount :: [Posting] -> [Text]+postingsAsLinesBeancount ps = concatMap first3 linesWithWidths+  where+    linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps+    maxacctwidth = maximumBound 0 $ map second3 linesWithWidths+    maxamtwidth  = maximumBound 0 $ map third3  linesWithWidths++-- | Render one posting, on one or more lines, suitable for `print -O beancount` output.+-- Also returns the widths calculated for the account and amount fields.+-- See also Posting.postingAsLines.+postingAsLinesBeancount  :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int)+postingAsLinesBeancount elideamount acctwidth amtwidth p =+    (concatMap (++ (map ("  "<>) $ metadatalines <> newlinecomments)) postingblocks+    ,thisacctwidth+    ,thisamtwidth+    )+  where+    -- This needs to be converted to strict Text in order to strip trailing+    -- spaces. This adds a small amount of inefficiency, and the only difference+    -- is whether there are trailing spaces in print (and related) reports. This+    -- could be removed and we could just keep everything as a Text Builder, but+    -- would require adding trailing spaces to 42 failing tests.+    postingblocks = [map T.stripEnd . T.lines . TL.toStrict $+                       render [ textCell BottomLeft statusandaccount+                              , textCell BottomLeft "  "+                              , Cell BottomLeft [pad amt]+                              , textCell BottomLeft samelinecomment+                              ]+                    | (amt,_assertion) <- shownAmountsAssertions]+    render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header+    pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt+      where w = max 12 amtwidth - wbWidth amt  -- min. 12 for backwards compatibility++    pacct = showAccountNameBeancount Nothing $ paccount p+    pstatusandacct p' = if pstatus p' == Pending then "! " else "" <> pacct++    -- currently prices are considered part of the amount string when right-aligning amounts+    -- Since we will usually be calling this function with the knot tied between+    -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on+    -- amtwidth at all.+    shownAmounts+      | elideamount = [mempty]+      | otherwise   = map addCostBasis $ showMixedAmountLinesPartsB displayopts a'+        where+          displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayQuotes=False, displayCostBasis=False }+          a' = mapMixedAmount amountToBeancount $ pamount p+          addCostBasis (builder, amt) = builder <> showAmountCostBasisBeancountB displayopts amt+    thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts++    -- when there is a balance assertion, show it only on the last posting line+    shownAmountsAssertions = zip shownAmounts shownAssertions+      where+        shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion]+          where+            assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p++    -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned+    statusandaccount = postingIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p+    thisacctwidth = realLength pacct+    mds = tagsToBeancountMetadata $ ptags p+    metadatalines = map (postingIndent . showBeancountMetadata (Just maxtagnamewidth)) mds+      where maxtagnamewidth = maximum' $ map (T.length . fst) mds+    (samelinecomment, newlinecomments) =+      case renderCommentLines (pcomment p) of []   -> ("",[])+                                              c:cs -> (c,cs)++-- | Like showAccountName for Beancount journal format.+-- Calls accountNameToBeancount first.+showAccountNameBeancount :: Maybe Int -> AccountName -> Text+showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount++type BeancountAccountName = AccountName+type BeancountAccountNameComponent = AccountName++-- | Convert a hledger account name to a valid Beancount account name.+-- It replaces spaces with dashes and other non-supported characters with C<HEXBYTES>;+-- prepends the letter A to any part which doesn't begin with a letter or number;+-- adds a second :A part if there is only one part;+-- and capitalises each part.+-- It also checks that the first part is one of the required english+-- account names Assets, Liabilities, Equity, Income, or Expenses, and if not+-- raises an informative error.+-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#accounts+accountNameToBeancount :: AccountName -> BeancountAccountName+accountNameToBeancount a = b+  where+    cs1 =+      map accountNameComponentToBeancount $ accountNameComponents $+      dbg9 "hledger account name  " a+    cs2 =+      case cs1 of+        c:_ | c `notElem` beancountTopLevelAccounts -> error' e+          where+            e = T.unpack $ T.unlines [+              "bad top-level account: " <> c+              ,"in beancount account name:           " <> accountNameFromComponents cs1+              ,"converted from hledger account name: " <> a+              ,"For Beancount, top-level accounts must be (or be --alias'ed to)"+              ,"one of " <> T.intercalate ", " beancountTopLevelAccounts <> "."+              -- ,"and not: " <> b+              ]+        [c] -> [c, "A"]+        cs  -> cs+    b = dbg9 "beancount account name" $ accountNameFromComponents cs2++accountNameComponentToBeancount :: AccountName -> BeancountAccountNameComponent+accountNameComponentToBeancount acctpart =+  prependStartCharIfNeeded $+  case T.uncons acctpart of+    Nothing -> ""+    Just (c,cs) ->+      textCapitalise $+      T.concatMap (\d -> if isBeancountAccountChar d then (T.singleton d) else T.pack $ charToBeancount d) $ T.cons c cs+  where+    prependStartCharIfNeeded t =+      case T.uncons t of+        Just (c,_) | not $ isBeancountAccountStartChar c -> T.cons beancountAccountDummyStartChar t+        _ -> t++-- | Dummy valid starting character to prepend to Beancount account name parts if needed (A).+beancountAccountDummyStartChar :: Char+beancountAccountDummyStartChar = 'A'++charToBeancount :: Char -> String+charToBeancount c = if isSpace c then "-" else printf "C%x" c++-- XXX these probably allow too much unicode:++-- https://hackage.haskell.org/package/base-4.20.0.1/docs/Data-Char.html#v:isUpperCase would be more correct,+-- but isn't available till base 4.18/ghc 9.6. isUpper is close enough in practice.+isuppercase = isUpper+-- same story, presumably+islowercase = isLower++-- | Is this a valid character to start a Beancount account name part (capital letter or digit) ?+isBeancountAccountStartChar :: Char -> Bool+isBeancountAccountStartChar c = (isLetter c && isuppercase c) || isDigit c++-- | Is this a valid character to appear elsewhere in a Beancount account name part (letter, digit, or -) ?+isBeancountAccountChar :: Char -> Bool+isBeancountAccountChar c = isLetter c || isDigit c || c=='-'++beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"]++type BeancountAmount = Amount++-- | Do some best effort adjustments to make an amount that renders+-- in a way that Beancount can read: force the commodity symbol to the right,+-- capitalise all letters, convert a few currency symbols to codes.+amountToBeancount :: Amount -> BeancountAmount+amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'}+  where+    c' = commodityToBeancount c+    s' = s{ascommodityside=R, ascommodityspaced=True}+    mp' = costToBeancount <$> mp+      where+        costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt+        costToBeancount (UnitCost  amt) = UnitCost  $ amountToBeancount amt++-- | Show an amount's cost basis in Beancount lot syntax: {cost, date, label}+-- Returns a WideBuilder with the formatted cost basis, or mempty if there's no cost basis.+showAmountCostBasisBeancountB :: AmountFormat -> Amount -> WideBuilder+showAmountCostBasisBeancountB afmt amt = case acostbasis amt of+  Nothing -> mempty+  Just CostBasis{cbCost, cbDate, cbLabel} ->+    case parts of+      [] -> mempty+      _  -> WideBuilder (TB.fromString " {") 2 <> contents <> WideBuilder (TB.singleton '}') 1+    where+      parts = catMaybes+        [ fmap (showAmountB afmt . amountToBeancount) cbCost+        , fmap (wbFromText . T.pack . show) cbDate+        , fmap (wbFromText . quote) cbLabel+        ]+      contents = mconcat $ Data.List.intersperse (WideBuilder (TB.fromString ", ") 2) parts+      quote t = "\"" <> t <> "\""++type BeancountCommoditySymbol = CommoditySymbol++-- | Convert a hledger commodity name to a valid Beancount commodity name.+-- That is: 2-24 uppercase letters / digits / apostrophe / period / underscore / dash,+-- starting with a letter, and ending with a letter or digit.+-- Ref: https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies+-- So this:+-- replaces common currency symbols with their ISO 4217 currency codes,+-- capitalises all letters,+-- replaces spaces with dashes and other invalid characters with C<HEXBYTES>,+-- prepends a C if the first character is not a letter,+-- appends a C if the last character is not a letter or digit,+-- and disables hledger's enclosing double quotes.+--+-- >>> commodityToBeancount ""+-- "C"+-- >>> commodityToBeancount "$"+-- "USD"+-- >>> commodityToBeancount "Usd"+-- "USD"+-- >>> commodityToBeancount "\"a1\""+-- "A1"+-- >>> commodityToBeancount "\"A 1!\""+-- "A-1C21"+--+commodityToBeancount :: CommoditySymbol -> BeancountCommoditySymbol+commodityToBeancount com =+  dbg9 "beancount commodity name" $+  let com' = stripquotes com+  in case currencySymbolToCode com' of+    Just code -> code+    Nothing ->+      com'+      & T.toUpper+      & T.concatMap (\d -> if isBeancountCommodityChar d then T.singleton d else T.pack $ charToBeancount d)+      & fixstart+      & fixend+  where+    fixstart bcom = case T.uncons bcom of+      Just (c,_) | isBeancountCommodityStartChar c -> bcom+      _ -> "C" <> bcom+    fixend bcom = case T.unsnoc bcom of+      Just (_,c) | isBeancountCommodityEndChar c -> bcom+      _ -> bcom <> "C"++-- | Is this a valid character in the middle of a Beancount commodity name (a capital letter, digit, or '._-) ?+isBeancountCommodityChar :: Char -> Bool+isBeancountCommodityChar c = (isLetter c && isuppercase c) || isDigit c || c `elem` ['\'', '.', '_', '-']++-- | Is this a valid character to start a Beancount commodity name (a capital letter) ?+isBeancountCommodityStartChar :: Char -> Bool+isBeancountCommodityStartChar c = isLetter c && isuppercase c++-- | Is this a valid character to end a Beancount commodity name (a capital letter or digit) ?+isBeancountCommodityEndChar :: Char -> Bool+isBeancountCommodityEndChar c = (isLetter c && isuppercase c) || isDigit c++--- ** tests++tests_WriteBeancount :: TestTree+tests_WriteBeancount = testGroup "Write.Beancount" [+  ]
+ Hledger/Write/Csv.hs view
@@ -0,0 +1,56 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+{-|++CSV utilities.++-}++--- ** language+{-# LANGUAGE OverloadedStrings    #-}++--- ** exports+module Hledger.Write.Csv (+  CSV, CsvRecord, CsvValue,+  printCSV,+  printTSV,+  -- * Tests+  tests_CsvUtils,+)+where++--- ** imports+import Prelude hiding (Applicative(..))+import Data.List (intersperse)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB++import Hledger.Utils++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++type CSV       = [CsvRecord]+type CsvRecord = [CsvValue]+type CsvValue  = Text++printCSV :: CSV -> TL.Text+printCSV = TB.toLazyText . unlinesB . map printRecord+    where printRecord = foldMap TB.fromText . intersperse "," . map printField+          printField = wrap "\"" "\"" . T.replace "\"" "\"\""++printTSV :: CSV -> TL.Text+printTSV = TB.toLazyText . unlinesB . map printRecord+    where printRecord = foldMap TB.fromText . intersperse "\t" . map printField+          printField = T.map replaceWhitespace+          replaceWhitespace c | c `elem` ['\t', '\n', '\r'] = ' '+          replaceWhitespace c = c++--- ** tests++tests_CsvUtils :: TestTree+tests_CsvUtils = testGroup "CsvUtils" [+  ]
+ Hledger/Write/Html.hs view
@@ -0,0 +1,41 @@+{- |+HTML writing helpers.+This module would ideally hide the details of which HTML library is used, but it doesn't yet.++Currently hledger-web uses blaze-html, but hledger CLI reports use lucid.+lucid has a more usable API than blaze-html (https://chrisdone.com/posts/lucid).+lucid2's is even better.+Unfortunately lucid* can not render multi-line or indented text.+We want this so that humans can read and troubleshoot our HTML output.+So a transition to blaze-html may be coming.++-}++{-# LANGUAGE OverloadedStrings #-}++module Hledger.Write.Html (+  L.toHtml,+  Html,+  formatRow,+  htmlAsText,+  htmlAsLazyText,+  styledTableHtml,+  tests_Hledger_Write_Html+  ) where++import Data.Text qualified as T (Text)+import Data.Text.Lazy qualified as TL (Text, toStrict)+import Lucid qualified as L (renderText, toHtml)+import Test.Tasty (testGroup)++import Hledger.Write.Html.Lucid (Html, formatRow, styledTableHtml)+++htmlAsText :: Html -> T.Text+htmlAsText = TL.toStrict . L.renderText++htmlAsLazyText :: Html -> TL.Text+htmlAsLazyText = L.renderText++tests_Hledger_Write_Html = testGroup "Write.Html" [+  ]
+ Hledger/Write/Html/Attribute.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Helpers and CSS styles for HTML output.+-}+module Hledger.Write.Html.Attribute (+    stylesheet,+    concatStyles,+    tableStylesheet,+    tableStyle,+    bold,+    doubleborder,+    topdoubleborder,+    bottomdoubleborder,+    alignright,+    alignleft,+    aligncenter,+    collapse,+    lpad,+    rpad,+    hpad,+    vpad,+    ) where++import Data.Text qualified as Text+import Data.Text (Text)+++stylesheet :: [(Text,Text)] -> Text+stylesheet elstyles =+    Text.unlines $+        "" : [el<>" {"<>styles<>"}" | (el,styles) <- elstyles]++concatStyles :: [Text] -> Text+concatStyles = Text.intercalate "; "+++tableStylesheet :: Text+tableStylesheet = stylesheet tableStyle++tableStyle :: [(Text, Text)]+tableStyle =+  [("table", collapse),+   ("th, td", lpad),+   ("th.account, td.account", "padding-left:0;")]++bold, doubleborder, topdoubleborder, bottomdoubleborder :: Text+bold = "font-weight:bold"+doubleborder = "double black"+topdoubleborder    = "border-top:"<>doubleborder+bottomdoubleborder = "border-bottom:"<>doubleborder++alignright, alignleft, aligncenter :: Text+alignright  = "text-align:right"+alignleft   = "text-align:left"+aligncenter = "text-align:center"++collapse :: Text+collapse = "border-collapse:collapse"++lpad, rpad, hpad, vpad :: Text+lpad = "padding-left:1em"+rpad = "padding-right:1em"+hpad = "padding-left:1em; padding-right:1em"+vpad = "padding-top:1em;  padding-bottom:1em"
+ Hledger/Write/Html/Blaze.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+HTML writing helpers using blaze-html.+-}++module Hledger.Write.Html.Blaze (+    styledTableHtml,+    formatRow,+    formatCell,+    ) where++import Hledger.Write.Html.Attribute qualified as Attr+import Hledger.Write.Spreadsheet qualified as Spr+import Hledger.Write.Html.HtmlCommon (Lines, borderStyles)+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))++import Text.Blaze.Html4.Transitional.Attributes qualified as HtmlAttr+import Text.Blaze.Html4.Transitional qualified as Html+import Data.Text qualified as Text+import Text.Blaze.Html4.Transitional (Html, toHtml, (!))+import Data.Foldable (traverse_)+++-- | Export spreadsheet table data as HTML table.+-- This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html+styledTableHtml table = do+    Html.style $ toHtml $ Attr.tableStylesheet+    Html.table $ traverse_ formatRow table++formatRow:: (Lines border) => [Cell border Html] -> Html+formatRow = Html.tr . traverse_ formatCell++formatCell :: (Lines border) => Cell border Html -> Html+formatCell cell =+    let str = cellContent cell in+    let content =+            if Text.null $ cellAnchor cell+                then str+                else Html.a str !+                        HtmlAttr.href (Html.textValue (cellAnchor cell)) in+    let style =+            case borderStyles cell of+                [] -> []+                ss -> [HtmlAttr.style $ Html.textValue $+                        Attr.concatStyles ss] in+    let class_ =+            map (HtmlAttr.class_ . Html.textValue) $+            filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in+    let span_ makeCell attrs =+            case Spr.cellSpan cell of+                Spr.NoSpan -> foldl (!) makeCell attrs+                Spr.Covered -> pure ()+                Spr.SpanHorizontal n ->+                    foldl (!) makeCell+                        (HtmlAttr.colspan (Html.stringValue $ show n) : attrs)+                Spr.SpanVertical n ->+                    foldl (!) makeCell+                        (HtmlAttr.rowspan (Html.stringValue $ show n) : attrs)+            in+    case cellStyle cell of+        Head -> span_ (Html.th content) (style++class_)+        Body emph ->+            let align =+                    case cellType cell of+                        TypeString -> []+                        TypeDate -> []+                        _ -> [HtmlAttr.align "right"]+                valign =+                    case Spr.cellSpan cell of+                        Spr.SpanVertical n ->+                            if n>1 then [HtmlAttr.valign "top"] else []+                        _ -> []+                withEmph =+                    case emph of+                        Item -> id+                        Total -> Html.b+            in  span_ (Html.td $ withEmph content) $+                style++align++valign++class_
+ Hledger/Write/Html/HtmlCommon.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Common definitions used by both Html.Blaze and Html.Lucid.+-}++module Hledger.Write.Html.HtmlCommon (+    Lines(..),+    borderStyles,+    ) where++import Data.Text (Text)++import           Hledger.Write.Spreadsheet (Cell(..))+import Hledger.Write.Spreadsheet qualified as Spr+++borderStyles :: Lines border => Cell border text -> [Text]+borderStyles cell =+    let border field access =+            map (field<>) $ borderLines $ access $ cellBorder cell in+    let leftBorder   = border "border-left:"   Spr.borderLeft   in+    let rightBorder  = border "border-right:"  Spr.borderRight  in+    let topBorder    = border "border-top:"    Spr.borderTop    in+    let bottomBorder = border "border-bottom:" Spr.borderBottom in+    leftBorder++rightBorder++topBorder++bottomBorder+++class (Spr.Lines border) => Lines border where+    borderLines :: border -> [Text]++instance Lines () where+    borderLines () = []++instance Lines Spr.NumLines where+    borderLines prop =+        case prop of+            Spr.NoLine -> []+            Spr.SingleLine -> ["black"]+            Spr.DoubleLine -> ["double black"]
+ Hledger/Write/Html/Lucid.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+HTML writing helpers using lucid.+-}++module Hledger.Write.Html.Lucid (+    Html,+    L.toHtml,+    styledTableHtml,+    formatRow,+    formatCell,+    ) where++import           Data.Foldable (traverse_)+import Data.Text qualified as Text+import Lucid.Base qualified as L+import Lucid qualified as L++import Hledger.Write.Html.Attribute qualified as Attr+import           Hledger.Write.Html.HtmlCommon+import           Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))+import Hledger.Write.Spreadsheet qualified as Spr+++type Html = L.Html ()++-- | Export spreadsheet table data as HTML table.+-- This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html+styledTableHtml table = do+    L.link_ [L.rel_ "stylesheet", L.href_ "hledger.css"]+    L.style_ Attr.tableStylesheet+    L.table_ $ traverse_ formatRow table++formatRow:: (Lines border) => [Cell border Html] -> Html+formatRow = L.tr_ . traverse_ formatCell++formatCell :: (Lines border) => Cell border Html -> Html+formatCell cell =+    let str = cellContent cell in+    let content =+            if Text.null $ cellAnchor cell+                then str+                else L.a_ [L.href_ $ cellAnchor cell] str in+    let style =+            case borderStyles cell of+                [] -> []+                ss -> [L.style_ $ Attr.concatStyles ss] in+    let class_ =+            map L.class_ $+            filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in+    let span_ makeCell attrs cont =+            case Spr.cellSpan cell of+                Spr.NoSpan -> makeCell attrs cont+                Spr.Covered -> pure ()+                Spr.SpanHorizontal n ->+                    makeCell (L.colspan_ (Text.pack $ show n) : attrs) cont+                Spr.SpanVertical n ->+                    makeCell (L.rowspan_ (Text.pack $ show n) : attrs) cont+            in+    case cellStyle cell of+        Head -> span_ L.th_ (style++class_) content+        Body emph ->+            let align =+                    case cellType cell of+                        TypeString -> []+                        TypeDate -> []+                        _ -> [L.makeAttribute "align" "right"]+                valign =+                    case Spr.cellSpan cell of+                        Spr.SpanVertical n ->+                            if n>1+                                then [L.makeAttribute "valign" "top"]+                                else []+                        _ -> []+                withEmph =+                    case emph of+                        Item -> id+                        Total -> L.b_+            in  span_ L.td_ (style++align++valign++class_) $+                withEmph content+
+ Hledger/Write/Ods.hs view
@@ -0,0 +1,376 @@+{- |+Export table data as OpenDocument Spreadsheet+<https://docs.oasis-open.org/office/OpenDocument/v1.3/>.+This format supports character encodings, fixed header rows and columns,+number formatting, text styles, merged cells, formulas, hyperlinks.+Currently we support Flat ODS, a plain uncompressed XML format.++This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>++-}+module Hledger.Write.Ods (+    printFods,+    ) where++import Prelude hiding (Applicative(..))+import Control.Monad (guard)+import Control.Applicative (Applicative(..))++import Data.Text.Lazy qualified as TL+import Data.Text qualified as T+import Data.Text (Text)++import Data.Foldable qualified as Fold+import Data.List qualified as List+import Data.Map qualified as Map+import Data.Set qualified as Set+import Data.Foldable (fold)+import Data.Map (Map)+import Data.Set (Set)+import Data.Maybe (catMaybes)++import System.IO qualified as IO+import Text.Printf (printf)++import Hledger.Write.Spreadsheet qualified as Spr+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))+import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))+import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)++printFods ::+    IO.TextEncoding ->+    Map Text ((Int, Int), [[Cell Spr.NumLines Text]]) -> TL.Text+printFods encoding tables =+    let fileOpen customStyles =+          map (map (\c -> case c of '\'' -> '"'; _ -> c)) $+          printf "<?xml version='1.0' encoding='%s'?>" (show encoding) :+          "<office:document" :+          "  office:mimetype='application/vnd.oasis.opendocument.spreadsheet'" :+          "  office:version='1.3'" :+          "  xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'" :+          "  xmlns:xsd='http://www.w3.org/2001/XMLSchema'" :+          "  xmlns:text='urn:oasis:names:tc:opendocument:xmlns:text:1.0'" :+          "  xmlns:style='urn:oasis:names:tc:opendocument:xmlns:style:1.0'" :+          "  xmlns:meta='urn:oasis:names:tc:opendocument:xmlns:meta:1.0'" :+          "  xmlns:config='urn:oasis:names:tc:opendocument:xmlns:config:1.0'" :+          "  xmlns:xlink='http://www.w3.org/1999/xlink'" :+          "  xmlns:fo='urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0'" :+          "  xmlns:ooo='http://openoffice.org/2004/office'" :+          "  xmlns:office='urn:oasis:names:tc:opendocument:xmlns:office:1.0'" :+          "  xmlns:table='urn:oasis:names:tc:opendocument:xmlns:table:1.0'" :+          "  xmlns:number='urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0'" :+          "  xmlns:of='urn:oasis:names:tc:opendocument:xmlns:of:1.2'" :+          "  xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" :+          "  xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" :+          "<office:styles>" :+          "  <number:date-style style:name='iso-date'>" :+          "    <number:year number:style='long'/>" :+          "    <number:text>-</number:text>" :+          "    <number:month number:style='long'/>" :+          "    <number:text>-</number:text>" :+          "    <number:day number:style='long'/>" :+          "  </number:date-style>" :+          "  <number:number-style style:name='integer'>" :+          "    <number:number number:min-integer-digits='1'/>" :+          "  </number:number-style>" :+          customStyles +++          "</office:styles>" :+          []++        fileClose =+          "</office:document>" :+          []++        tableConfig tableNames =+          " <office:settings>" :+          "  <config:config-item-set config:name='ooo:view-settings'>" :+          "   <config:config-item-map-indexed config:name='Views'>" :+          "    <config:config-item-map-entry>" :+          "     <config:config-item-map-named config:name='Tables'>" :+          (fold $+           flip Map.mapWithKey tableNames $ \tableName (topRow,leftColumn) ->+             printf "      <config:config-item-map-entry config:name='%s'>" tableName :+             ((guard (leftColumn>0) >>) $+                "       <config:config-item config:name='HorizontalSplitMode' config:type='short'>2</config:config-item>" :+                printf "       <config:config-item config:name='HorizontalSplitPosition' config:type='int'>%d</config:config-item>" leftColumn :+                printf "       <config:config-item config:name='PositionRight' config:type='int'>%d</config:config-item>" leftColumn :+                []) +++             ((guard (topRow>0) >>) $+                "       <config:config-item config:name='VerticalSplitMode' config:type='short'>2</config:config-item>" :+                printf "       <config:config-item config:name='VerticalSplitPosition' config:type='int'>%d</config:config-item>" topRow :+                printf "       <config:config-item config:name='PositionBottom' config:type='int'>%d</config:config-item>" topRow :+                []) +++             "      </config:config-item-map-entry>" :+             []) +++          "     </config:config-item-map-named>" :+          "    </config:config-item-map-entry>" :+          "   </config:config-item-map-indexed>" :+          "  </config:config-item-set>" :+          " </office:settings>" :+          []++        tableOpen name =+          "<office:body>" :+          "<office:spreadsheet>" :+          printf "<table:table table:name='%s'>" name :+          []++        tableClose =+          "</table:table>" :+          "</office:spreadsheet>" :+          "</office:body>" :+          []++    in  TL.unlines $ map (TL.fromStrict . T.pack) $+        fileOpen+          (let styles = cellStyles (foldMap (concat.snd) tables) in+           (numberConfig =<< Set.toList (foldMap (numberParams.snd) styles))+           +++           (cellConfig =<< Set.toList styles)) +++        tableConfig (fmap fst tables) +++        (Map.toAscList tables >>= \(name,(_,table)) ->+            tableOpen name +++            (table >>= \row ->+                "<table:table-row>" :+                (row >>= formatCell) +++                "</table:table-row>" :+                []) +++            tableClose) +++        fileClose+++dataStyleFromType :: Type -> DataStyle+dataStyleFromType typ =+    case typ of+        TypeString -> DataString+        TypeInteger -> DataInteger+        TypeDate -> DataDate+        TypeAmount amt -> DataAmount (acommodity amt) (asprecision $ astyle amt)+        TypeMixedAmount -> DataMixedAmount++cellStyles ::+    (Ord border) =>+    [Cell border Text] ->+    Set ((Spr.Border border, Style), DataStyle)+cellStyles =+    Set.fromList .+    map (\cell ->+            ((cellBorder cell, cellStyle cell),+             dataStyleFromType $ cellType cell))++numberStyleName :: (CommoditySymbol, AmountPrecision) -> String+numberStyleName (comm, prec) =+    printf "%s-%s" comm $+    case prec of+        NaturalPrecision -> "natural"+        Precision k -> show k++numberParams :: DataStyle -> Set (CommoditySymbol, AmountPrecision)+numberParams (DataAmount comm prec) = Set.singleton (comm, prec)+numberParams _ = Set.empty++numberConfig :: (CommoditySymbol, AmountPrecision) -> [String]+numberConfig (comm, prec) =+    let precStr =+            case prec of+                NaturalPrecision -> ""+                Precision k -> printf " number:decimal-places='%d'" k+        name = numberStyleName (comm, prec)+    in+    printf "  <number:number-style style:name='number-%s'>" name :+    printf "    <number:number number:min-integer-digits='1'%s/>" precStr :+    printf "    <number:text>%s%s</number:text>"+      (if T.null comm then "" else " ") comm :+    "  </number:number-style>" :+    []++emphasisName :: Emphasis -> String+emphasisName emph =+    case emph of+        Item -> "item"+        Total -> "total"++cellStyleName :: Style -> String+cellStyleName style =+    case style of+        Head -> "head"+        Body emph -> emphasisName emph++linesName :: Spr.NumLines -> Maybe String+linesName prop =+    case prop of+        Spr.NoLine -> Nothing+        Spr.SingleLine -> Just "single"+        Spr.DoubleLine -> Just "double"++linesStyle :: Spr.NumLines -> String+linesStyle prop =+    case prop of+        Spr.NoLine -> "none"+        Spr.SingleLine -> "1.5pt solid #000000"+        Spr.DoubleLine -> "1.5pt double-thin #000000"++borderLabels :: Spr.Border String+borderLabels = Spr.Border "left" "right" "top" "bottom"++borderName :: Spr.Border Spr.NumLines -> String+borderName border =+    (\bs ->+        case bs of+            [] -> "noborder"+            _ ->+                ("border="++) $ List.intercalate "," $+                map (\(name,num) -> name ++ ':' : num) bs) $+    catMaybes $ Fold.toList $+    liftA2+        (\name numLines -> (,) name <$> linesName numLines)+        borderLabels+        border++borderStyle :: Spr.Border Spr.NumLines -> [String]+borderStyle border =+    if border == Spr.noBorder+        then []+        else (:[]) $+            printf "    <style:table-cell-properties%s/>" $+            (id :: String -> String) $ fold $+            liftA2 (printf " fo:border-%s='%s'") borderLabels $+            fmap linesStyle border++data DataStyle =+      DataString+    | DataInteger+    | DataDate+    | DataAmount CommoditySymbol AmountPrecision+    | DataMixedAmount+    deriving (Eq, Ord, Show)++cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]+cellConfig ((border, cstyle), dataStyle) =+    let boldStyle = "    <style:text-properties fo:font-weight='bold'/>"+        alignTop =+            "    <style:table-cell-properties style:vertical-align='top'/>"+        alignParagraph =+            printf "    <style:paragraph-properties fo:text-align='%s'/>"+        moreStyles =+            borderStyle border+            +++            (+            case cstyle of+                Body Item ->+                    alignTop :+                    []+                Body Total ->+                    alignTop :+                    boldStyle :+                    []+                Head ->+                    alignParagraph "center" :+                    boldStyle :+                    []+            )+            +++            (+            case dataStyle of+                DataMixedAmount -> [alignParagraph "end"]+                _ -> []+            )+        style :: String+        style =+            let (styleName,dataStyleName) = styleNames cstyle border dataStyle+            in  printf "style:name='%s'" styleName+                +++                foldMap (printf " style:data-style-name='%s'") dataStyleName+    in+    case moreStyles of+        [] ->+            printf "  <style:style style:family='table-cell' %s/>" style :+            []+        _ ->+            printf "  <style:style style:family='table-cell' %s>" style :+            moreStyles +++            "  </style:style>" :+            []+++formatCell :: Cell Spr.NumLines Text -> [String]+formatCell cell =+    let style, valueType :: String+        style =+            printf " table:style-name='%s'" $ fst $+            styleNames+                (cellStyle cell)+                (cellBorder cell)+                (dataStyleFromType $ cellType cell)++        valueType =+            case cellType cell of+                TypeInteger ->+                    printf+                        "office:value-type='float' office:value='%s'"+                        (cellContent cell)+                TypeAmount amt ->+                    printf+                        "office:value-type='float' office:value='%s'"+                        (show $ aquantity amt)+                TypeDate ->+                    printf+                        "office:value-type='date' office:date-value='%s'"+                        (cellContent cell)+                _ -> "office:value-type='string'"++        covered =+            case cellSpan cell of+                Spr.Covered -> "covered-"+                _ -> ""++        span_ =+            case cellSpan cell of+                Spr.SpanHorizontal n | n>1 ->+                    printf " table:number-columns-spanned='%d'" n+                Spr.SpanVertical n | n>1 ->+                    printf " table:number-rows-spanned='%d'" n+                _ -> ""++        anchor text =+            if T.null $ Spr.cellAnchor cell+                then text+                else printf "<text:a xlink:href='%s'>%s</text:a>"+                        (escape $ T.unpack $ Spr.cellAnchor cell) text++    in+    printf "<table:%stable-cell%s%s %s>" covered style span_ valueType :+    printf "<text:p>%s</text:p>"+        (anchor $ escape $ T.unpack $ cellContent cell) :+    printf "</table:%stable-cell>" covered :+    []++styleNames ::+    Style -> Spr.Border Spr.NumLines -> DataStyle -> (String, Maybe String)+styleNames cstyle border dataStyle =+    let cstyleName = cellStyleName cstyle in+    let bordName = borderName border in+    case dataStyle of+        DataDate ->+            (printf "%s-%s-date" cstyleName bordName, Just "iso-date")+        DataInteger ->+            (printf "%s-%s-integer" cstyleName bordName, Just "integer")+        DataAmount comm prec ->+            let name = numberStyleName (comm, prec) in+            (printf "%s-%s-%s" cstyleName bordName name,+                Just $ printf "number-%s" name)+        DataMixedAmount ->+            (printf "%s-%s-mixedamount" cstyleName bordName, Nothing)+        DataString -> (printf "%s-%s" cstyleName bordName, Nothing)++escape :: String -> String+escape =+    concatMap $ \c ->+        case c of+            '\n' -> "&#10;"+            '&' -> "&amp;"+            '<' -> "&lt;"+            '>' -> "&gt;"+            '"' -> "&quot;"+            '\'' -> "&apos;"+            _ -> [c]
+ Hledger/Write/Spreadsheet.hs view
@@ -0,0 +1,258 @@+{- |+Rich data type to describe data in a table.+This is the basis for ODS and HTML export.+-}+module Hledger.Write.Spreadsheet (+    Type(..),+    Style(..),+    Emphasis(..),+    Cell(..),+    Class(Class), textFromClass,+    Span(..),+    Border(..),+    Lines(..),+    NumLines(..),+    noBorder,+    defaultCell,+    headerCell,+    emptyCell,+    transposeCell,+    transpose,+    horizontalSpan,+    addHeaderBorders,+    addRowSpanHeader,+    rawTableContent,+    cellFromMixedAmount,+    cellsFromMixedAmount,+    cellFromAmount,+    integerCell,+    ) where++import Hledger.Data.Amount qualified as Amt+import Hledger.Data.Types (Amount, MixedAmount, acommodity)+import Hledger.Data.Amount (AmountFormat)++import Data.List qualified as List+import Data.Text qualified as Text+import Data.Text (Text)+import Text.WideString (WideBuilder)++import Prelude hiding (span)+++data Type =+      TypeString+    | TypeInteger+    | TypeAmount !Amount+    | TypeMixedAmount+    | TypeDate+    deriving (Eq, Ord, Show)++data Style = Body Emphasis | Head+    deriving (Eq, Ord, Show)++data Emphasis = Item | Total+    deriving (Eq, Ord, Show)+++class Lines border where noLine :: border+instance Lines () where noLine = ()+instance Lines NumLines where noLine = NoLine++{- |+The same as Tab.Properties, but has 'Eq' and 'Ord' instances.+We need those for storing 'NumLines' in 'Set's.+-}+data NumLines = NoLine | SingleLine | DoubleLine+    deriving (Eq, Ord, Show)++data Border lines =+    Border {+        borderLeft, borderRight,+        borderTop, borderBottom :: lines+    }+    deriving (Eq, Ord, Show)++instance Functor Border where+    fmap f (Border left right top bottom) =+        Border (f left) (f right) (f top) (f bottom)++instance Applicative Border where+    pure a = Border a a a a+    Border fLeft fRight fTop fBottom <*> Border left right top bottom =+        Border (fLeft left) (fRight right) (fTop top) (fBottom bottom)++instance Foldable Border where+    foldMap f (Border left right top bottom) =+        f left <> f right <> f top <> f bottom++noBorder :: (Lines border) => Border border+noBorder = pure noLine++transposeBorder :: Border lines -> Border lines+transposeBorder (Border left right top bottom) =+    Border top bottom left right+++newtype Class = Class Text++textFromClass :: Class -> Text+textFromClass (Class cls) = cls+++{- |+* 'NoSpan' means a single unmerged cell.++* 'Covered' is a cell if it is part of a horizontally or vertically merged cell.+  We maintain these cells although they are ignored in HTML output.+  In contrast to that, FODS can store covered cells+  and allows to access the hidden cell content via formulas.+  CSV does not support merged cells+  and thus simply writes the content of covered cells.+  Maintaining 'Covered' cells also simplifies transposing.++* @'SpanHorizontal' n@ denotes the first cell in a row+  that is part of a merged cell.+  The merged cell contains @n@ atomic cells, including the first one.+  That is @SpanHorizontal 1@ is actually like @NoSpan@.+  The content of this cell is shown as content of the merged cell.++* @'SpanVertical' n@ starts a vertically merged cell.++The writer functions expect consistent data,+that is, 'Covered' cells must actually be part of a merged cell+and merged cells must only cover 'Covered' cells.+-}+data Span =+      NoSpan+    | Covered+    | SpanHorizontal Int+    | SpanVertical Int+    deriving (Eq)++transposeSpan :: Span -> Span+transposeSpan span =+    case span of+        NoSpan -> NoSpan+        Covered -> Covered+        SpanHorizontal n -> SpanVertical n+        SpanVertical n -> SpanHorizontal n++data Cell border text =+    Cell {+        cellType :: Type,+        cellBorder :: Border border,+        cellStyle :: Style,+        cellSpan :: Span,+        cellAnchor :: Text,+        cellClass :: Class,+        cellContent :: text+    }++instance Functor (Cell border) where+    fmap f (Cell typ border style span anchor class_ content) =+        Cell typ border style span anchor class_ $ f content++defaultCell :: (Lines border) => text -> Cell border text+defaultCell text =+    Cell {+        cellType = TypeString,+        cellBorder = noBorder,+        cellStyle = Body Item,+        cellSpan = NoSpan,+        cellAnchor = mempty,+        cellClass = Class mempty,+        cellContent = text+    }++headerCell :: (Lines borders) => Text -> Cell borders Text+headerCell text = (defaultCell text) {cellStyle = Head}++emptyCell :: (Lines border, Monoid text) => Cell border text+emptyCell = defaultCell mempty++transposeCell :: Cell border text -> Cell border text+transposeCell cell =+    cell {+        cellBorder = transposeBorder $ cellBorder cell,+        cellSpan = transposeSpan $ cellSpan cell+    }++transpose :: [[Cell border text]] -> [[Cell border text]]+transpose = List.transpose . map (map transposeCell)+++addHeaderBorders :: [Cell () text] -> [Cell NumLines text]+addHeaderBorders =+    map (\c -> c {cellBorder = noBorder {borderBottom = DoubleLine}})++horizontalSpan ::+    (Lines border, Monoid text) =>+    [a] -> Cell border text -> [Cell border text]+horizontalSpan subCells cell =+    zipWith const+        (cell{cellSpan = SpanHorizontal $ length subCells}+            : repeat (emptyCell {cellSpan = Covered}))+        subCells++addRowSpanHeader ::+    Cell border text ->+    [[Cell border text]] -> [[Cell border text]]+addRowSpanHeader header rows =+    case rows of+        [] -> []+        [row] -> [header:row]+        _ ->+            zipWith (:)+                (header{cellSpan = SpanVertical (length rows)} :+                 repeat header{cellSpan = Covered})+                rows++rawTableContent :: [[Cell border text]] -> [[text]]+rawTableContent = map (map cellContent)++++cellFromMixedAmount ::+    (Lines border) =>+    AmountFormat -> (Class, MixedAmount) -> Cell border WideBuilder+cellFromMixedAmount bopts (cls, mixedAmt) =+    (defaultCell $ Amt.showMixedAmountB bopts mixedAmt) {+        cellClass = cls,+        cellType =+          case Amt.unifyMixedAmount mixedAmt of+            Just amt -> amountType bopts amt+            Nothing -> TypeMixedAmount+    }++cellsFromMixedAmount ::+    (Lines border) =>+    AmountFormat -> (Class, MixedAmount) -> [Cell border WideBuilder]+cellsFromMixedAmount bopts (cls, mixedAmt) =+    map+        (\(str,amt) ->+            (defaultCell str) {+                cellClass = cls,+                cellType = amountType bopts amt+            })+        (Amt.showMixedAmountLinesPartsB bopts mixedAmt)++cellFromAmount ::+    (Lines border) =>+    AmountFormat -> (Class, (wb, Amount)) -> Cell border wb+cellFromAmount bopts (cls, (str,amt)) =+    (defaultCell str) {+        cellClass = cls,+        cellType = amountType bopts amt+    }++amountType :: AmountFormat -> Amount -> Type+amountType bopts amt =+    TypeAmount $+    if Amt.displayCommodity bopts+      then amt+      else amt {acommodity = Text.empty}+++integerCell :: (Lines border) => Integer -> Cell border Text+integerCell k = (defaultCell $ Text.pack $ show k) {cellType = TypeInteger}
LICENSE view
@@ -1,7 +1,7 @@                     GNU GENERAL PUBLIC LICENSE                        Version 3, 29 June 2007 - Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>  Everyone is permitted to copy and distribute verbatim copies  of this license document, but changing it is not allowed. @@ -645,7 +645,7 @@     GNU General Public License for more details.      You should have received a copy of the GNU General Public License-    along with this program.  If not, see <http://www.gnu.org/licenses/>.+    along with this program.  If not, see <https://www.gnu.org/licenses/>.  Also add information on how to contact you by electronic and paper mail. @@ -664,11 +664,11 @@   You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.+<https://www.gnu.org/licenses/>.    The GNU General Public License does not permit incorporating your program into proprietary programs.  If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library.  If this is what you want to do, use the GNU Lesser General Public License instead of this License.  But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.+<https://www.gnu.org/licenses/why-not-lgpl.html>.
− README 
@@ -1,3 +0,0 @@-A reusable library containing hledger's core functionality.-This is used by most hledger* packages for common data parsing,-command line option handling, reporting etc.
+ README.md view
@@ -0,0 +1,9 @@+# hledger-lib++A reusable library containing hledger's core functionality.+This is used by most hledger* packages so that they support the same+common file formats, command line options, reports etc.++See also:+the [project README](https://hledger.org/README.html)+and [home page](https://hledger.org).
− Text/Megaparsec/Custom.hs 
@@ -1,420 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} -- new-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} -- new--module Text.Megaparsec.Custom (-  -- * Custom parse error type-  CustomErr,--  -- * Failing with an arbitrary source position-  parseErrorAt,-  parseErrorAtRegion,--  -- * Re-parsing-  SourceExcerpt,-  getExcerptText,--  excerpt_,-  reparseExcerpt,--  -- * Pretty-printing custom parse errors-  customErrorBundlePretty,---  -- * "Final" parse errors-  FinalParseError,-  FinalParseError',-  FinalParseErrorBundle,-  FinalParseErrorBundle',--  -- * Constructing "final" parse errors-  finalError,-  finalFancyFailure,-  finalFail,-  finalCustomFailure,--  -- * Pretty-printing "final" parse errors-  finalErrorBundlePretty,-  attachSource,--  -- * Handling parse errors from include files with "final" parse errors-  parseIncludeFile,-)-where--import Prelude ()-import "base-compat-batteries" Prelude.Compat hiding (readFile)--import Control.Monad.Except-import Control.Monad.State.Strict (StateT, evalStateT)-import Data.Foldable (asum, toList)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as S-import Data.Text (Text)-import Text.Megaparsec------ * Custom parse error type---- | A custom error type for the parser. The type is specialized to--- parsers of 'Text' streams.--data CustomErr-  -- | Fail with a message at a specific source position interval. The-  -- interval must be contained within a single line.-  = ErrorFailAt Int -- Starting offset-                Int -- Ending offset-                String -- Error message-  -- | Re-throw parse errors obtained from the "re-parsing" of an excerpt-  -- of the source text.-  | ErrorReparsing-      (NE.NonEmpty (ParseError Text CustomErr)) -- Source fragment parse errors-  deriving (Show, Eq, Ord)---- We require an 'Ord' instance for 'CustomError' so that they may be--- stored in a 'Set'. The actual instance is inconsequential, so we just--- derive it, but the derived instance requires an (orphan) instance for--- 'ParseError'. Hopefully this does not cause any trouble.--deriving instance Ord (ParseError Text CustomErr)---- Note: the pretty-printing of our 'CustomErr' type is only partally--- defined in its 'ShowErrorComponent' instance; we perform additional--- adjustments in 'customErrorBundlePretty'.--instance ShowErrorComponent CustomErr where-  showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg-  showErrorComponent (ErrorReparsing _) = "" -- dummy value--  errorComponentLen (ErrorFailAt startOffset endOffset _) =-    endOffset - startOffset-  errorComponentLen (ErrorReparsing _) = 1 -- dummy value------ * Failing with an arbitrary source position---- | Fail at a specific source position, given by the raw offset from the--- start of the input stream (the number of tokens processed at that--- point).--parseErrorAt :: Int -> String -> CustomErr-parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg---- | Fail at a specific source interval, given by the raw offsets of its--- endpoints from the start of the input stream (the numbers of tokens--- processed at those points).------ Note that care must be taken to ensure that the specified interval does--- not span multiple lines of the input source. This will not be checked.--parseErrorAtRegion-  :: Int    -- ^ Start offset-  -> Int    -- ^ End end offset-  -> String -- ^ Error message-  -> CustomErr-parseErrorAtRegion startOffset endOffset msg =-  if startOffset < endOffset-    then ErrorFailAt startOffset endOffset msg-    else ErrorFailAt startOffset (startOffset+1) msg------ * Re-parsing---- | A fragment of source suitable for "re-parsing". The purpose of this--- data type is to preserve the content and source position of the excerpt--- so that parse errors raised during "re-parsing" may properly reference--- the original source.--data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt-                                   Text -- Fragment of source file---- | Get the raw text of a source excerpt.--getExcerptText :: SourceExcerpt -> Text-getExcerptText (SourceExcerpt _ txt) = txt---- | 'excerpt_ p' applies the given parser 'p' and extracts the portion of--- the source consumed by 'p', along with the source position of this--- portion. This is the only way to create a source excerpt suitable for--- "re-parsing" by 'reparseExcerpt'.---- This function could be extended to return the result of 'p', but we don't--- currently need this.--excerpt_ :: MonadParsec CustomErr Text m => m a -> m SourceExcerpt-excerpt_ p = do-  offset <- getOffset-  (!txt, _) <- match p-  pure $ SourceExcerpt offset txt---- | 'reparseExcerpt s p' "re-parses" the source excerpt 's' using the--- parser 'p'. Parse errors raised by 'p' will be re-thrown at the source--- position of the source excerpt.------ In order for the correct source file to be displayed when re-throwing--- parse errors, we must ensure that the source file during the use of--- 'reparseExcerpt s p' is the same as that during the use of 'excerpt_'--- that generated the source excerpt 's'. However, we can usually expect--- this condition to be satisfied because, at the time of writing, the--- only changes of source file in the codebase take place through include--- files, and the parser for include files neither accepts nor returns--- 'SourceExcerpt's.--reparseExcerpt-  :: Monad m-  => SourceExcerpt-  -> ParsecT CustomErr Text m a-  -> ParsecT CustomErr Text m a-reparseExcerpt (SourceExcerpt offset txt) p = do-  (_, res) <- lift $ runParserT' p (offsetInitialState offset txt)-  case res of-    Right result -> pure result-    Left errBundle -> customFailure $ ErrorReparsing $ bundleErrors errBundle--  where-    offsetInitialState :: Int -> s -> State s-    offsetInitialState initialOffset s = State-      { stateInput  = s-      , stateOffset = initialOffset-      , statePosState = PosState-        { pstateInput = s-        , pstateOffset = initialOffset-        , pstateSourcePos = initialPos ""-        , pstateTabWidth = defaultTabWidth-        , pstateLinePrefix = ""-        }-      }----- * Pretty-printing custom parse errors---- | Pretty-print our custom parse errors. It is necessary to use this--- instead of 'errorBundlePretty' when custom parse errors are thrown.------ This function intercepts our custom parse errors and applies final--- adjustments ('finalizeCustomError') before passing them to--- 'errorBundlePretty'. These adjustments are part of the implementation--- of the behaviour of our custom parse errors.------ Note: We must ensure that the offset of the 'PosState' of the provided--- 'ParseErrorBundle' is no larger than the offset specified by a--- 'ErrorFailAt' constructor. This is guaranteed if this offset is set to--- 0 (that is, the beginning of the source file), which is the--- case for 'ParseErrorBundle's returned from 'runParserT'.--customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String-customErrorBundlePretty errBundle =-  let errBundle' = errBundle { bundleErrors =-        NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets-        bundleErrors errBundle >>= finalizeCustomError }-  in  errorBundlePretty errBundle'--  where-    finalizeCustomError-      :: ParseError Text CustomErr -> NE.NonEmpty (ParseError Text CustomErr)-    finalizeCustomError err = case findCustomError err of-      Nothing -> pure err--      Just errFailAt@(ErrorFailAt startOffset _ _) ->-        -- Adjust the offset-        pure $ FancyError startOffset $ S.singleton $ ErrorCustom errFailAt--      Just (ErrorReparsing errs) ->-        -- Extract and finalize the inner errors-        errs >>= finalizeCustomError--    -- If any custom errors are present, arbitrarily take the first one-    -- (since only one custom error should be used at a time).-    findCustomError :: ParseError Text CustomErr -> Maybe CustomErr-    findCustomError err = case err of-      FancyError _ errSet -> -        finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet-      _ -> Nothing--    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b-    finds f = asum . map f . toList------ * "Final" parse errors------ | A type representing "final" parse errors that cannot be backtracked--- from and are guaranteed to halt parsing. The anti-backtracking--- behaviour is implemented by an 'ExceptT' layer in the parser's monad--- stack, using this type as the 'ExceptT' error type.------ We have three goals for this type:--- (1) it should be possible to convert any parse error into a "final"--- parse error,--- (2) it should be possible to take a parse error thrown from an include--- file and re-throw it in the parent file, and--- (3) the pretty-printing of "final" parse errors should be consistent--- with that of ordinary parse errors, but should also report a stack of--- files for errors thrown from include files.------ In order to pretty-print a "final" parse error (goal 3), it must be--- bundled with include filepaths and its full source text. When a "final"--- parse error is thrown from within a parser, we do not have access to--- the full source, so we must hold the parse error until it can be joined--- with its source (and include filepaths, if it was thrown from an--- include file) by the parser's caller.------ A parse error with include filepaths and its full source text is--- represented by the 'FinalParseErrorBundle' type, while a parse error in--- need of either include filepaths, full source text, or both is--- represented by the 'FinalParseError' type.--data FinalParseError' e-  -- a parse error thrown as a "final" parse error-  = FinalError           (ParseError Text e)-  -- a parse error obtained from running a parser, e.g. using 'runParserT'-  | FinalBundle          (ParseErrorBundle Text e)-  -- a parse error thrown from an include file-  | FinalBundleWithStack (FinalParseErrorBundle' e)-  deriving (Show)--type FinalParseError = FinalParseError' CustomErr---- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT--- FinalParseError m' is an instance of Alternative and MonadPlus, which--- is needed to use some parser combinators, e.g. 'many'.------ This monoid instance simply takes the first (left-most) error.--instance Semigroup (FinalParseError' e) where-  e <> _ = e--instance Monoid (FinalParseError' e) where-  mempty = FinalError $ FancyError 0 $-            S.singleton (ErrorFail "default parse error")-  mappend = (<>)---- | A type bundling a 'ParseError' with its full source text, filepath,--- and stack of include files. Suitable for pretty-printing.------ Megaparsec's 'ParseErrorBundle' type already bundles a parse error with--- its full source text and filepath, so we just add a stack of include--- files.--data FinalParseErrorBundle' e = FinalParseErrorBundle'-  { finalErrorBundle :: ParseErrorBundle Text e-  , includeFileStack :: [FilePath]-  } deriving (Show)--type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr------ * Constructing and throwing final parse errors---- | Convert a "regular" parse error into a "final" parse error.--finalError :: ParseError Text e -> FinalParseError' e-finalError = FinalError---- | Like megaparsec's 'fancyFailure', but as a "final" parse error.--finalFancyFailure-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)-  => S.Set (ErrorFancy e) -> m a-finalFancyFailure errSet = do-  offset <- getOffset-  throwError $ FinalError $ FancyError offset errSet---- | Like 'fail', but as a "final" parse error.--finalFail-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a-finalFail = finalFancyFailure . S.singleton . ErrorFail---- | Like megaparsec's 'customFailure', but as a "final" parse error.--finalCustomFailure-  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a-finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom------ * Pretty-printing "final" parse errors---- | Pretty-print a "final" parse error: print the stack of include files,--- then apply the pretty-printer for parse error bundles. Note that--- 'attachSource' must be used on a "final" parse error before it can be--- pretty-printed.--finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String-finalErrorBundlePretty bundle =-     concatMap showIncludeFilepath (includeFileStack bundle)-  <> customErrorBundlePretty (finalErrorBundle bundle)-  where-    showIncludeFilepath path = "in file included from " <> path <> ",\n"---- | Supply a filepath and source text to a "final" parse error so that it--- can be pretty-printed. You must ensure that you provide the appropriate--- source text and filepath.--attachSource-  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e-attachSource filePath sourceText finalParseError = case finalParseError of--  -- A parse error thrown directly with the 'FinalError' constructor-  -- requires both source and filepath.-  FinalError parseError ->-    let bundle = ParseErrorBundle-          { bundleErrors = parseError NE.:| []-          , bundlePosState = initialPosState filePath sourceText }-    in  FinalParseErrorBundle'-          { finalErrorBundle = bundle-          , includeFileStack  = [] }--  -- A 'ParseErrorBundle' already has the appropriate source and filepath-  -- and so needs neither.-  FinalBundle peBundle -> FinalParseErrorBundle'-    { finalErrorBundle = peBundle-    , includeFileStack = [] }--  -- A parse error from a 'FinalParseErrorBundle' was thrown from an-  -- include file, so we add the filepath to the stack.-  FinalBundleWithStack fpeBundle -> fpeBundle-    { includeFileStack = filePath : includeFileStack fpeBundle }------ * Handling parse errors from include files with "final" parse errors---- | Parse a file with the given parser and initial state, discarding the--- final state and re-throwing any parse errors as "final" parse errors.--parseIncludeFile-  :: Monad m-  => StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a-  -> st-  -> FilePath-  -> Text-  -> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a-parseIncludeFile parser initialState filepath text =-  catchError parser' handler-  where-    parser' = do-      eResult <- lift $ lift $-                  runParserT (evalStateT parser initialState) filepath text-      case eResult of-        Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle-        Right result -> pure result--    -- Attach source and filepath of the include file to its parse errors-    handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e------ * Helpers---- Like megaparsec's 'initialState', but instead for 'PosState'. Used when--- constructing 'ParseErrorBundle's. The values for "tab width" and "line--- prefix" are taken from 'initialState'.--initialPosState :: FilePath -> Text -> PosState Text-initialPosState filePath sourceText = PosState-  { pstateInput      = sourceText-  , pstateOffset     = 0-  , pstateSourcePos  = initialPos filePath-  , pstateTabWidth   = defaultTabWidth-  , pstateLinePrefix = "" }
Text/Tabular/AsciiWide.hs view
@@ -1,111 +1,306 @@ -- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat -- wide characters as double width. -module Text.Tabular.AsciiWide where+{-# LANGUAGE OverloadedStrings #-} +module Text.Tabular.AsciiWide+( module Text.Tabular++, TableOpts(..)+, render+, renderTable+, renderTableB+, renderTableByRowsB+, renderRow+, renderRowB+, renderColumns++, Cell(..)+, Align(..)+, emptyCell+, textCell+, textsCell+, cellWidth+, concatTables+) where++import Data.Bifunctor (bimap)+import Data.Maybe (fromMaybe)+import Data.Default (Default(..)) import Data.List (intersperse, transpose)+import Data.Semigroup (stimesMonoid)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText)+import Safe (maximumMay) import Text.Tabular-import Hledger.Utils.String+import Text.WideString (WideBuilder(..), wbFromText) --- | for simplicity, we assume that each cell is rendered---   on a single line-render :: Bool -- ^ pretty tables-       -> (rh -> String)-       -> (ch -> String)-       -> (a -> String)-       -> Table rh ch a-       -> String-render pretty fr fc f (Table rh ch cells) =-  unlines $ [ bar SingleLine   -- +--------------------------------------+-            , renderColumns pretty sizes ch2-            , bar DoubleLine   -- +======================================+-            ] ++-            (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) ++-            [ bar SingleLine ] -- +--------------------------------------+++-- | The options to use for rendering a table.+data TableOpts = TableOpts+  { prettyTable  :: Bool  -- ^ Pretty tables+  , tableBorders :: Bool  -- ^ Whether to display the outer borders+  , borderSpaces :: Bool  -- ^ Whether to display spaces around bars+  } deriving (Show)++instance Default TableOpts where+  def = TableOpts { prettyTable  = False+                  , tableBorders = True+                  , borderSpaces = True+                  }++-- | Cell contents along an alignment+data Cell = Cell Align [WideBuilder]++-- | How to align text in a cell+data Align = TopRight | BottomRight | BottomLeft | TopLeft+  deriving (Show)++emptyCell :: Cell+emptyCell = Cell TopRight []++-- | Create a single-line cell from the given contents with its natural width.+textCell :: Align -> Text -> Cell+textCell a x = Cell a . map wbFromText $ if T.null x then [""] else T.lines x++-- | Create a multi-line cell from the given contents with its natural width.+textsCell :: Align -> [Text] -> Cell+textsCell a = Cell a . fmap wbFromText++-- | Return the width of a Cell.+cellWidth :: Cell -> Int+cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map wbWidth xs+++-- | Render a table according to common options, for backwards compatibility+render :: Show a => Bool -> (rh -> Text) -> (ch -> Text) -> (a -> Text) -> Table rh ch a -> TL.Text+render pretty fr fc f = renderTable def{prettyTable=pretty} (cell . fr) (cell . fc) (cell . f)+  where cell = textCell TopRight++-- | Render a table according to various cell specifications>+renderTable :: Show a =>+               TableOpts       -- ^ Options controlling Table rendering+            -> (rh -> Cell)  -- ^ Rendering function for row headers+            -> (ch -> Cell)  -- ^ Rendering function for column headers+            -> (a -> Cell)   -- ^ Function determining the string and width of a cell+            -> Table rh ch a+            -> TL.Text+renderTable topts fr fc f = toLazyText . renderTableB topts fr fc f++-- | A version of renderTable which returns the underlying Builder.+renderTableB :: Show a =>+                TableOpts       -- ^ Options controlling Table rendering+             -> (rh -> Cell)  -- ^ Rendering function for row headers+             -> (ch -> Cell)  -- ^ Rendering function for column headers+             -> (a -> Cell)   -- ^ Function determining the string and width of a cell+             -> Table rh ch a+             -> Builder+renderTableB topts fr fc f = renderTableByRowsB topts (fmap fc) $ bimap fr (fmap f)++-- | A version of renderTable that operates on rows (including the 'row' of+-- column headers) and returns the underlying Builder.+renderTableByRowsB :: Show a =>+                TableOpts      -- ^ Options controlling Table rendering+             -> ([ch] -> [Cell])     -- ^ Rendering function for column headers+             -> ((rh, [a]) -> (Cell, [Cell])) -- ^ Rendering function for row and row header+             -> Table rh ch a+             -> Builder+renderTableByRowsB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fc f (Table rh ch cells) =+   unlinesB . addBorders $+     renderColumns topts sizes ch2+     : bar VM DoubleLine   -- +======================================++     : renderRs (renderR <$> zipHeader [] cellContents rowHeaders)  where-  bar = concat . renderHLine pretty sizes ch2+  renderR :: ([Cell], Cell) -> Builder+  renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine+                     [ Header h+                     , fst <$> zipHeader emptyCell cs colHeaders+                     ]++  rows         = unzip . fmap f $ zip (headerContents rh) cells+  rowHeaders   = fst <$> zipHeader emptyCell (fst rows) rh+  colHeaders   = fst <$> zipHeader emptyCell (fc $ headerContents ch) ch+  cellContents = snd rows+   -- ch2 and cell2 include the row and column labels-  ch2 = Group DoubleLine [Header "", fmap fc ch]-  cells2 = headerContents ch2-         : zipWith (\h cs -> h : map f cs) rhStrings cells-  ---  renderR (cs,h) = renderColumns pretty sizes $ Group DoubleLine-                    [ Header h-                    , fmap fst $ zipHeader "" (map f cs) ch]-  rhStrings = map fr $ headerContents rh+  ch2 = Group DoubleLine [Header emptyCell, colHeaders]+  cells2 = headerContents ch2 : zipWith (:) (headerContents rowHeaders) cellContents+   -- maximum width for each column-  sizes   = map (maximum . map strWidth) . transpose $ cells2-  renderRs (Header s)   = [s]-  renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs-    where sep = renderHLine pretty sizes ch2 p+  sizes = map (fromMaybe 0 . maximumMay . map cellWidth) $ transpose cells2+  renderRs =+    concatMap (either (renderHLine VM borders pretty sizes ch2) (:[])) .+    flattenHeader +  -- borders and bars+  addBorders xs = if borders then bar VT SingleLine : xs ++ [bar VB SingleLine] else xs+  bar vpos prop = mconcat $ renderHLine vpos borders pretty sizes ch2 prop+  unlinesB = foldMap (<> singleton '\n')++-- | Render a single row according to cell specifications.+renderRow :: TableOpts -> Header Cell -> TL.Text+renderRow topts = toLazyText . renderRowB topts++-- | A version of renderRow which returns the underlying Builder.+renderRowB:: TableOpts -> Header Cell -> Builder+renderRowB topts h = renderColumns topts ws h where ws = map cellWidth $ headerContents h+ verticalBar :: Bool -> Char verticalBar pretty = if pretty then '│' else '|' -leftBar :: Bool -> String-leftBar pretty = verticalBar pretty : " "+leftBar :: Bool -> Bool -> Builder+leftBar pretty True  = fromString $ verticalBar pretty : " "+leftBar pretty False = singleton $ verticalBar pretty -rightBar :: Bool -> String-rightBar pretty = " " ++ [verticalBar pretty]+rightBar :: Bool -> Bool -> Builder+rightBar pretty True  = fromString $ ' ' : [verticalBar pretty]+rightBar pretty False = singleton $ verticalBar pretty -midBar :: Bool -> String-midBar pretty = " " ++ verticalBar pretty : " "+midBar :: Bool -> Bool -> Builder+midBar pretty True  = fromString $ ' ' : verticalBar pretty : " "+midBar pretty False = singleton $ verticalBar pretty -doubleMidBar :: Bool -> String-doubleMidBar pretty = if pretty then " ║ " else " || "+doubleMidBar :: Bool -> Bool -> Builder+doubleMidBar pretty True  = fromText $ if pretty then " ║ " else " || "+doubleMidBar pretty False = fromText $ if pretty then "║" else "||" -horizontalBar :: Bool -> Char-horizontalBar pretty = if pretty then '─' else '-'+-- | We stop rendering on the shortest list!+renderColumns :: TableOpts  -- ^ rendering options for the table+              -> [Int]      -- ^ max width for each column+              -> Header Cell+              -> Builder+renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=spaces} is h =+    mconcat . intersperse "\n"                   -- Put each line on its own line+    . map (addBorders . mconcat) . transpose     -- Change to a list of lines and add borders+    . map (either hsep padCell) . flattenHeader  -- We now have a matrix of strings+    . zipHeader 0 is $ padRow <$> h  -- Pad cell height and add width marker+  where+    -- Pad each cell to have the appropriate width+    padCell (w, Cell TopLeft     ls) = map (\x -> wbBuilder x <> fromText (T.replicate (w - wbWidth x) " ")) ls+    padCell (w, Cell BottomLeft  ls) = map (\x -> wbBuilder x <> fromText (T.replicate (w - wbWidth x) " ")) ls+    padCell (w, Cell TopRight    ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls+    padCell (w, Cell BottomRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls -doubleHorizontalBar :: Bool -> Char-doubleHorizontalBar pretty = if pretty then '═' else '=' --- | We stop rendering on the shortest list!-renderColumns :: Bool -- ^ pretty-              -> [Int] -- ^ max width for each column-              -> Header String-              -> String-renderColumns pretty is h = leftBar pretty ++ coreLine ++ rightBar pretty- where-  coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h-  helper = either hsep (uncurry padLeftWide)-  hsep :: Properties -> String-  hsep NoLine     = "  "-  hsep SingleLine = midBar pretty-  hsep DoubleLine = doubleMidBar pretty+    -- Pad each cell to have the same number of lines+    padRow (Cell TopLeft     ls) = Cell TopLeft     $ ls ++ replicate (nLines - length ls) mempty+    padRow (Cell TopRight    ls) = Cell TopRight    $ ls ++ replicate (nLines - length ls) mempty+    padRow (Cell BottomLeft  ls) = Cell BottomLeft  $ replicate (nLines - length ls) mempty ++ ls+    padRow (Cell BottomRight ls) = Cell BottomRight $ replicate (nLines - length ls) mempty ++ ls -renderHLine :: Bool -- ^ pretty-            -> [Int] -- ^ width specifications-            -> Header String-            -> Properties-            -> [String]-renderHLine _ _ _ NoLine = []-renderHLine pretty w h SingleLine = [renderHLine' pretty SingleLine w (horizontalBar pretty) h]-renderHLine pretty w h DoubleLine = [renderHLine' pretty DoubleLine w (doubleHorizontalBar pretty) h]+    hsep :: Properties -> [Builder]+    hsep NoLine     = replicate nLines $ if spaces then "  " else ""+    hsep SingleLine = replicate nLines $ midBar pretty spaces+    hsep DoubleLine = replicate nLines $ doubleMidBar pretty spaces -doubleCross :: Bool -> String-doubleCross pretty = if pretty then "╬" else "++"+    addBorders xs | borders   = leftBar pretty spaces <> xs <> rightBar pretty spaces+                  | spaces    = fromText " " <> xs <> fromText " "+                  | otherwise = xs -doubleVerticalCross :: Bool -> String-doubleVerticalCross pretty = if pretty then "╫" else "++"+    nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h -cross :: Bool -> Char-cross pretty = if pretty then '┼' else '+'+renderHLine :: VPos+            -> Bool  -- ^ show outer borders+            -> Bool -- ^ pretty+            -> [Int] -- ^ width specifications+            -> Header a+            -> Properties+            -> [Builder]+renderHLine _ _ _ _ _ NoLine = []+renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h] -renderHLine' :: Bool -> Properties -> [Int] -> Char -> Header String -> String-renderHLine' pretty prop is sep h = [ cross pretty, sep ] ++ coreLine ++ [sep, cross pretty]+renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder+renderHLine' vpos borders pretty prop is hdr = addBorders $ sep <> coreLine <> sep  where-  coreLine        = concatMap helper $ flattenHeader $ zipHeader 0 is h+  addBorders xs   = if borders then edge HL <> xs <> edge HR else xs+  edge hpos       = boxchar vpos hpos SingleLine prop pretty+  coreLine        = foldMap helper $ flattenHeader $ zipHeader 0 is hdr   helper          = either vsep dashes-  dashes (i,_)    = replicate i sep-  vsep NoLine     = replicate 2 sep  -- match the double space sep in renderColumns -  vsep SingleLine = sep : cross pretty : [sep]-  vsep DoubleLine = sep : cross' ++ [sep]-  cross' = case prop of-     DoubleLine -> doubleCross pretty-     _ -> doubleVerticalCross pretty+  dashes (i,_)    = stimesMonoid i sep+  sep             = boxchar vpos HM NoLine prop pretty+  vsep v          = case v of+                      NoLine -> sep <> sep+                      _      -> sep <> cross v prop <> sep+  cross v h       = boxchar vpos HM v h pretty --- padLeft :: Int -> String -> String--- padLeft l s = padding ++ s---  where padding = replicate (l - length s) ' '+data VPos = VT | VM | VB -- top middle bottom+data HPos = HL | HM | HR -- left middle right +boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> Builder+boxchar vpos hpos vert horiz = lineart u d l r+  where+    u = case vpos of+          VT -> NoLine+          _  -> vert+    d = case vpos of+          VB -> NoLine+          _  -> vert+    l = case hpos of+          HL -> NoLine+          _  -> horiz+    r = case hpos of+          HR -> NoLine+          _  -> horiz++pick :: Text -> Text -> Bool -> Builder+pick x _ True  = fromText x+pick _ x False = fromText x++lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> Builder+--      up         down       left      right+lineart SingleLine SingleLine SingleLine SingleLine = pick "┼" "+"+lineart SingleLine SingleLine SingleLine NoLine     = pick "┤" "+"+lineart SingleLine SingleLine NoLine     SingleLine = pick "├" "+"+lineart SingleLine NoLine     SingleLine SingleLine = pick "┴" "+"+lineart NoLine     SingleLine SingleLine SingleLine = pick "┬" "+"+lineart SingleLine NoLine     NoLine     SingleLine = pick "└" "+"+lineart SingleLine NoLine     SingleLine NoLine     = pick "┘" "+"+lineart NoLine     SingleLine SingleLine NoLine     = pick "┐" "+"+lineart NoLine     SingleLine NoLine     SingleLine = pick "┌" "+"+lineart SingleLine SingleLine NoLine     NoLine     = pick "│" "|"+lineart NoLine     NoLine     SingleLine SingleLine = pick "─" "-"++lineart DoubleLine DoubleLine DoubleLine DoubleLine = pick "╬" "++"+lineart DoubleLine DoubleLine DoubleLine NoLine     = pick "╣" "++"+lineart DoubleLine DoubleLine NoLine     DoubleLine = pick "╠" "++"+lineart DoubleLine NoLine     DoubleLine DoubleLine = pick "╩" "++"+lineart NoLine     DoubleLine DoubleLine DoubleLine = pick "╦" "++"+lineart DoubleLine NoLine     NoLine     DoubleLine = pick "╚" "++"+lineart DoubleLine NoLine     DoubleLine NoLine     = pick "╝" "++"+lineart NoLine     DoubleLine DoubleLine NoLine     = pick "╗" "++"+lineart NoLine     DoubleLine NoLine     DoubleLine = pick "╔" "++"+lineart DoubleLine DoubleLine NoLine     NoLine     = pick "║" "||"+lineart NoLine     NoLine     DoubleLine DoubleLine = pick "═" "="++lineart DoubleLine NoLine     NoLine     SingleLine = pick "╙" "++"+lineart DoubleLine NoLine     SingleLine NoLine     = pick "╜" "++"+lineart NoLine     DoubleLine SingleLine NoLine     = pick "╖" "++"+lineart NoLine     DoubleLine NoLine     SingleLine = pick "╓" "++"++lineart SingleLine NoLine     NoLine     DoubleLine = pick "╘" "+"+lineart SingleLine NoLine     DoubleLine NoLine     = pick "╛" "+"+lineart NoLine     SingleLine DoubleLine NoLine     = pick "╕" "+"+lineart NoLine     SingleLine NoLine     DoubleLine = pick "╒" "+"++lineart DoubleLine DoubleLine SingleLine NoLine     = pick "╢" "++"+lineart DoubleLine DoubleLine NoLine     SingleLine = pick "╟" "++"+lineart DoubleLine NoLine     SingleLine SingleLine = pick "╨" "++"+lineart NoLine     DoubleLine SingleLine SingleLine = pick "╥" "++"++lineart SingleLine SingleLine DoubleLine NoLine     = pick "╡" "+"+lineart SingleLine SingleLine NoLine     DoubleLine = pick "╞" "+"+lineart SingleLine NoLine     DoubleLine DoubleLine = pick "╧" "+"+lineart NoLine     SingleLine DoubleLine DoubleLine = pick "╤" "+"++lineart SingleLine SingleLine DoubleLine DoubleLine = pick "╪" "+"+lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++"++lineart _          _          _          _          = const mempty+++-- | Add the second table below the first, discarding its column headings.+concatTables :: Properties -> Table rh ch a -> Table rh ch2 a -> Table rh ch a+concatTables prop (Table hLeft hTop dat) (Table hLeft' _ dat') =+    Table (Group prop [hLeft, hLeft']) hTop (dat ++ dat')
+ Text/WideString.hs view
@@ -0,0 +1,39 @@+-- | Calculate the width of String and Text, being aware of wide characters.++module Text.WideString (+  -- * Text Builders which keep track of length+  WideBuilder(..),+  wbUnpack,+  wbToText,+  wbFromText+  ) where++import Data.Text (Text)+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Text.DocLayout (realLength)+++-- | Helper for constructing Builders while keeping track of text width.+data WideBuilder = WideBuilder+  { wbBuilder :: !TB.Builder+  , wbWidth   :: !Int+  } deriving (Show)++instance Semigroup WideBuilder where+  WideBuilder x i <> WideBuilder y j = WideBuilder (x <> y) (i + j)++instance Monoid WideBuilder where+  mempty = WideBuilder mempty 0++-- | Convert a WideBuilder to a strict Text.+wbToText :: WideBuilder -> Text+wbToText = TL.toStrict . TB.toLazyText . wbBuilder++-- | Convert a strict Text to a WideBuilder.+wbFromText :: Text -> WideBuilder+wbFromText t = WideBuilder (TB.fromText t) (realLength t)++-- | Convert a WideBuilder to a String.+wbUnpack :: WideBuilder -> String+wbUnpack = TL.unpack . TB.toLazyText . wbBuilder
hledger-lib.cabal view
@@ -1,52 +1,55 @@-cabal-version: 1.12+cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack------ hash: 4d6b36fe7c3d7cbcff001ad72b5f9030c0fdf2caf573b30e46dddbc0045a7066  name:           hledger-lib-version:        1.14.1-synopsis:       Core data types, parsers and functionality for the hledger accounting tools-description:    This is a reusable library containing hledger's core functionality.+version:        1.52.1+synopsis:       A library providing the core functionality of hledger+description:    This library contains hledger's core functionality.+                It is used by most hledger* packages so that they support the same+                command line options, file formats, reports, etc.                 .-                hledger is a cross-platform program for tracking money, time, or-                any other commodity, using double-entry accounting and a simple,-                editable file format. It is inspired by and largely compatible-                with ledger(1).  hledger provides command-line, curses and web-                interfaces, and aims to be a reliable, practical tool for daily-                use.+                hledger is a robust, cross-platform set of tools for tracking money,+                time, or any other commodity, using double-entry accounting and a+                simple, editable file format, with command-line, terminal and web+                interfaces. It is a Haskell rewrite of Ledger, and one of the leading+                implementations of Plain Text Accounting.+                .+                See also:+                .+                - https://hledger.org - hledger's home page+                .+                - https://hledger.org/dev.html - starting point for hledger's developer docs+                .+                - https://hackage.haskell.org/package/hledger-lib/docs/Hledger.html - starting point for hledger's haddock docs category:       Finance stability:      stable homepage:       http://hledger.org bug-reports:    http://bugs.hledger.org author:         Simon Michael <simon@joyful.com> maintainer:     Simon Michael <simon@joyful.com>-license:        GPL-3+license:        GPL-3.0-or-later license-file:   LICENSE-tested-with:    GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.3 build-type:     Simple+tested-with:+    ghc==9.6.7, ghc==9.8.4, ghc==9.10.2, ghc==9.12.2 extra-source-files:     CHANGES.md-    README-    hledger_csv.5-    hledger_csv.txt-    hledger_csv.info-    hledger_journal.5-    hledger_journal.txt-    hledger_journal.info-    hledger_timedot.5-    hledger_timedot.txt-    hledger_timedot.info-    hledger_timeclock.5-    hledger_timeclock.txt-    hledger_timeclock.info+    README.md+    test/unittest.hs+    test/doctests.hs  source-repository head   type: git   location: https://github.com/simonmichael/hledger +flag debug+  description: Build with GHC 9.10+ stack traces enabled+  manual: True+  default: False+ library   exposed-modules:       Hledger@@ -54,298 +57,246 @@       Hledger.Data.Account       Hledger.Data.AccountName       Hledger.Data.Amount-      Hledger.Data.Commodity+      Hledger.Data.BalanceData+      Hledger.Data.Balancing+      Hledger.Data.Currency       Hledger.Data.Dates+      Hledger.Data.DayPartition+      Hledger.Data.Errors       Hledger.Data.Journal+      Hledger.Data.JournalChecks+      Hledger.Data.JournalChecks.Ordereddates+      Hledger.Data.JournalChecks.Uniqueleafnames+      Hledger.Data.Json       Hledger.Data.Ledger-      Hledger.Data.MarketPrice       Hledger.Data.Period+      Hledger.Data.PeriodData       Hledger.Data.PeriodicTransaction-      Hledger.Data.StringFormat       Hledger.Data.Posting       Hledger.Data.RawOptions+      Hledger.Data.StringFormat       Hledger.Data.Timeclock       Hledger.Data.Transaction       Hledger.Data.TransactionModifier       Hledger.Data.Types+      Hledger.Data.Valuation       Hledger.Query       Hledger.Read       Hledger.Read.Common       Hledger.Read.CsvReader+      Hledger.Read.InputOptions       Hledger.Read.JournalReader-      Hledger.Read.TimedotReader+      Hledger.Read.RulesReader       Hledger.Read.TimeclockReader+      Hledger.Read.TimedotReader       Hledger.Reports-      Hledger.Reports.ReportOptions-      Hledger.Reports.ReportTypes-      Hledger.Reports.BalanceHistoryReport+      Hledger.Reports.AccountTransactionsReport       Hledger.Reports.BalanceReport       Hledger.Reports.BudgetReport       Hledger.Reports.EntriesReport-      Hledger.Reports.MultiBalanceReports+      Hledger.Reports.MultiBalanceReport       Hledger.Reports.PostingsReport-      Hledger.Reports.TransactionsReports+      Hledger.Reports.ReportOptions+      Hledger.Reports.ReportTypes       Hledger.Utils-      Hledger.Utils.Color       Hledger.Utils.Debug+      Hledger.Utils.IO       Hledger.Utils.Parse       Hledger.Utils.Regex       Hledger.Utils.String       Hledger.Utils.Test       Hledger.Utils.Text-      Hledger.Utils.Tree-      Hledger.Utils.UTF8IOCompat+      Hledger.Write.Beancount+      Hledger.Write.Csv+      Hledger.Write.Html+      Hledger.Write.Html.Attribute+      Hledger.Write.Html.Blaze+      Hledger.Write.Html.HtmlCommon+      Hledger.Write.Html.Lucid+      Hledger.Write.Ods+      Hledger.Write.Spreadsheet       Text.Tabular.AsciiWide+      Text.WideString   other-modules:-      Text.Megaparsec.Custom       Paths_hledger_lib+  autogen-modules:+      Paths_hledger_lib   hs-source-dirs:-      ./.-  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+      ./+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  cpp-options: -DVERSION="1.52.1"   build-depends:-      Decimal+      Decimal >=0.5.1     , Glob >=0.9-    , ansi-terminal >=0.6.2.3+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9     , array-    , base >=4.8 && <4.13-    , base-compat-batteries >=0.10.1 && <0.11+    , base >=4.18 && <4.23+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack     , cassava     , cassava-megaparsec     , cmdargs >=0.10-    , containers+    , colour >=2.3.6+    , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory-    , easytest >=0.2.1 && <0.3-    , extra+    , directory >=1.2.6.1+    , doclayout >=0.3 && <0.6+    , encoding >=0.10+    , extra >=1.7.11     , file-embed >=0.0.10     , filepath-    , hashtables >=1.2.3.1-    , megaparsec >=7.0.0 && <8-    , mtl-    , mtl-compat-    , old-time-    , parsec >=3+    , hashtables >=1.2.3.1 && <1.3 || >=1.4.0+    , lucid+    , megaparsec >=7.0.0 && <9.8+    , microlens >=0.4+    , microlens-th >=0.4+    , mtl >=2.2.1     , parser-combinators >=0.4.0-    , pretty-show >=1.6.4+    , pretty-simple >4 && <5+    , process     , regex-tdfa-    , safe >=0.2-    , split >=0.1+    , safe >=0.3.20     , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2     , template-haskell-    , text >=1.2+    , terminal-size >=0.3.3+    , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5+    , timeit     , transformers >=0.2     , uglymemo+    , unordered-containers >=0.2     , utf8-string >=0.3.5-  if (!impl(ghc >= 8.0))-    build-depends:-        semigroups ==0.18.*-  default-language: Haskell2010+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG -test-suite doctests+test-suite doctest   type: exitcode-stdio-1.0   main-is: doctests.hs-  other-modules:-      Hledger-      Hledger.Data-      Hledger.Data.Account-      Hledger.Data.AccountName-      Hledger.Data.Amount-      Hledger.Data.Commodity-      Hledger.Data.Dates-      Hledger.Data.Journal-      Hledger.Data.Ledger-      Hledger.Data.MarketPrice-      Hledger.Data.Period-      Hledger.Data.PeriodicTransaction-      Hledger.Data.Posting-      Hledger.Data.RawOptions-      Hledger.Data.StringFormat-      Hledger.Data.Timeclock-      Hledger.Data.Transaction-      Hledger.Data.TransactionModifier-      Hledger.Data.Types-      Hledger.Query-      Hledger.Read-      Hledger.Read.Common-      Hledger.Read.CsvReader-      Hledger.Read.JournalReader-      Hledger.Read.TimeclockReader-      Hledger.Read.TimedotReader-      Hledger.Reports-      Hledger.Reports.BalanceHistoryReport-      Hledger.Reports.BalanceReport-      Hledger.Reports.BudgetReport-      Hledger.Reports.EntriesReport-      Hledger.Reports.MultiBalanceReports-      Hledger.Reports.PostingsReport-      Hledger.Reports.ReportOptions-      Hledger.Reports.ReportTypes-      Hledger.Reports.TransactionsReports-      Hledger.Utils-      Hledger.Utils.Color-      Hledger.Utils.Debug-      Hledger.Utils.Parse-      Hledger.Utils.Regex-      Hledger.Utils.String-      Hledger.Utils.Test-      Hledger.Utils.Text-      Hledger.Utils.Tree-      Hledger.Utils.UTF8IOCompat-      Text.Megaparsec.Custom-      Text.Tabular.AsciiWide-      Paths_hledger_lib   hs-source-dirs:-      ./.       test-  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  cpp-options: -DVERSION="1.52.1"   build-depends:-      Decimal+      Decimal >=0.5.1     , Glob >=0.7-    , ansi-terminal >=0.6.2.3+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9     , array-    , base >=4.8 && <4.13-    , base-compat-batteries >=0.10.1 && <0.11+    , base >=4.18 && <4.23+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack     , cassava     , cassava-megaparsec     , cmdargs >=0.10-    , containers+    , colour >=2.3.6+    , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory-    , doctest >=0.16-    , easytest >=0.2.1 && <0.3-    , extra+    , directory >=1.2.6.1+    , doclayout >=0.3 && <0.6+    , doctest >=0.18.1+    , encoding >=0.10+    , extra >=1.7.11     , file-embed >=0.0.10     , filepath-    , hashtables >=1.2.3.1-    , megaparsec >=7.0.0 && <8-    , mtl-    , mtl-compat-    , old-time-    , parsec >=3+    , hashtables >=1.2.3.1 && <1.3 || >=1.4.0+    , lucid+    , megaparsec >=7.0.0 && <9.8+    , microlens >=0.4+    , microlens-th >=0.4+    , mtl >=2.2.1     , parser-combinators >=0.4.0-    , pretty-show >=1.6.4+    , pretty-simple >4 && <5+    , process     , regex-tdfa-    , safe >=0.2-    , split >=0.1+    , safe >=0.3.20     , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2     , template-haskell-    , text >=1.2+    , terminal-size >=0.3.3+    , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5+    , timeit     , transformers >=0.2     , uglymemo+    , unordered-containers >=0.2     , utf8-string >=0.3.5-  if (!impl(ghc >= 8.0))-    build-depends:-        semigroups ==0.18.*-  default-language: Haskell2010+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG -test-suite easytests+test-suite unittest   type: exitcode-stdio-1.0-  main-is: easytests.hs-  other-modules:-      Hledger-      Hledger.Data-      Hledger.Data.Account-      Hledger.Data.AccountName-      Hledger.Data.Amount-      Hledger.Data.Commodity-      Hledger.Data.Dates-      Hledger.Data.Journal-      Hledger.Data.Ledger-      Hledger.Data.MarketPrice-      Hledger.Data.Period-      Hledger.Data.PeriodicTransaction-      Hledger.Data.Posting-      Hledger.Data.RawOptions-      Hledger.Data.StringFormat-      Hledger.Data.Timeclock-      Hledger.Data.Transaction-      Hledger.Data.TransactionModifier-      Hledger.Data.Types-      Hledger.Query-      Hledger.Read-      Hledger.Read.Common-      Hledger.Read.CsvReader-      Hledger.Read.JournalReader-      Hledger.Read.TimeclockReader-      Hledger.Read.TimedotReader-      Hledger.Reports-      Hledger.Reports.BalanceHistoryReport-      Hledger.Reports.BalanceReport-      Hledger.Reports.BudgetReport-      Hledger.Reports.EntriesReport-      Hledger.Reports.MultiBalanceReports-      Hledger.Reports.PostingsReport-      Hledger.Reports.ReportOptions-      Hledger.Reports.ReportTypes-      Hledger.Reports.TransactionsReports-      Hledger.Utils-      Hledger.Utils.Color-      Hledger.Utils.Debug-      Hledger.Utils.Parse-      Hledger.Utils.Regex-      Hledger.Utils.String-      Hledger.Utils.Test-      Hledger.Utils.Text-      Hledger.Utils.Tree-      Hledger.Utils.UTF8IOCompat-      Text.Megaparsec.Custom-      Text.Tabular.AsciiWide-      Paths_hledger_lib+  main-is: unittest.hs   hs-source-dirs:-      ./.       test-  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+  ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind+  cpp-options: -DVERSION="1.52.1"   build-depends:-      Decimal+      Decimal >=0.5.1     , Glob >=0.9-    , ansi-terminal >=0.6.2.3+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9     , array-    , base >=4.8 && <4.13-    , base-compat-batteries >=0.10.1 && <0.11+    , base >=4.18 && <4.23+    , blaze-html     , blaze-markup >=0.5.1     , bytestring     , call-stack     , cassava     , cassava-megaparsec     , cmdargs >=0.10-    , containers+    , colour >=2.3.6+    , containers >=0.5.9     , data-default >=0.5     , deepseq-    , directory-    , easytest >=0.2.1 && <0.3-    , extra+    , directory >=1.2.6.1+    , doclayout >=0.3 && <0.6+    , encoding >=0.10+    , extra >=1.7.11     , file-embed >=0.0.10     , filepath-    , hashtables >=1.2.3.1+    , hashtables >=1.2.3.1 && <1.3 || >=1.4.0     , hledger-lib-    , megaparsec >=7.0.0 && <8-    , mtl-    , mtl-compat-    , old-time-    , parsec >=3+    , lucid+    , megaparsec >=7.0.0 && <9.8+    , microlens >=0.4+    , microlens-th >=0.4+    , mtl >=2.2.1     , parser-combinators >=0.4.0-    , pretty-show >=1.6.4+    , pretty-simple >4 && <5+    , process     , regex-tdfa-    , safe >=0.2-    , split >=0.1+    , safe >=0.3.20     , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2     , template-haskell-    , text >=1.2+    , terminal-size >=0.3.3+    , text >=1.2.4.1+    , these >=1.0.0     , time >=1.5+    , timeit     , transformers >=0.2     , uglymemo+    , unordered-containers >=0.2     , utf8-string >=0.3.5-  if (!impl(ghc >= 8.0))-    build-depends:-        semigroups ==0.18.*-  default-language: Haskell2010+  buildable: True+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG
− hledger_csv.5 
@@ -1,335 +0,0 @@--.TH "hledger_csv" "5" "March 2019" "hledger 1.14" "hledger User Manuals"----.SH NAME-.PP-CSV \- how hledger reads CSV data, and the CSV rules file format-.SH DESCRIPTION-.PP-hledger can read CSV (comma\-separated value) files as if they were-journal files, automatically converting each CSV record into a-transaction.-(To learn about \f[I]writing\f[] CSV, see CSV output.)-.PP-Converting CSV to transactions requires some special conversion rules.-These do several things:-.IP \[bu] 2-they describe the layout and format of the CSV data-.IP \[bu] 2-they can customize the generated journal entries using a simple-templating language-.IP \[bu] 2-they can add refinements based on patterns in the CSV data, eg-categorizing transactions with more detailed account names.-.PP-When reading a CSV file named \f[C]FILE.csv\f[], hledger looks for a-conversion rules file named \f[C]FILE.csv.rules\f[] in the same-directory.-You can override this with the \f[C]\-\-rules\-file\f[] option.-If the rules file does not exist, hledger will auto\-create one with-some example rules, which you\[aq]ll need to adjust.-.PP-At minimum, the rules file must identify the \f[C]date\f[] and-\f[C]amount\f[] fields.-It may also be necessary to specify the date format, and the number of-header lines to skip.-Eg:-.IP-.nf-\f[C]-fields\ date,\ _,\ _,\ amount-date\-format\ \ %d/%m/%Y-skip\ 1-\f[]-.fi-.PP-A more complete example:-.IP-.nf-\f[C]-#\ hledger\ CSV\ rules\ for\ amazon.com\ order\ history--#\ sample:-#\ "Date","Type","To/From","Name","Status","Amount","Fees","Transaction\ ID"-#\ "Jul\ 29,\ 2012","Payment","To","Adapteva,\ Inc.","Completed","$25.00","$0.00","17LA58JSK6PRD4HDGLNJQPI1PB9N8DKPVHL"--#\ skip\ one\ header\ line-skip\ 1--#\ name\ the\ csv\ fields\ (and\ assign\ the\ transaction\[aq]s\ date,\ amount\ and\ code)-fields\ date,\ _,\ toorfrom,\ name,\ amzstatus,\ amount,\ fees,\ code--#\ how\ to\ parse\ the\ date-date\-format\ %b\ %\-d,\ %Y--#\ combine\ two\ fields\ to\ make\ the\ description-description\ %toorfrom\ %name--#\ save\ these\ fields\ as\ tags-comment\ \ \ \ \ status:%amzstatus,\ fees:%fees--#\ set\ the\ base\ account\ for\ all\ transactions-account1\ \ \ \ assets:amazon--#\ flip\ the\ sign\ on\ the\ amount-amount\ \ \ \ \ \ \-%amount-\f[]-.fi-.PP-For more examples, see Convert CSV files.-.SH CSV RULES-.PP-The following seven kinds of rule can appear in the rules file, in any-order.-Blank lines and lines beginning with \f[C]#\f[] or \f[C];\f[] are-ignored.-.SS skip-.PP-\f[C]skip\f[]\f[I]\f[CI]N\f[I]\f[]-.PP-Skip this number of CSV records at the beginning.-You\[aq]ll need this whenever your CSV data contains header lines.-Eg:-.IP-.nf-\f[C]-#\ ignore\ the\ first\ CSV\ line-skip\ 1-\f[]-.fi-.SS date\-format-.PP-\f[C]date\-format\f[]\f[I]\f[CI]DATEFMT\f[I]\f[]-.PP-When your CSV date fields are not formatted like \f[C]YYYY/MM/DD\f[] (or-\f[C]YYYY\-MM\-DD\f[] or \f[C]YYYY.MM.DD\f[]), you\[aq]ll need to-specify the format.-DATEFMT is a strptime\-like date parsing pattern, which must parse the-date field values completely.-Examples:-.IP-.nf-\f[C]-#\ for\ dates\ like\ "11/06/2013":-date\-format\ %m/%d/%Y-\f[]-.fi-.IP-.nf-\f[C]-#\ for\ dates\ like\ "6/11/2013"\ (note\ the\ \-\ to\ make\ leading\ zeros\ optional):-date\-format\ %\-d/%\-m/%Y-\f[]-.fi-.IP-.nf-\f[C]-#\ for\ dates\ like\ "2013\-Nov\-06":-date\-format\ %Y\-%h\-%d-\f[]-.fi-.IP-.nf-\f[C]-#\ for\ dates\ like\ "11/6/2013\ 11:32\ PM":-date\-format\ %\-m/%\-d/%Y\ %l:%M\ %p-\f[]-.fi-.SS field list-.PP-\f[C]fields\f[]\f[I]\f[CI]FIELDNAME1\f[I]\f[],-\f[I]\f[CI]FIELDNAME2\f[I]\f[]...-.PP-This (a) names the CSV fields, in order (names may not contain-whitespace; uninteresting names may be left blank), and (b) assigns them-to journal entry fields if you use any of these standard field names:-\f[C]date\f[], \f[C]date2\f[], \f[C]status\f[], \f[C]code\f[],-\f[C]description\f[], \f[C]comment\f[], \f[C]account1\f[],-\f[C]account2\f[], \f[C]amount\f[], \f[C]amount\-in\f[],-\f[C]amount\-out\f[], \f[C]currency\f[], \f[C]balance\f[].-Eg:-.IP-.nf-\f[C]-#\ use\ the\ 1st,\ 2nd\ and\ 4th\ CSV\ fields\ as\ the\ entry\[aq]s\ date,\ description\ and\ amount,-#\ and\ give\ the\ 7th\ and\ 8th\ fields\ meaningful\ names\ for\ later\ reference:-#-#\ CSV\ field:-#\ \ \ \ \ \ 1\ \ \ \ \ 2\ \ \ \ \ \ \ \ \ \ \ \ 3\ 4\ \ \ \ \ \ \ 5\ 6\ 7\ \ \ \ \ \ \ \ \ \ 8-#\ entry\ field:-fields\ date,\ description,\ ,\ amount,\ ,\ ,\ somefield,\ anotherfield-\f[]-.fi-.SS field assignment-.PP-\f[I]\f[CI]ENTRYFIELDNAME\f[I]\f[] \f[I]\f[CI]FIELDVALUE\f[I]\f[]-.PP-This sets a journal entry field (one of the standard names above) to the-given text value, which can include CSV field values interpolated by-name (\f[C]%CSVFIELDNAME\f[]) or 1\-based position (\f[C]%N\f[]).- Eg:-.IP-.nf-\f[C]-#\ set\ the\ amount\ to\ the\ 4th\ CSV\ field\ with\ "USD\ "\ prepended-amount\ USD\ %4-\f[]-.fi-.IP-.nf-\f[C]-#\ combine\ three\ fields\ to\ make\ a\ comment\ (containing\ two\ tags)-comment\ note:\ %somefield\ \-\ %anotherfield,\ date:\ %1-\f[]-.fi-.PP-Field assignments can be used instead of or in addition to a field list.-.SS conditional block-.PP-\f[C]if\f[] \f[I]\f[CI]PATTERN\f[I]\f[]-.PD 0-.P-.PD-\ \ \ \ \f[I]\f[CI]FIELDASSIGNMENTS\f[I]\f[]...-.PP-\f[C]if\f[]-.PD 0-.P-.PD-\f[I]\f[CI]PATTERN\f[I]\f[]-.PD 0-.P-.PD-\f[I]\f[CI]PATTERN\f[I]\f[]...-.PD 0-.P-.PD-\ \ \ \ \f[I]\f[CI]FIELDASSIGNMENTS\f[I]\f[]...-.PP-This applies one or more field assignments, only to those CSV records-matched by one of the PATTERNs.-The patterns are case\-insensitive regular expressions which match-anywhere within the whole CSV record (it\[aq]s not yet possible to match-within a specific field).-When there are multiple patterns they can be written on separate lines,-unindented.-The field assignments are on separate lines indented by at least one-space.-Examples:-.IP-.nf-\f[C]-#\ if\ the\ CSV\ record\ contains\ "groceries",\ set\ account2\ to\ "expenses:groceries"-if\ groceries-\ account2\ expenses:groceries-\f[]-.fi-.IP-.nf-\f[C]-#\ if\ the\ CSV\ record\ contains\ any\ of\ these\ patterns,\ set\ account2\ and\ comment\ as\ shown-if-monthly\ service\ fee-atm\ transaction\ fee-banking\ thru\ software-\ account2\ expenses:business:banking-\ comment\ \ XXX\ deductible\ ?\ check\ it-\f[]-.fi-.SS include-.PP-\f[C]include\f[]\f[I]\f[CI]RULESFILE\f[I]\f[]-.PP-Include another rules file at this point.-\f[C]RULESFILE\f[] is either an absolute file path or a path relative to-the current file\[aq]s directory.-Eg:-.IP-.nf-\f[C]-#\ rules\ reused\ with\ several\ CSV\ files-include\ common.rules-\f[]-.fi-.SS newest\-first-.PP-\f[C]newest\-first\f[]-.PP-Consider adding this rule if all of the following are true: you might be-processing just one day of data, your CSV records are in reverse-chronological order (newest first), and you care about preserving the-order of same\-day transactions.-It usually isn\[aq]t needed, because hledger autodetects the CSV order,-but when all CSV records have the same date it will assume they are-oldest first.-.SH CSV TIPS-.SS CSV ordering-.PP-The generated journal entries will be sorted by date.-The order of same\-day entries will be preserved (except in the special-case where you might need \f[C]newest\-first\f[], see above).-.SS CSV accounts-.PP-Each journal entry will have two postings, to \f[C]account1\f[] and-\f[C]account2\f[] respectively.-It\[aq]s not yet possible to generate entries with more than two-postings.-It\[aq]s conventional and recommended to use \f[C]account1\f[] for the-account whose CSV we are reading.-.SS CSV amounts-.PP-The \f[C]amount\f[] field sets the amount of the \f[C]account1\f[]-posting.-.PP-If the CSV has debit/credit amounts in separate fields, assign to the-\f[C]amount\-in\f[] and \f[C]amount\-out\f[] pseudo fields instead.-(Whichever one has a value will be used, with appropriate sign.-If both contain a value, it may not work so well.)-.PP-If an amount value is parenthesised, it will be de\-parenthesised and-sign\-flipped.-.PP-If an amount value begins with a double minus sign, those will cancel-out and be removed.-.PP-If the CSV has the currency symbol in a separate field, assign that to-the \f[C]currency\f[] pseudo field to have it prepended to the amount.-Or, you can use a field assignment to \f[C]amount\f[] that interpolates-both CSV fields (giving more control, eg to put the currency symbol on-the right).-.SS CSV balance assertions-.PP-If the CSV includes a running balance, you can assign that to the-\f[C]balance\f[] pseudo field; whenever the running balance value is-non\-empty, it will be asserted as the balance after the-\f[C]account1\f[] posting.-.SS Reading multiple CSV files-.PP-You can read multiple CSV files at once using multiple \f[C]\-f\f[]-arguments on the command line, and hledger will look for a-correspondingly\-named rules file for each.-Note if you use the \f[C]\-\-rules\-file\f[] option, this one rules file-will be used for all the CSV files being read.---.SH "REPORTING BUGS"-Report bugs at http://bugs.hledger.org-(or on the #hledger IRC channel or hledger mail list)--.SH AUTHORS-Simon Michael <simon@joyful.com> and contributors--.SH COPYRIGHT--Copyright (C) 2007-2016 Simon Michael.-.br-Released under GNU GPL v3 or later.--.SH SEE ALSO-hledger(1), hledger\-ui(1), hledger\-web(1), hledger\-api(1),-hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_timedot(5),-ledger(1)--http://hledger.org
− hledger_csv.info 
@@ -1,349 +0,0 @@-This is hledger_csv.info, produced by makeinfo version 6.5 from stdin.---File: hledger_csv.info,  Node: Top,  Next: CSV RULES,  Up: (dir)--hledger_csv(5) hledger 1.14-***************************--hledger can read CSV (comma-separated value) files as if they were-journal files, automatically converting each CSV record into a-transaction.  (To learn about _writing_ CSV, see CSV output.)--   Converting CSV to transactions requires some special conversion-rules.  These do several things:--   * they describe the layout and format of the CSV data-   * they can customize the generated journal entries using a simple-     templating language-   * they can add refinements based on patterns in the CSV data, eg-     categorizing transactions with more detailed account names.--   When reading a CSV file named 'FILE.csv', hledger looks for a-conversion rules file named 'FILE.csv.rules' in the same directory.  You-can override this with the '--rules-file' option.  If the rules file-does not exist, hledger will auto-create one with some example rules,-which you'll need to adjust.--   At minimum, the rules file must identify the 'date' and 'amount'-fields.  It may also be necessary to specify the date format, and the-number of header lines to skip.  Eg:--fields date, _, _, amount-date-format  %d/%m/%Y-skip 1--   A more complete example:--# hledger CSV rules for amazon.com order history--# sample:-# "Date","Type","To/From","Name","Status","Amount","Fees","Transaction ID"-# "Jul 29, 2012","Payment","To","Adapteva, Inc.","Completed","$25.00","$0.00","17LA58JSK6PRD4HDGLNJQPI1PB9N8DKPVHL"--# skip one header line-skip 1--# name the csv fields (and assign the transaction's date, amount and code)-fields date, _, toorfrom, name, amzstatus, amount, fees, code--# how to parse the date-date-format %b %-d, %Y--# combine two fields to make the description-description %toorfrom %name--# save these fields as tags-comment     status:%amzstatus, fees:%fees--# set the base account for all transactions-account1    assets:amazon--# flip the sign on the amount-amount      -%amount--   For more examples, see Convert CSV files.-* Menu:--* CSV RULES::-* CSV TIPS::---File: hledger_csv.info,  Node: CSV RULES,  Next: CSV TIPS,  Prev: Top,  Up: Top--1 CSV RULES-***********--The following seven kinds of rule can appear in the rules file, in any-order.  Blank lines and lines beginning with '#' or ';' are ignored.-* Menu:--* skip::-* date-format::-* field list::-* field assignment::-* conditional block::-* include::-* newest-first::---File: hledger_csv.info,  Node: skip,  Next: date-format,  Up: CSV RULES--1.1 skip-========--'skip'_'N'_--   Skip this number of CSV records at the beginning.  You'll need this-whenever your CSV data contains header lines.  Eg:--# ignore the first CSV line-skip 1---File: hledger_csv.info,  Node: date-format,  Next: field list,  Prev: skip,  Up: CSV RULES--1.2 date-format-===============--'date-format'_'DATEFMT'_--   When your CSV date fields are not formatted like 'YYYY/MM/DD' (or-'YYYY-MM-DD' or 'YYYY.MM.DD'), you'll need to specify the format.-DATEFMT is a strptime-like date parsing pattern, which must parse the-date field values completely.  Examples:--# for dates like "11/06/2013":-date-format %m/%d/%Y--# for dates like "6/11/2013" (note the - to make leading zeros optional):-date-format %-d/%-m/%Y--# for dates like "2013-Nov-06":-date-format %Y-%h-%d--# for dates like "11/6/2013 11:32 PM":-date-format %-m/%-d/%Y %l:%M %p---File: hledger_csv.info,  Node: field list,  Next: field assignment,  Prev: date-format,  Up: CSV RULES--1.3 field list-==============--'fields'_'FIELDNAME1'_, _'FIELDNAME2'_...--   This (a) names the CSV fields, in order (names may not contain-whitespace; uninteresting names may be left blank), and (b) assigns them-to journal entry fields if you use any of these standard field names:-'date', 'date2', 'status', 'code', 'description', 'comment', 'account1',-'account2', 'amount', 'amount-in', 'amount-out', 'currency', 'balance'.-Eg:--# use the 1st, 2nd and 4th CSV fields as the entry's date, description and amount,-# and give the 7th and 8th fields meaningful names for later reference:-#-# CSV field:-#      1     2            3 4       5 6 7          8-# entry field:-fields date, description, , amount, , , somefield, anotherfield---File: hledger_csv.info,  Node: field assignment,  Next: conditional block,  Prev: field list,  Up: CSV RULES--1.4 field assignment-====================--_'ENTRYFIELDNAME'_ _'FIELDVALUE'_--   This sets a journal entry field (one of the standard names above) to-the given text value, which can include CSV field values interpolated by-name ('%CSVFIELDNAME') or 1-based position ('%N').  Eg:--# set the amount to the 4th CSV field with "USD " prepended-amount USD %4--# combine three fields to make a comment (containing two tags)-comment note: %somefield - %anotherfield, date: %1--   Field assignments can be used instead of or in addition to a field-list.---File: hledger_csv.info,  Node: conditional block,  Next: include,  Prev: field assignment,  Up: CSV RULES--1.5 conditional block-=====================--'if' _'PATTERN'_-    _'FIELDASSIGNMENTS'_...--   'if'-_'PATTERN'_-_'PATTERN'_...-    _'FIELDASSIGNMENTS'_...--   This applies one or more field assignments, only to those CSV records-matched by one of the PATTERNs.  The patterns are case-insensitive-regular expressions which match anywhere within the whole CSV record-(it's not yet possible to match within a specific field).  When there-are multiple patterns they can be written on separate lines, unindented.-The field assignments are on separate lines indented by at least one-space.  Examples:--# if the CSV record contains "groceries", set account2 to "expenses:groceries"-if groceries- account2 expenses:groceries--# if the CSV record contains any of these patterns, set account2 and comment as shown-if-monthly service fee-atm transaction fee-banking thru software- account2 expenses:business:banking- comment  XXX deductible ? check it---File: hledger_csv.info,  Node: include,  Next: newest-first,  Prev: conditional block,  Up: CSV RULES--1.6 include-===========--'include'_'RULESFILE'_--   Include another rules file at this point.  'RULESFILE' is either an-absolute file path or a path relative to the current file's directory.-Eg:--# rules reused with several CSV files-include common.rules---File: hledger_csv.info,  Node: newest-first,  Prev: include,  Up: CSV RULES--1.7 newest-first-================--'newest-first'--   Consider adding this rule if all of the following are true: you might-be processing just one day of data, your CSV records are in reverse-chronological order (newest first), and you care about preserving the-order of same-day transactions.  It usually isn't needed, because-hledger autodetects the CSV order, but when all CSV records have the-same date it will assume they are oldest first.---File: hledger_csv.info,  Node: CSV TIPS,  Prev: CSV RULES,  Up: Top--2 CSV TIPS-**********--* Menu:--* CSV ordering::-* CSV accounts::-* CSV amounts::-* CSV balance assertions::-* Reading multiple CSV files::---File: hledger_csv.info,  Node: CSV ordering,  Next: CSV accounts,  Up: CSV TIPS--2.1 CSV ordering-================--The generated journal entries will be sorted by date.  The order of-same-day entries will be preserved (except in the special case where you-might need 'newest-first', see above).---File: hledger_csv.info,  Node: CSV accounts,  Next: CSV amounts,  Prev: CSV ordering,  Up: CSV TIPS--2.2 CSV accounts-================--Each journal entry will have two postings, to 'account1' and 'account2'-respectively.  It's not yet possible to generate entries with more than-two postings.  It's conventional and recommended to use 'account1' for-the account whose CSV we are reading.---File: hledger_csv.info,  Node: CSV amounts,  Next: CSV balance assertions,  Prev: CSV accounts,  Up: CSV TIPS--2.3 CSV amounts-===============--The 'amount' field sets the amount of the 'account1' posting.--   If the CSV has debit/credit amounts in separate fields, assign to the-'amount-in' and 'amount-out' pseudo fields instead.  (Whichever one has-a value will be used, with appropriate sign.  If both contain a value,-it may not work so well.)--   If an amount value is parenthesised, it will be de-parenthesised and-sign-flipped.--   If an amount value begins with a double minus sign, those will cancel-out and be removed.--   If the CSV has the currency symbol in a separate field, assign that-to the 'currency' pseudo field to have it prepended to the amount.  Or,-you can use a field assignment to 'amount' that interpolates both CSV-fields (giving more control, eg to put the currency symbol on the-right).---File: hledger_csv.info,  Node: CSV balance assertions,  Next: Reading multiple CSV files,  Prev: CSV amounts,  Up: CSV TIPS--2.4 CSV balance assertions-==========================--If the CSV includes a running balance, you can assign that to the-'balance' pseudo field; whenever the running balance value is non-empty,-it will be asserted as the balance after the 'account1' posting.---File: hledger_csv.info,  Node: Reading multiple CSV files,  Prev: CSV balance assertions,  Up: CSV TIPS--2.5 Reading multiple CSV files-==============================--You can read multiple CSV files at once using multiple '-f' arguments on-the command line, and hledger will look for a correspondingly-named-rules file for each.  Note if you use the '--rules-file' option, this-one rules file will be used for all the CSV files being read.---Tag Table:-Node: Top72-Node: CSV RULES2163-Ref: #csv-rules2271-Node: skip2533-Ref: #skip2627-Node: date-format2799-Ref: #date-format2926-Node: field list3476-Ref: #field-list3613-Node: field assignment4318-Ref: #field-assignment4473-Node: conditional block4977-Ref: #conditional-block5131-Node: include6027-Ref: #include6157-Node: newest-first6388-Ref: #newest-first6502-Node: CSV TIPS6913-Ref: #csv-tips7007-Node: CSV ordering7125-Ref: #csv-ordering7243-Node: CSV accounts7424-Ref: #csv-accounts7562-Node: CSV amounts7816-Ref: #csv-amounts7962-Node: CSV balance assertions8737-Ref: #csv-balance-assertions8919-Node: Reading multiple CSV files9124-Ref: #reading-multiple-csv-files9294--End Tag Table
− hledger_csv.txt 
@@ -1,252 +0,0 @@--hledger_csv(5)               hledger User Manuals               hledger_csv(5)----NAME-       CSV - how hledger reads CSV data, and the CSV rules file format--DESCRIPTION-       hledger  can  read  CSV  (comma-separated  value) files as if they were-       journal files, automatically converting each CSV record into a transac--       tion.  (To learn about writing CSV, see CSV output.)--       Converting  CSV to transactions requires some special conversion rules.-       These do several things:--       o they describe the layout and format of the CSV data--       o they can customize the generated journal entries using a simple  tem--         plating language--       o they  can add refinements based on patterns in the CSV data, eg cate--         gorizing transactions with more detailed account names.--       When reading a CSV file named FILE.csv, hledger looks for a  conversion-       rules  file  named FILE.csv.rules in the same directory.  You can over--       ride this with the --rules-file option.  If the  rules  file  does  not-       exist,  hledger  will  auto-create  one  with some example rules, which-       you'll need to adjust.--       At minimum, the rules file must identify the date  and  amount  fields.-       It  may also be necessary to specify the date format, and the number of-       header lines to skip.  Eg:--              fields date, _, _, amount-              date-format  %d/%m/%Y-              skip 1--       A more complete example:--              # hledger CSV rules for amazon.com order history--              # sample:-              # "Date","Type","To/From","Name","Status","Amount","Fees","Transaction ID"-              # "Jul 29, 2012","Payment","To","Adapteva, Inc.","Completed","$25.00","$0.00","17LA58JSK6PRD4HDGLNJQPI1PB9N8DKPVHL"--              # skip one header line-              skip 1--              # name the csv fields (and assign the transaction's date, amount and code)-              fields date, _, toorfrom, name, amzstatus, amount, fees, code--              # how to parse the date-              date-format %b %-d, %Y--              # combine two fields to make the description-              description %toorfrom %name--              # save these fields as tags-              comment     status:%amzstatus, fees:%fees--              # set the base account for all transactions-              account1    assets:amazon--              # flip the sign on the amount-              amount      -%amount--       For more examples, see Convert CSV files.--CSV RULES-       The following seven kinds of rule can appear in the rules file, in  any-       order.  Blank lines and lines beginning with # or ; are ignored.--   skip-       skipN--       Skip  this  number  of  CSV records at the beginning.  You'll need this-       whenever your CSV data contains header lines.  Eg:--              # ignore the first CSV line-              skip 1--   date-format-       date-formatDATEFMT--       When your CSV  date  fields  are  not  formatted  like  YYYY/MM/DD  (or-       YYYY-MM-DD  or YYYY.MM.DD), you'll need to specify the format.  DATEFMT-       is a strptime-like date parsing pattern,  which  must  parse  the  date-       field values completely.  Examples:--              # for dates like "11/06/2013":-              date-format %m/%d/%Y--              # for dates like "6/11/2013" (note the - to make leading zeros optional):-              date-format %-d/%-m/%Y--              # for dates like "2013-Nov-06":-              date-format %Y-%h-%d--              # for dates like "11/6/2013 11:32 PM":-              date-format %-m/%-d/%Y %l:%M %p--   field list-       fieldsFIELDNAME1, FIELDNAME2...--       This  (a)  names the CSV fields, in order (names may not contain white--       space; uninteresting names may be left blank), and (b) assigns them  to-       journal  entry  fields  if  you  use any of these standard field names:-       date, date2, status, code, description,  comment,  account1,  account2,-       amount, amount-in, amount-out, currency, balance.  Eg:--              # use the 1st, 2nd and 4th CSV fields as the entry's date, description and amount,-              # and give the 7th and 8th fields meaningful names for later reference:-              #-              # CSV field:-              #      1     2            3 4       5 6 7          8-              # entry field:-              fields date, description, , amount, , , somefield, anotherfield--   field assignment-       ENTRYFIELDNAME FIELDVALUE--       This  sets  a  journal entry field (one of the standard names above) to-       the given text value, which can include CSV field  values  interpolated-       by name (%CSVFIELDNAME) or 1-based position (%N).-        Eg:--              # set the amount to the 4th CSV field with "USD " prepended-              amount USD %4--              # combine three fields to make a comment (containing two tags)-              comment note: %somefield - %anotherfield, date: %1--       Field  assignments  can  be  used  instead of or in addition to a field-       list.--   conditional block-       if PATTERN-           FIELDASSIGNMENTS...--       if-       PATTERN-       PATTERN...-           FIELDASSIGNMENTS...--       This applies one or more field assignments, only to those  CSV  records-       matched by one of the PATTERNs.  The patterns are case-insensitive reg--       ular expressions which match anywhere within the whole CSV record (it's-       not  yet  possible  to  match within a specific field).  When there are-       multiple patterns they can be written on  separate  lines,  unindented.-       The  field  assignments  are on separate lines indented by at least one-       space.  Examples:--              # if the CSV record contains "groceries", set account2 to "expenses:groceries"-              if groceries-               account2 expenses:groceries--              # if the CSV record contains any of these patterns, set account2 and comment as shown-              if-              monthly service fee-              atm transaction fee-              banking thru software-               account2 expenses:business:banking-               comment  XXX deductible ? check it--   include-       includeRULESFILE--       Include another rules file at this point.  RULESFILE is either an abso--       lute file path or a path relative to the current file's directory.  Eg:--              # rules reused with several CSV files-              include common.rules--   newest-first-       newest-first--       Consider adding this rule if all of the following are true:  you  might-       be  processing  just  one  day of data, your CSV records are in reverse-       chronological order (newest first), and you care about  preserving  the-       order  of  same-day  transactions.   It  usually  isn't needed, because-       hledger autodetects the CSV order, but when all CSV  records  have  the-       same date it will assume they are oldest first.--CSV TIPS-   CSV ordering-       The  generated  journal  entries  will be sorted by date.  The order of-       same-day entries will be preserved (except in the  special  case  where-       you might need newest-first, see above).--   CSV accounts-       Each  journal  entry  will  have two postings, to account1 and account2-       respectively.  It's not yet possible to generate entries with more than-       two  postings.   It's  conventional and recommended to use account1 for-       the account whose CSV we are reading.--   CSV amounts-       The amount field sets the amount of the account1 posting.--       If the CSV has debit/credit amounts in separate fields, assign  to  the-       amount-in  and  amount-out pseudo fields instead.  (Whichever one has a-       value will be used, with appropriate sign.  If both contain a value, it-       may not work so well.)--       If  an  amount  value is parenthesised, it will be de-parenthesised and-       sign-flipped.--       If an amount value begins with a double minus sign, those  will  cancel-       out and be removed.--       If  the CSV has the currency symbol in a separate field, assign that to-       the currency pseudo field to have it prepended to the amount.  Or,  you-       can  use a field assignment to amount that interpolates both CSV fields-       (giving more control, eg to put the currency symbol on the right).--   CSV balance assertions-       If the CSV includes a running balance, you can assign that to the  bal--       ance  pseudo field; whenever the running balance value is non-empty, it-       will be asserted as the balance after the account1 posting.--   Reading multiple CSV files-       You can read multiple CSV files at once using multiple -f arguments  on-       the  command  line,  and  hledger will look for a correspondingly-named-       rules file for each.  Note if you use the --rules-file option, this one-       rules file will be used for all the CSV files being read.----REPORTING BUGS-       Report  bugs at http://bugs.hledger.org (or on the #hledger IRC channel-       or hledger mail list)---AUTHORS-       Simon Michael <simon@joyful.com> and contributors---COPYRIGHT-       Copyright (C) 2007-2016 Simon Michael.-       Released under GNU GPL v3 or later.---SEE ALSO-       hledger(1),     hledger-ui(1),     hledger-web(1),      hledger-api(1),-       hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_time--       dot(5), ledger(1)--       http://hledger.org----hledger 1.14                      March 2019                    hledger_csv(5)
− hledger_journal.5 
@@ -1,1772 +0,0 @@-.\"t--.TH "hledger_journal" "5" "March 2019" "hledger 1.14" "hledger User Manuals"----.SH NAME-.PP-Journal \- hledger\[aq]s default file format, representing a General-Journal-.SH DESCRIPTION-.PP-hledger\[aq]s usual data source is a plain text file containing journal-entries in hledger journal format.-This file represents a standard accounting general journal.-I use file names ending in \f[C]\&.journal\f[], but that\[aq]s not-required.-The journal file contains a number of transaction entries, each-describing a transfer of money (or any commodity) between two or more-named accounts, in a simple format readable by both hledger and humans.-.PP-hledger\[aq]s journal format is a compatible subset, mostly, of-ledger\[aq]s journal format, so hledger can work with compatible ledger-journal files as well.-It\[aq]s safe, and encouraged, to run both hledger and ledger on the-same journal file, eg to validate the results you\[aq]re getting.-.PP-You can use hledger without learning any more about this file; just use-the add or web commands to create and update it.-Many users, though, also edit the journal file directly with a text-editor, perhaps assisted by the helper modes for emacs or vim.-.PP-Here\[aq]s an example:-.IP-.nf-\f[C]-;\ A\ sample\ journal\ file.\ This\ is\ a\ comment.--2008/01/01\ income\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ;\ <\-\ transaction\[aq]s\ first\ line\ starts\ in\ column\ 0,\ contains\ date\ and\ description-\ \ \ \ assets:bank:checking\ \ $1\ \ \ \ ;\ <\-\ posting\ lines\ start\ with\ whitespace,\ each\ contains\ an\ account\ name-\ \ \ \ income:salary\ \ \ \ \ \ \ \ $\-1\ \ \ \ ;\ \ \ \ followed\ by\ at\ least\ two\ spaces\ and\ an\ amount--2008/06/01\ gift-\ \ \ \ assets:bank:checking\ \ $1\ \ \ \ ;\ <\-\ at\ least\ two\ postings\ in\ a\ transaction-\ \ \ \ income:gifts\ \ \ \ \ \ \ \ \ $\-1\ \ \ \ ;\ <\-\ their\ amounts\ must\ balance\ to\ 0--2008/06/02\ save-\ \ \ \ assets:bank:saving\ \ \ \ $1-\ \ \ \ assets:bank:checking\ \ \ \ \ \ \ \ ;\ <\-\ one\ amount\ may\ be\ omitted;\ here\ $\-1\ is\ inferred--2008/06/03\ eat\ &\ shop\ \ \ \ \ \ \ \ \ \ \ ;\ <\-\ description\ can\ be\ anything-\ \ \ \ expenses:food\ \ \ \ \ \ \ \ \ $1-\ \ \ \ expenses:supplies\ \ \ \ \ $1\ \ \ \ ;\ <\-\ this\ transaction\ debits\ two\ expense\ accounts-\ \ \ \ assets:cash\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ;\ <\-\ $\-2\ inferred--2008/10/01\ take\ a\ loan-\ \ \ \ assets:bank:checking\ \ $1-\ \ \ \ liabilities:debts\ \ \ \ $\-1--2008/12/31\ *\ pay\ off\ \ \ \ \ \ \ \ \ \ \ \ ;\ <\-\ an\ optional\ *\ or\ !\ after\ the\ date\ means\ "cleared"\ (or\ anything\ you\ want)-\ \ \ \ liabilities:debts\ \ \ \ \ $1-\ \ \ \ assets:bank:checking-\f[]-.fi-.SH FILE FORMAT-.SS Transactions-.PP-Transactions are movements of some quantity of commodities between named-accounts.-Each transaction is represented by a journal entry beginning with a-simple date in column 0.-This can be followed by any of the following, separated by spaces:-.IP \[bu] 2-(optional) a status character (empty, \f[C]!\f[], or \f[C]*\f[])-.IP \[bu] 2-(optional) a transaction code (any short number or text, enclosed in-parentheses)-.IP \[bu] 2-(optional) a transaction description (any remaining text until end of-line or a semicolon)-.IP \[bu] 2-(optional) a transaction comment (any remaining text following a-semicolon until end of line)-.PP-Then comes zero or more (but usually at least 2) indented lines-representing...-.SS Postings-.PP-A posting is an addition of some amount to, or removal of some amount-from, an account.-Each posting line begins with at least one space or tab (2 or 4 spaces-is common), followed by:-.IP \[bu] 2-(optional) a status character (empty, \f[C]!\f[], or \f[C]*\f[]),-followed by a space-.IP \[bu] 2-(required) an account name (any text, optionally containing \f[B]single-spaces\f[], until end of line or a double space)-.IP \[bu] 2-(optional) \f[B]two or more spaces\f[] or tabs followed by an amount.-.PP-Positive amounts are being added to the account, negative amounts are-being removed.-.PP-The amounts within a transaction must always sum up to zero.-As a convenience, one amount may be left blank; it will be inferred so-as to balance the transaction.-.PP-Be sure to note the unusual two\-space delimiter between account name-and amount.-This makes it easy to write account names containing spaces.-But if you accidentally leave only one space (or tab) before the amount,-the amount will be considered part of the account name.-.SS Dates-.SS Simple dates-.PP-Within a journal file, transaction dates use Y/M/D (or Y\-M\-D or Y.M.D)-Leading zeros are optional.-The year may be omitted, in which case it will be inferred from the-context \- the current transaction, the default year set with a default-year directive, or the current date when the command is run.-Some examples: \f[C]2010/01/31\f[], \f[C]1/31\f[],-\f[C]2010\-01\-31\f[], \f[C]2010.1.31\f[].-.SS Secondary dates-.PP-Real\-life transactions sometimes involve more than one date \- eg the-date you write a cheque, and the date it clears in your bank.-When you want to model this, eg for more accurate balances, you can-specify individual posting dates, which I recommend.-Or, you can use the secondary dates (aka auxiliary/effective dates)-feature, supported for compatibility with Ledger.-.PP-A secondary date can be written after the primary date, separated by an-equals sign.-The primary date, on the left, is used by default; the secondary date,-on the right, is used when the \f[C]\-\-date2\f[] flag is specified-(\f[C]\-\-aux\-date\f[] or \f[C]\-\-effective\f[] also work).-.PP-The meaning of secondary dates is up to you, but it\[aq]s best to follow-a consistent rule.-Eg write the bank\[aq]s clearing date as primary, and when needed, the-date the transaction was initiated as secondary.-.PP-Here\[aq]s an example.-Note that a secondary date will use the year of the primary date if-unspecified.-.IP-.nf-\f[C]-2010/2/23=2/19\ movie\ ticket-\ \ expenses:cinema\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $10-\ \ assets:checking-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ register\ checking-2010/02/23\ movie\ ticket\ \ \ \ \ \ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-10\ \ \ \ \ \ \ \ \ $\-10-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ register\ checking\ \-\-date2-2010/02/19\ movie\ ticket\ \ \ \ \ \ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-10\ \ \ \ \ \ \ \ \ $\-10-\f[]-.fi-.PP-Secondary dates require some effort; you must use them consistently in-your journal entries and remember whether to use or not use the-\f[C]\-\-date2\f[] flag for your reports.-They are included in hledger for Ledger compatibility, but posting dates-are a more powerful and less confusing alternative.-.SS Posting dates-.PP-You can give individual postings a different date from their parent-transaction, by adding a posting comment containing a tag (see below)-like \f[C]date:DATE\f[].-This is probably the best way to control posting dates precisely.-Eg in this example the expense should appear in May reports, and the-deduction from checking should be reported on 6/1 for easy bank-reconciliation:-.IP-.nf-\f[C]-2015/5/30-\ \ \ \ expenses:food\ \ \ \ \ $10\ \ \ ;\ food\ purchased\ on\ saturday\ 5/30-\ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ ;\ bank\ cleared\ it\ on\ monday,\ date:6/1-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.j\ register\ food-2015/05/30\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ expenses:food\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $10\ \ \ \ \ \ \ \ \ \ \ $10-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.j\ register\ checking-2015/06/01\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-10\ \ \ \ \ \ \ \ \ \ $\-10-\f[]-.fi-.PP-DATE should be a simple date; if the year is not specified it will use-the year of the transaction\[aq]s date.-You can set the secondary date similarly, with \f[C]date2:DATE2\f[].-The \f[C]date:\f[] or \f[C]date2:\f[] tags must have a valid simple date-value if they are present, eg a \f[C]date:\f[] tag with no value is not-allowed.-.PP-Ledger\[aq]s earlier, more compact bracketed date syntax is also-supported: \f[C][DATE]\f[], \f[C][DATE=DATE2]\f[] or \f[C][=DATE2]\f[].-hledger will attempt to parse any square\-bracketed sequence of the-\f[C]0123456789/\-.=\f[] characters in this way.-With this syntax, DATE infers its year from the transaction and DATE2-infers its year from DATE.-.SS Status-.PP-Transactions, or individual postings within a transaction, can have a-status mark, which is a single character before the transaction-description or posting account name, separated from it by a space,-indicating one of three statuses:-.PP-.TS-tab(@);-l l.-T{-mark \ -T}@T{-status-T}-_-T{-\ -T}@T{-unmarked-T}-T{-\f[C]!\f[]-T}@T{-pending-T}-T{-\f[C]*\f[]-T}@T{-cleared-T}-.TE-.PP-When reporting, you can filter by status with the-\f[C]\-U/\-\-unmarked\f[], \f[C]\-P/\-\-pending\f[], and-\f[C]\-C/\-\-cleared\f[] flags; or the \f[C]status:\f[],-\f[C]status:!\f[], and \f[C]status:*\f[] queries; or the U, P, C keys in-hledger\-ui.-.PP-Note, in Ledger and in older versions of hledger, the "unmarked" state-is called "uncleared".-As of hledger 1.3 we have renamed it to unmarked for clarity.-.PP-To replicate Ledger and old hledger\[aq]s behaviour of also matching-pending, combine \-U and \-P.-.PP-Status marks are optional, but can be helpful eg for reconciling with-real\-world accounts.-Some editor modes provide highlighting and shortcuts for working with-status.-Eg in Emacs ledger\-mode, you can toggle transaction status with C\-c-C\-e, or posting status with C\-c C\-c.-.PP-What "uncleared", "pending", and "cleared" actually mean is up to you.-Here\[aq]s one suggestion:-.PP-.TS-tab(@);-lw(9.9n) lw(60.1n).-T{-status-T}@T{-meaning-T}-_-T{-uncleared-T}@T{-recorded but not yet reconciled; needs review-T}-T{-pending-T}@T{-tentatively reconciled (if needed, eg during a big reconciliation)-T}-T{-cleared-T}@T{-complete, reconciled as far as possible, and considered correct-T}-.TE-.PP-With this scheme, you would use \f[C]\-PC\f[] to see the current balance-at your bank, \f[C]\-U\f[] to see things which will probably hit your-bank soon (like uncashed checks), and no flags to see the most-up\-to\-date state of your finances.-.SS Description-.PP-A transaction\[aq]s description is the rest of the line following the-date and status mark (or until a comment begins).-Sometimes called the "narration" in traditional bookkeeping, it can be-used for whatever you wish, or left blank.-Transaction descriptions can be queried, unlike comments.-.SS Payee and note-.PP-You can optionally include a \f[C]|\f[] (pipe) character in a-description to subdivide it into a payee/payer name on the left and-additional notes on the right.-This may be worthwhile if you need to do more precise querying and-pivoting by payee.-.SS Account names-.PP-Account names typically have several parts separated by a full colon,-from which hledger derives a hierarchical chart of accounts.-They can be anything you like, but in finance there are traditionally-five top\-level accounts: \f[C]assets\f[], \f[C]liabilities\f[],-\f[C]income\f[], \f[C]expenses\f[], and \f[C]equity\f[].-.PP-Account names may contain single spaces, eg:-\f[C]assets:accounts\ receivable\f[].-Because of this, they must always be followed by \f[B]two or more-spaces\f[] (or newline).-.PP-Account names can be aliased.-.SS Amounts-.PP-After the account name, there is usually an amount.-Important: between account name and amount, there must be \f[B]two or-more spaces\f[].-.PP-Amounts consist of a number and (usually) a currency symbol or commodity-name.-Some examples:-.PP-\f[C]2.00001\f[]-.PD 0-.P-.PD-\f[C]$1\f[]-.PD 0-.P-.PD-\f[C]4000\ AAPL\f[]-.PD 0-.P-.PD-\f[C]3\ "green\ apples"\f[]-.PD 0-.P-.PD-\f[C]\-$1,000,000.00\f[]-.PD 0-.P-.PD-\f[C]INR\ 9,99,99,999.00\f[]-.PD 0-.P-.PD-\f[C]EUR\ \-2.000.000,00\f[]-.PD 0-.P-.PD-\f[C]1\ 999\ 999.9455\f[]-.PD 0-.P-.PD-\f[C]EUR\ 1E3\f[]-.PD 0-.P-.PD-\f[C]1000E\-6s\f[]-.PP-As you can see, the amount format is somewhat flexible:-.IP \[bu] 2-amounts are a number (the "quantity") and optionally a currency-symbol/commodity name (the "commodity").-.IP \[bu] 2-the commodity is a symbol, word, or phrase, on the left or right, with-or without a separating space.-If the commodity contains numbers, spaces or non\-word punctuation it-must be enclosed in double quotes.-.IP \[bu] 2-negative amounts with a commodity on the left can have the minus sign-before or after it-.IP \[bu] 2-digit groups (thousands, or any other grouping) can be separated by-space or comma or period and should be used as separator between all-groups-.IP \[bu] 2-decimal part can be separated by comma or period and should be different-from digit groups separator-.IP \[bu] 2-scientific E\-notation is allowed.-Be careful not to use a digit group separator character in scientific-notation, as it\[aq]s not supported and it might get mistaken for a-decimal point.-(Declaring the digit group separator character explicitly with a-commodity directive will prevent this.)-.PP-You can use any of these variations when recording data.-However, there is some ambiguous way of representing numbers like-\f[C]$1.000\f[] and \f[C]$1,000\f[] both may mean either one thousand or-one dollar.-By default hledger will assume that this is sole delimiter is used only-for decimals.-On the other hand commodity format declared prior to that line will help-to resolve that ambiguity differently:-.IP-.nf-\f[C]-commodity\ $1,000.00--2017/12/25\ New\ life\ of\ Scrooge-\ \ \ \ expenses:gifts\ \ $1,000-\ \ \ \ assets-\f[]-.fi-.PP-Though journal may contain mixed styles to represent amount, when-hledger displays amounts, it will choose a consistent format for each-commodity.-(Except for price amounts, which are always formatted as written).-The display format is chosen as follows:-.IP \[bu] 2-if there is a commodity directive specifying the format, that is used-.IP \[bu] 2-otherwise the format is inferred from the first posting amount in that-commodity in the journal, and the precision (number of decimal places)-will be the maximum from all posting amounts in that commmodity-.IP \[bu] 2-or if there are no such amounts in the journal, a default format is used-(like \f[C]$1000.00\f[]).-.PP-Price amounts and amounts in \f[C]D\f[] directives usually don\[aq]t-affect amount format inference, but in some situations they can do so-indirectly.-(Eg when D\[aq]s default commodity is applied to a commodity\-less-amount, or when an amountless posting is balanced using a price\[aq]s-commodity, or when \-V is used.) If you find this causing problems, set-the desired format with a commodity directive.-.SS Virtual Postings-.PP-When you parenthesise the account name in a posting, we call that a-\f[I]virtual posting\f[], which means:-.IP \[bu] 2-it is ignored when checking that the transaction is balanced-.IP \[bu] 2-it is excluded from reports when the \f[C]\-\-real/\-R\f[] flag is used,-or the \f[C]real:1\f[] query.-.PP-You could use this, eg, to set an account\[aq]s opening balance without-needing to use the \f[C]equity:opening\ balances\f[] account:-.IP-.nf-\f[C]-1/1\ special\ unbalanced\ posting\ to\ set\ initial\ balance-\ \ (assets:checking)\ \ \ $1000-\f[]-.fi-.PP-When the account name is bracketed, we call it a \f[I]balanced virtual-posting\f[].-This is like an ordinary virtual posting except the balanced virtual-postings in a transaction must balance to 0, like the real postings (but-separately from them).-Balanced virtual postings are also excluded by \f[C]\-\-real/\-R\f[] or-\f[C]real:1\f[].-.IP-.nf-\f[C]-1/1\ buy\ food\ with\ cash,\ and\ update\ some\ budget\-tracking\ subaccounts\ elsewhere-\ \ expenses:food\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $10-\ \ assets:cash\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-10-\ \ [assets:checking:available]\ \ \ \ \ $10-\ \ [assets:checking:budget:food]\ \ $\-10-\f[]-.fi-.PP-Virtual postings have some legitimate uses, but those are few.-You can usually find an equivalent journal entry using real postings,-which is more correct and provides better error checking.-.SS Balance Assertions-.PP-hledger supports Ledger\-style balance assertions in journal files.-These look like, for example, \f[C]=\ EXPECTEDBALANCE\f[] following a-posting\[aq]s amount.-Eg here we assert the expected dollar balance in accounts a and b after-each posting:-.IP-.nf-\f[C]-2013/1/1-\ \ a\ \ \ $1\ \ =$1-\ \ b\ \ \ \ \ \ \ =$\-1--2013/1/2-\ \ a\ \ \ $1\ \ =$2-\ \ b\ \ $\-1\ \ =$\-2-\f[]-.fi-.PP-After reading a journal file, hledger will check all balance assertions-and report an error if any of them fail.-Balance assertions can protect you from, eg, inadvertently disrupting-reconciled balances while cleaning up old entries.-You can disable them temporarily with the-\f[C]\-I/\-\-ignore\-assertions\f[] flag, which can be useful for-troubleshooting or for reading Ledger files.-.SS Assertions and ordering-.PP-hledger sorts an account\[aq]s postings and assertions first by date and-then (for postings on the same day) by parse order.-Note this is different from Ledger, which sorts assertions only by parse-order.-(Also, Ledger assertions do not see the accumulated effect of repeated-postings to the same account within a transaction.)-.PP-So, hledger balance assertions keep working if you reorder-differently\-dated transactions within the journal.-But if you reorder same\-dated transactions or postings, assertions-might break and require updating.-This order dependence does bring an advantage: precise control over the-order of postings and assertions within a day, so you can assert-intra\-day balances.-.SS Assertions and included files-.PP-With included files, things are a little more complicated.-Including preserves the ordering of postings and assertions.-If you have multiple postings to an account on the same day, split-across different files, and you also want to assert the account\[aq]s-balance on the same day, you\[aq]ll have to put the assertion in the-right file.-.SS Assertions and multiple \-f options-.PP-Balance assertions don\[aq]t work well across files specified with-multiple \-f options.-Use include or concatenate the files instead.-.SS Assertions and commodities-.PP-The asserted balance must be a simple single\-commodity amount, and in-fact the assertion checks only this commodity\[aq]s balance within the-(possibly multi\-commodity) account balance.-.PD 0-.P-.PD-This is how assertions work in Ledger also.-We could call this a "partial" balance assertion.-.PP-To assert the balance of more than one commodity in an account, you can-write multiple postings, each asserting one commodity\[aq]s balance.-.PP-You can make a stronger "total" balance assertion by writing a double-equals sign (\f[C]==\ EXPECTEDBALANCE\f[]).-This asserts that there are no other unasserted commodities in the-account (or, that their balance is 0).-.IP-.nf-\f[C]-2013/1/1-\ \ a\ \ \ $1-\ \ a\ \ \ \ 1€-\ \ b\ \ $\-1-\ \ c\ \ \ \-1€--2013/1/2\ \ ;\ These\ assertions\ succeed-\ \ a\ \ \ \ 0\ \ =\ \ $1-\ \ a\ \ \ \ 0\ \ =\ \ \ 1€-\ \ b\ \ \ \ 0\ ==\ $\-1-\ \ c\ \ \ \ 0\ ==\ \ \-1€--2013/1/3\ \ ;\ This\ assertion\ fails\ as\ \[aq]a\[aq]\ also\ contains\ 1€-\ \ a\ \ \ \ 0\ ==\ \ $1-\f[]-.fi-.PP-It\[aq]s not yet possible to make a complete assertion about a balance-that has multiple commodities.-One workaround is to isolate each commodity into its own subaccount:-.IP-.nf-\f[C]-2013/1/1-\ \ a:usd\ \ \ $1-\ \ a:euro\ \ \ 1€-\ \ b--2013/1/2-\ \ a\ \ \ \ \ \ \ \ 0\ ==\ \ 0-\ \ a:usd\ \ \ \ 0\ ==\ $1-\ \ a:euro\ \ \ 0\ ==\ \ 1€-\f[]-.fi-.SS Assertions and prices-.PP-Balance assertions ignore transaction prices, and should normally be-written without one:-.IP-.nf-\f[C]-2019/1/1-\ \ (a)\ \ \ \ \ $1\ \@\ €1\ =\ $1-\f[]-.fi-.PP-We do allow prices to be written there, however, and print shows them,-even though they don\[aq]t affect whether the assertion passes or fails.-This is for backward compatibility (hledger\[aq]s close command used to-generate balance assertions with prices), and because balance-\f[I]assignments\f[] do use them (see below).-.SS Assertions and subaccounts-.PP-The balance assertions above (\f[C]=\f[] and \f[C]==\f[]) do not count-the balance from subaccounts; they check the account\[aq]s exclusive-balance only.-You can assert the balance including subaccounts by writing \f[C]=*\f[]-or \f[C]==*\f[], eg:-.IP-.nf-\f[C]-2019/1/1-\ \ equity:opening\ balances-\ \ checking:a\ \ \ \ \ \ \ 5-\ \ checking:b\ \ \ \ \ \ \ 5-\ \ checking\ \ \ \ \ \ \ \ \ 1\ \ ==*\ 11-\f[]-.fi-.SS Assertions and virtual postings-.PP-Balance assertions are checked against all postings, both real and-virtual.-They are not affected by the \f[C]\-\-real/\-R\f[] flag or-\f[C]real:\f[] query.-.SS Assertions and precision-.PP-Balance assertions compare the exactly calculated amounts, which are not-always what is shown by reports.-Eg a commodity directive may limit the display precision, but this will-not affect balance assertions.-Balance assertion failure messages show exact amounts.-.SS Balance Assignments-.PP-Ledger\-style balance assignments are also supported.-These are like balance assertions, but with no posting amount on the-left side of the equals sign; instead it is calculated automatically so-as to satisfy the assertion.-This can be a convenience during data entry, eg when setting opening-balances:-.IP-.nf-\f[C]-;\ starting\ a\ new\ journal,\ set\ asset\ account\ balances\ -2016/1/1\ opening\ balances-\ \ assets:checking\ \ \ \ \ \ \ \ \ \ \ \ =\ $409.32-\ \ assets:savings\ \ \ \ \ \ \ \ \ \ \ \ \ =\ $735.24-\ \ assets:cash\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ =\ $42-\ \ equity:opening\ balances-\f[]-.fi-.PP-or when adjusting a balance to reality:-.IP-.nf-\f[C]-;\ no\ cash\ left;\ update\ balance,\ record\ any\ untracked\ spending\ as\ a\ generic\ expense-2016/1/15-\ \ assets:cash\ \ \ \ =\ $0-\ \ expenses:misc-\f[]-.fi-.PP-The calculated amount depends on the account\[aq]s balance in the-commodity at that point (which depends on the previously\-dated postings-of the commodity to that account since the last balance assertion or-assignment).-Note that using balance assignments makes your journal a little less-explicit; to know the exact amount posted, you have to run hledger or do-the calculations yourself, instead of just reading it.-.SS Balance assignments and prices-.PP-A transaction price in a balance assignment will cause the calculated-amount to have that price attached:-.IP-.nf-\f[C]-2019/1/1-\ \ (a)\ \ \ \ \ \ \ \ \ \ \ \ \ =\ $1\ \@\ €2-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ print\ \-\-explicit-2019/01/01-\ \ \ \ (a)\ \ \ \ \ \ \ \ \ $1\ \@\ €2\ =\ $1\ \@\ €2-\f[]-.fi-.SS Transaction prices-.PP-Within a transaction, you can note an amount\[aq]s price in another-commodity.-This can be used to document the cost (in a purchase) or selling price-(in a sale).-For example, transaction prices are useful to record purchases of a-foreign currency.-Note transaction prices are fixed at the time of the transaction, and do-not change over time.-See also market prices, which represent prevailing exchange rates on a-certain date.-.PP-There are several ways to record a transaction price:-.IP "1." 3-Write the price per unit, as \f[C]\@\ UNITPRICE\f[] after the amount:-.RS 4-.IP-.nf-\f[C]-2009/1/1-\ \ assets:euros\ \ \ \ \ €100\ \@\ $1.35\ \ ;\ one\ hundred\ euros\ purchased\ at\ $1.35\ each-\ \ assets:dollars\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ;\ balancing\ amount\ is\ \-$135.00-\f[]-.fi-.RE-.IP "2." 3-Write the total price, as \f[C]\@\@\ TOTALPRICE\f[] after the amount:-.RS 4-.IP-.nf-\f[C]-2009/1/1-\ \ assets:euros\ \ \ \ \ €100\ \@\@\ $135\ \ ;\ one\ hundred\ euros\ purchased\ at\ $135\ for\ the\ lot-\ \ assets:dollars-\f[]-.fi-.RE-.IP "3." 3-Specify amounts for all postings, using exactly two commodities, and let-hledger infer the price that balances the transaction:-.RS 4-.IP-.nf-\f[C]-2009/1/1-\ \ assets:euros\ \ \ \ \ €100\ \ \ \ \ \ \ \ \ \ ;\ one\ hundred\ euros\ purchased-\ \ assets:dollars\ \ $\-135\ \ \ \ \ \ \ \ \ \ ;\ for\ $135-\f[]-.fi-.RE-.PP-(Ledger users: Ledger uses a different syntax for fixed prices,-\f[C]{=UNITPRICE}\f[], which hledger currently ignores).-.PP-Use the \f[C]\-B/\-\-cost\f[] flag to convert amounts to their-transaction price\[aq]s commodity, if any.-(mnemonic: "B" is from "cost Basis", as in Ledger).-Eg here is how \-B affects the balance report for the example above:-.IP-.nf-\f[C]-$\ hledger\ bal\ \-N\ \-\-flat-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-135\ \ assets:dollars-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ €100\ \ assets:euros-$\ hledger\ bal\ \-N\ \-\-flat\ \-B-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $\-135\ \ assets:dollars-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ $135\ \ assets:euros\ \ \ \ #\ <\-\ the\ euros\[aq]\ cost-\f[]-.fi-.PP-Note \-B is sensitive to the order of postings when a transaction price-is inferred: the inferred price will be in the commodity of the last-amount.-So if example 3\[aq]s postings are reversed, while the transaction is-equivalent, \-B shows something different:-.IP-.nf-\f[C]-2009/1/1-\ \ assets:dollars\ \ $\-135\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ;\ 135\ dollars\ sold-\ \ assets:euros\ \ \ \ \ €100\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ;\ for\ 100\ euros-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ bal\ \-N\ \-\-flat\ \-B-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ €\-100\ \ assets:dollars\ \ #\ <\-\ the\ dollars\[aq]\ selling\ price-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ €100\ \ assets:euros-\f[]-.fi-.SS Comments-.PP-Lines in the journal beginning with a semicolon (\f[C];\f[]) or hash-(\f[C]#\f[]) or star (\f[C]*\f[]) are comments, and will be ignored.-(Star comments cause org\-mode nodes to be ignored, allowing emacs users-to fold and navigate their journals with org\-mode or orgstruct\-mode.)-.PP-You can attach comments to a transaction by writing them after the-description and/or indented on the following lines (before the-postings).-Similarly, you can attach comments to an individual posting by writing-them after the amount and/or indented on the following lines.-Transaction and posting comments must begin with a semicolon-(\f[C];\f[]).-.PP-Some examples:-.IP-.nf-\f[C]-#\ a\ file\ comment--;\ also\ a\ file\ comment--comment-This\ is\ a\ multiline\ file\ comment,-which\ continues\ until\ a\ line-where\ the\ "end\ comment"\ string-appears\ on\ its\ own\ (or\ end\ of\ file).-end\ comment--2012/5/14\ something\ \ ;\ a\ transaction\ comment-\ \ \ \ ;\ the\ transaction\ comment,\ continued-\ \ \ \ posting1\ \ 1\ \ ;\ a\ comment\ for\ posting\ 1-\ \ \ \ posting2-\ \ \ \ ;\ a\ comment\ for\ posting\ 2-\ \ \ \ ;\ another\ comment\ line\ for\ posting\ 2-;\ a\ file\ comment\ (because\ not\ indented)-\f[]-.fi-.PP-You can also comment larger regions of a file using \f[C]comment\f[] and-\f[C]end\ comment\f[] directives.-.SS Tags-.PP-Tags are a way to add extra labels or labelled data to postings and-transactions, which you can then search or pivot on.-.PP-A simple tag is a word (which may contain hyphens) followed by a full-colon, written inside a transaction or posting comment line:-.IP-.nf-\f[C]-2017/1/16\ bought\ groceries\ \ \ \ ;\ sometag:-\f[]-.fi-.PP-Tags can have a value, which is the text after the colon, up to the next-comma or end of line, with leading/trailing whitespace removed:-.IP-.nf-\f[C]-\ \ \ \ expenses:food\ \ \ \ $10\ \ \ ;\ a\-posting\-tag:\ the\ tag\ value-\f[]-.fi-.PP-Note this means hledger\[aq]s tag values can not contain commas or-newlines.-Ending at commas means you can write multiple short tags on one line,-comma separated:-.IP-.nf-\f[C]-\ \ \ \ assets:checking\ \ \ \ \ \ \ ;\ a\ comment\ containing\ tag1:,\ tag2:\ some\ value\ ...-\f[]-.fi-.PP-Here,-.IP \[bu] 2-"\f[C]a\ comment\ containing\f[]" is just comment text, not a tag-.IP \[bu] 2-"\f[C]tag1\f[]" is a tag with no value-.IP \[bu] 2-"\f[C]tag2\f[]" is another tag, whose value is-"\f[C]some\ value\ ...\f[]"-.PP-Tags in a transaction comment affect the transaction and all of its-postings, while tags in a posting comment affect only that posting.-For example, the following transaction has three tags (\f[C]A\f[],-\f[C]TAG2\f[], \f[C]third\-tag\f[]) and the posting has four (those plus-\f[C]posting\-tag\f[]):-.IP-.nf-\f[C]-1/1\ a\ transaction\ \ ;\ A:,\ TAG2:-\ \ \ \ ;\ third\-tag:\ a\ third\ transaction\ tag,\ <\-\ with\ a\ value-\ \ \ \ (a)\ \ $1\ \ ;\ posting\-tag:-\f[]-.fi-.PP-Tags are like Ledger\[aq]s metadata feature, except hledger\[aq]s tag-values are simple strings.-.SS Directives-.PP-A directive is a line in the journal beginning with a special keyword,-that influences how the journal is processed.-hledger\[aq]s directives are based on a subset of Ledger\[aq]s, but-there are many differences (and also some differences between hledger-versions).-.PP-Directives\[aq] behaviour and interactions can get a little bit complex,-so here is a table summarising the directives and their effects, with-links to more detailed docs.-.PP-.TS-tab(@);-lw(7.8n) lw(8.6n) lw(7.0n) lw(27.8n) lw(18.8n).-T{-directive-T}@T{-end directive-T}@T{-subdirectives-T}@T{-purpose-T}@T{-can affect (as of 2018/06)-T}-_-T{-\f[C]account\f[]-T}@T{-T}@T{-any text-T}@T{-document account names, declare account types & display order-T}@T{-all entries in all files, before or after-T}-T{-\f[C]alias\f[]-T}@T{-\f[C]end\ aliases\f[]-T}@T{-T}@T{-rewrite account names-T}@T{-following inline/included entries until end of current file or end-directive-T}-T{-\f[C]apply\ account\f[]-T}@T{-\f[C]end\ apply\ account\f[]-T}@T{-T}@T{-prepend a common parent to account names-T}@T{-following inline/included entries until end of current file or end-directive-T}-T{-\f[C]comment\f[]-T}@T{-\f[C]end\ comment\f[]-T}@T{-T}@T{-ignore part of journal-T}@T{-following inline/included entries until end of current file or end-directive-T}-T{-\f[C]commodity\f[]-T}@T{-T}@T{-\f[C]format\f[]-T}@T{-declare a commodity and its number notation & display style-T}@T{-number notation: following entries in that commodity in all files;-display style: amounts of that commodity in reports-T}-T{-\f[C]D\f[]-T}@T{-T}@T{-T}@T{-declare a commodity, number notation & display style for commodityless-amounts-T}@T{-commodity: all commodityless entries in all files; number notation:-following commodityless entries and entries in that commodity in all-files; display style: amounts of that commodity in reports-T}-T{-\f[C]include\f[]-T}@T{-T}@T{-T}@T{-include entries/directives from another file-T}@T{-what the included directives affect-T}-T{-\f[C]P\f[]-T}@T{-T}@T{-T}@T{-declare a market price for a commodity-T}@T{-amounts of that commodity in reports, when \-V is used-T}-T{-\f[C]Y\f[]-T}@T{-T}@T{-T}@T{-declare a year for yearless dates-T}@T{-following inline/included entries until end of current file-T}-.TE-.PP-And some definitions:-.PP-.TS-tab(@);-lw(8.9n) lw(61.1n).-T{-subdirective-T}@T{-optional indented directive line immediately following a parent-directive-T}-T{-number notation-T}@T{-how to interpret numbers when parsing journal entries (the identity of-the decimal separator character).-(Currently each commodity can have its own notation, even in the same-file.)-T}-T{-display style-T}@T{-how to display amounts of a commodity in reports (symbol side and-spacing, digit groups, decimal separator, decimal places)-T}-T{-directive scope-T}@T{-which entries and (when there are multiple files) which files are-affected by a directive-T}-.TE-.PP-As you can see, directives vary in which journal entries and files they-affect, and whether they are focussed on input (parsing) or output-(reports).-Some directives have multiple effects.-.PP-If you have a journal made up of multiple files, or pass multiple \-f-options on the command line, note that directives which affect input-typically last only until the end of their defining file.-This provides more simplicity and predictability, eg reports are not-changed by writing file options in a different order.-It can be surprising at times though.-.SS Comment blocks-.PP-A line containing just \f[C]comment\f[] starts a commented region of the-file, and a line containing just \f[C]end\ comment\f[] (or the end of-the current file) ends it.-See also comments.-.SS Including other files-.PP-You can pull in the content of additional files by writing an include-directive, like this:-.IP-.nf-\f[C]-include\ path/to/file.journal-\f[]-.fi-.PP-If the path does not begin with a slash, it is relative to the current-file.-The include file path may contain common glob patterns (e.g.-\f[C]*\f[]).-.PP-The \f[C]include\f[] directive can only be used in journal files.-It can include journal, timeclock or timedot files, but not CSV files.-.SS Default year-.PP-You can set a default year to be used for subsequent dates which-don\[aq]t specify a year.-This is a line beginning with \f[C]Y\f[] followed by the year.-Eg:-.IP-.nf-\f[C]-Y2009\ \ \ \ \ \ ;\ set\ default\ year\ to\ 2009--12/15\ \ \ \ \ \ ;\ equivalent\ to\ 2009/12/15-\ \ expenses\ \ 1-\ \ assets--Y2010\ \ \ \ \ \ ;\ change\ default\ year\ to\ 2010--2009/1/30\ \ ;\ specifies\ the\ year,\ not\ affected-\ \ expenses\ \ 1-\ \ assets--1/31\ \ \ \ \ \ \ ;\ equivalent\ to\ 2010/1/31-\ \ expenses\ \ 1-\ \ assets-\f[]-.fi-.SS Declaring commodities-.PP-The \f[C]commodity\f[] directive declares commodities which may be used-in the journal (though currently we do not enforce this).-It may be written on a single line, like this:-.IP-.nf-\f[C]-;\ commodity\ EXAMPLEAMOUNT--;\ display\ AAAA\ amounts\ with\ the\ symbol\ on\ the\ right,\ space\-separated,-;\ using\ period\ as\ decimal\ point,\ with\ four\ decimal\ places,\ and-;\ separating\ thousands\ with\ comma.-commodity\ 1,000.0000\ AAAA-\f[]-.fi-.PP-or on multiple lines, using the "format" subdirective.-In this case the commodity symbol appears twice and should be the same-in both places:-.IP-.nf-\f[C]-;\ commodity\ SYMBOL-;\ \ \ format\ EXAMPLEAMOUNT--;\ display\ indian\ rupees\ with\ currency\ name\ on\ the\ left,-;\ thousands,\ lakhs\ and\ crores\ comma\-separated,-;\ period\ as\ decimal\ point,\ and\ two\ decimal\ places.-commodity\ INR-\ \ format\ INR\ 9,99,99,999.00-\f[]-.fi-.PP-Commodity directives have a second purpose: they define the standard-display format for amounts in the commodity.-Normally the display format is inferred from journal entries, but this-can be unpredictable; declaring it with a commodity directive overrides-this and removes ambiguity.-Towards this end, amounts in commodity directives must always be written-with a decimal point (a period or comma, followed by 0 or more decimal-digits).-.SS Default commodity-.PP-The \f[C]D\f[] directive sets a default commodity (and display format),-to be used for amounts without a commodity symbol (ie, plain numbers).-(Note this differs from Ledger\[aq]s default commodity directive.) The-commodity and display format will be applied to all subsequent-commodity\-less amounts, or until the next \f[C]D\f[] directive.-.IP-.nf-\f[C]-#\ commodity\-less\ amounts\ should\ be\ treated\ as\ dollars-#\ (and\ displayed\ with\ symbol\ on\ the\ left,\ thousands\ separators\ and\ two\ decimal\ places)-D\ $1,000.00--1/1-\ \ a\ \ \ \ \ 5\ \ \ \ ;\ <\-\ commodity\-less\ amount,\ becomes\ $1-\ \ b-\f[]-.fi-.PP-As with the \f[C]commodity\f[] directive, the amount must always be-written with a decimal point.-.SS Market prices-.PP-The \f[C]P\f[] directive declares a market price, which is an exchange-rate between two commodities on a certain date.-(In Ledger, they are called "historical prices".) These are often-obtained from a stock exchange, cryptocurrency exchange, or the foreign-exchange market.-.PP-Here is the format:-.IP-.nf-\f[C]-P\ DATE\ COMMODITYA\ COMMODITYBAMOUNT-\f[]-.fi-.IP \[bu] 2-DATE is a simple date-.IP \[bu] 2-COMMODITYA is the symbol of the commodity being priced-.IP \[bu] 2-COMMODITYBAMOUNT is an amount (symbol and quantity) in a second-commodity, giving the price in commodity B of one unit of commodity A.-.PP-These two market price directives say that one euro was worth 1.35 US-dollars during 2009, and $1.40 from 2010 onward:-.IP-.nf-\f[C]-P\ 2009/1/1\ €\ $1.35-P\ 2010/1/1\ €\ $1.40-\f[]-.fi-.PP-The \f[C]\-V/\-\-value\f[] flag can be used to convert reported amounts-to another commodity using these prices.-.SS Declaring accounts-.PP-\f[C]account\f[] directives can be used to pre\-declare accounts.-Though not required, they can provide several benefits:-.IP \[bu] 2-They can document your intended chart of accounts, providing a-reference.-.IP \[bu] 2-They can store extra information about accounts (account numbers, notes,-etc.)-.IP \[bu] 2-They can help hledger know your accounts\[aq] types (asset, liability,-equity, revenue, expense), useful for reports like balancesheet and-incomestatement.-.IP \[bu] 2-They control account display order in reports, allowing non\-alphabetic-sorting (eg Revenues to appear above Expenses).-.IP \[bu] 2-They help with account name completion in the add command,-hledger\-iadd, hledger\-web, ledger\-mode etc.-.PP-The simplest form is just the word \f[C]account\f[] followed by a-hledger\-style account name, eg:-.IP-.nf-\f[C]-account\ assets:bank:checking-\f[]-.fi-.SS Account comments-.PP-Comments, beginning with a semicolon, optionally including tags, can be-written after the account name, and/or on following lines.-Eg:-.IP-.nf-\f[C]-account\ assets:bank:checking\ \ ;\ a\ comment-\ \ ;\ another\ comment-\ \ ;\ acctno:12345,\ a\ tag-\f[]-.fi-.PP-Tip: comments on the same line require hledger 1.12+.-If you need your journal to be compatible with older hledger versions,-write comments on the next line instead.-.SS Account subdirectives-.PP-We also allow (and ignore) Ledger\-style indented subdirectives, just-for compatibility.:-.IP-.nf-\f[C]-account\ assets:bank:checking-\ \ format\ blah\ blah\ \ ;\ <\-\ subdirective,\ ignored-\f[]-.fi-.PP-Here is the full syntax of account directives:-.IP-.nf-\f[C]-account\ ACCTNAME\ \ [ACCTTYPE]\ [;COMMENT]-\ \ [;COMMENTS]-\ \ [LEDGER\-STYLE\ SUBDIRECTIVES,\ IGNORED]-\f[]-.fi-.SS Account types-.PP-hledger recognises five types (or classes) of account: Asset, Liability,-Equity, Revenue, Expense.-This is used by a few accounting\-aware reports such as balancesheet,-incomestatement and cashflow.-.SS Auto\-detected account types-.PP-If you name your top\-level accounts with some variation of-\f[C]assets\f[], \f[C]liabilities\f[]/\f[C]debts\f[], \f[C]equity\f[],-\f[C]revenues\f[]/\f[C]income\f[], or \f[C]expenses\f[], their types are-detected automatically.-.SS Account types declared with tags-.PP-More generally, you can declare an account\[aq]s type with an account-directive, by writing a \f[C]type:\f[] tag in a comment, followed by one-of the words \f[C]Asset\f[], \f[C]Liability\f[], \f[C]Equity\f[],-\f[C]Revenue\f[], \f[C]Expense\f[], or one of the letters \f[C]ALERX\f[]-(case insensitive):-.IP-.nf-\f[C]-account\ assets\ \ \ \ \ \ \ ;\ type:Asset-account\ liabilities\ \ ;\ type:Liability-account\ equity\ \ \ \ \ \ \ ;\ type:Equity-account\ revenues\ \ \ \ \ ;\ type:Revenue-account\ expenses\ \ \ \ \ ;\ type:Expenses-\f[]-.fi-.SS Account types declared with account type codes-.PP-Or, you can write one of those letters separated from the account name-by two or more spaces, but this should probably be considered deprecated-as of hledger 1.13:-.IP-.nf-\f[C]-account\ assets\ \ \ \ \ \ \ A-account\ liabilities\ \ L-account\ equity\ \ \ \ \ \ \ E-account\ revenues\ \ \ \ \ R-account\ expenses\ \ \ \ \ X-\f[]-.fi-.SS Overriding auto\-detected types-.PP-If you ever override the types of those auto\-detected english account-names mentioned above, you might need to help the reports a bit.-Eg:-.IP-.nf-\f[C]-;\ make\ "liabilities"\ not\ have\ the\ liability\ type\ \-\ who\ knows\ why-account\ liabilities\ \ \ ;\ type:E--;\ we\ need\ to\ ensure\ some\ other\ account\ has\ the\ liability\ type,\ -;\ otherwise\ balancesheet\ would\ still\ show\ "liabilities"\ under\ Liabilities\ -account\ \-\ \ \ \ \ \ \ \ \ \ \ \ \ ;\ type:L-\f[]-.fi-.SS Account display order-.PP-Account directives also set the order in which accounts are displayed,-eg in reports, the hledger\-ui accounts screen, and the hledger\-web-sidebar.-By default accounts are listed in alphabetical order.-But if you have these account directives in the journal:-.IP-.nf-\f[C]-account\ assets-account\ liabilities-account\ equity-account\ revenues-account\ expenses-\f[]-.fi-.PP-you\[aq]ll see those accounts displayed in declaration order, not-alphabetically:-.IP-.nf-\f[C]-$\ hledger\ accounts\ \-1-assets-liabilities-equity-revenues-expenses-\f[]-.fi-.PP-Undeclared accounts, if any, are displayed last, in alphabetical order.-.PP-Note that sorting is done at each level of the account tree (within each-group of sibling accounts under the same parent).-And currently, this directive:-.IP-.nf-\f[C]-account\ other:zoo-\f[]-.fi-.PP-would influence the position of \f[C]zoo\f[] among \f[C]other\f[]\[aq]s-subaccounts, but not the position of \f[C]other\f[] among the top\-level-accounts.-This means: \- you will sometimes declare parent accounts (eg-\f[C]account\ other\f[] above) that you don\[aq]t intend to post to,-just to customize their display order \- sibling accounts stay together-(you couldn\[aq]t display \f[C]x:y\f[] in between \f[C]a:b\f[] and-\f[C]a:c\f[]).-.SS Rewriting accounts-.PP-You can define account alias rules which rewrite your account names, or-parts of them, before generating reports.-This can be useful for:-.IP \[bu] 2-expanding shorthand account names to their full form, allowing easier-data entry and a less verbose journal-.IP \[bu] 2-adapting old journals to your current chart of accounts-.IP \[bu] 2-experimenting with new account organisations, like a new hierarchy or-combining two accounts into one-.IP \[bu] 2-customising reports-.PP-Account aliases also rewrite account names in account directives.-They do not affect account names being entered via hledger add or-hledger\-web.-.PP-See also Cookbook: Rewrite account names.-.SS Basic aliases-.PP-To set an account alias, use the \f[C]alias\f[] directive in your-journal file.-This affects all subsequent journal entries in the current file or its-included files.-The spaces around the = are optional:-.IP-.nf-\f[C]-alias\ OLD\ =\ NEW-\f[]-.fi-.PP-Or, you can use the \f[C]\-\-alias\ \[aq]OLD=NEW\[aq]\f[] option on the-command line.-This affects all entries.-It\[aq]s useful for trying out aliases interactively.-.PP-OLD and NEW are case sensitive full account names.-hledger will replace any occurrence of the old account name with the new-one.-Subaccounts are also affected.-Eg:-.IP-.nf-\f[C]-alias\ checking\ =\ assets:bank:wells\ fargo:checking-#\ rewrites\ "checking"\ to\ "assets:bank:wells\ fargo:checking",\ or\ "checking:a"\ to\ "assets:bank:wells\ fargo:checking:a"-\f[]-.fi-.SS Regex aliases-.PP-There is also a more powerful variant that uses a regular expression,-indicated by the forward slashes:-.IP-.nf-\f[C]-alias\ /REGEX/\ =\ REPLACEMENT-\f[]-.fi-.PP-or \f[C]\-\-alias\ \[aq]/REGEX/=REPLACEMENT\[aq]\f[].-.PP-REGEX is a case\-insensitive regular expression.-Anywhere it matches inside an account name, the matched part will be-replaced by REPLACEMENT.-If REGEX contains parenthesised match groups, these can be referenced by-the usual numeric backreferences in REPLACEMENT.-Eg:-.IP-.nf-\f[C]-alias\ /^(.+):bank:([^:]+)(.*)/\ =\ \\1:\\2\ \\3-#\ rewrites\ "assets:bank:wells\ fargo:checking"\ to\ \ "assets:wells\ fargo\ checking"-\f[]-.fi-.PP-Also note that REPLACEMENT continues to the end of line (or on command-line, to end of option argument), so it can contain trailing whitespace.-.SS Multiple aliases-.PP-You can define as many aliases as you like using directives or-command\-line options.-Aliases are recursive \- each alias sees the result of applying previous-ones.-(This is different from Ledger, where aliases are non\-recursive by-default).-Aliases are applied in the following order:-.IP "1." 3-alias directives, most recently seen first (recent directives take-precedence over earlier ones; directives not yet seen are ignored)-.IP "2." 3-alias options, in the order they appear on the command line-.SS \f[C]end\ aliases\f[]-.PP-You can clear (forget) all currently defined aliases with the-\f[C]end\ aliases\f[] directive:-.IP-.nf-\f[C]-end\ aliases-\f[]-.fi-.SS Default parent account-.PP-You can specify a parent account which will be prepended to all accounts-within a section of the journal.-Use the \f[C]apply\ account\f[] and \f[C]end\ apply\ account\f[]-directives like so:-.IP-.nf-\f[C]-apply\ account\ home--2010/1/1-\ \ \ \ food\ \ \ \ $10-\ \ \ \ cash--end\ apply\ account-\f[]-.fi-.PP-which is equivalent to:-.IP-.nf-\f[C]-2010/01/01-\ \ \ \ home:food\ \ \ \ \ \ \ \ \ \ \ $10-\ \ \ \ home:cash\ \ \ \ \ \ \ \ \ \ $\-10-\f[]-.fi-.PP-If \f[C]end\ apply\ account\f[] is omitted, the effect lasts to the end-of the file.-Included files are also affected, eg:-.IP-.nf-\f[C]-apply\ account\ business-include\ biz.journal-end\ apply\ account-apply\ account\ personal-include\ personal.journal-\f[]-.fi-.PP-Prior to hledger 1.0, legacy \f[C]account\f[] and \f[C]end\f[] spellings-were also supported.-.PP-A default parent account also affects account directives.-It does not affect account names being entered via hledger add or-hledger\-web.-If account aliases are present, they are applied after the default-parent account.-.SS Periodic transactions-.PP-Periodic transaction rules describe transactions that recur.-They allow you to generate future transactions for forecasting, without-having to write them out explicitly in the journal (with-\f[C]\-\-forecast\f[]).-Secondly, they also can be used to define budget goals (with-\f[C]\-\-budget\f[]).-.PP-A periodic transaction rule looks like a normal journal entry, with the-date replaced by a tilde (\f[C]~\f[]) followed by a period expression-(mnemonic: \f[C]~\f[] looks like a recurring sine wave.):-.IP-.nf-\f[C]-~\ monthly-\ \ \ \ expenses:rent\ \ \ \ \ \ \ \ \ \ $2000-\ \ \ \ assets:bank:checking-\f[]-.fi-.PP-There is an additional constraint on the period expression: the start-date must fall on a natural boundary of the interval.-Eg \f[C]monthly\ from\ 2018/1/1\f[] is valid, but-\f[C]monthly\ from\ 2018/1/15\f[] is not.-.PP-Partial or relative dates (M/D, D, tomorrow, last week) in the period-expression can work (useful or not).-They will be relative to today\[aq]s date, unless a Y default year-directive is in effect, in which case they will be relative to Y/1/1.-.SS Two spaces after the period expression-.PP-If the period expression is followed by a transaction description, these-must be separated by \f[B]two or more spaces\f[].-This helps hledger know where the period expression ends, so that-descriptions can not accidentally alter their meaning, as in this-example:-.IP-.nf-\f[C]-;\ 2\ or\ more\ spaces\ needed\ here,\ so\ the\ period\ is\ not\ understood\ as\ "every\ 2\ months\ in\ 2020"-;\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ||-;\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ vv-~\ every\ 2\ months\ \ in\ 2020,\ we\ will\ review-\ \ \ \ assets:bank:checking\ \ \ $1500-\ \ \ \ income:acme\ inc-\f[]-.fi-.SS Forecasting with periodic transactions-.PP-With the \f[C]\-\-forecast\f[] flag, each periodic transaction rule-generates future transactions recurring at the specified interval.-These are not saved in the journal, but appear in all reports.-They will look like normal transactions, but with an extra tag named-\f[C]recur\f[], whose value is the generating period expression.-.PP-Forecast transactions start on the first occurrence, and end on the last-occurrence, of their interval within the forecast period.-The forecast period:-.IP \[bu] 2-begins on the later of-.RS 2-.IP \[bu] 2-the report start date if specified with \-b/\-p/date:-.IP \[bu] 2-the day after the latest normal (non\-periodic) transaction in the-journal, or today if there are no normal transactions.-.RE-.IP \[bu] 2-ends on the report end date if specified with \-e/\-p/date:, or 180 days-from today.-.PP-where "today" means the current date at report time.-The "later of" rule ensures that forecast transactions do not overlap-normal transactions in time; they will begin only after normal-transactions end.-.PP-Forecasting can be useful for estimating balances into the future, and-experimenting with different scenarios.-Note the start date logic means that forecasted transactions are-automatically replaced by normal transactions as you add those.-.PP-Forecasting can also help with data entry: describe most of your-transactions with periodic rules, and every so often copy the output of-\f[C]print\ \-\-forecast\f[] to the journal.-.PP-You can generate one\-time transactions too: just write a period-expression specifying a date with no report interval.-(You could also write a normal transaction with a future date, but-remember this disables forecast transactions on previous dates.)-.SS Budgeting with periodic transactions-.PP-With the \f[C]\-\-budget\f[] flag, currently supported by the balance-command, each periodic transaction rule declares recurring budget goals-for the specified accounts.-Eg the first example above declares a goal of spending $2000 on rent-(and also, a goal of depositing $2000 into checking) every month.-Goals and actual performance can then be compared in budget reports.-.PP-For more details, see: balance: Budget report and Cookbook: Budgeting-and Forecasting.-.PP-.SS Transaction modifiers-.PP-Transaction modifier rules describe changes that should be applied-automatically to certain transactions.-They can be enabled by using the \f[C]\-\-auto\f[] flag.-Currently, just one kind of change is possible: adding extra postings.-These rule\-generated postings are known as "automated postings" or-"auto postings".-.PP-A transaction modifier rule looks quite like a normal transaction,-except the first line is an equals sign followed by a query that matches-certain postings (mnemonic: \f[C]=\f[] suggests matching).-And each "posting" is actually a posting\-generating rule:-.IP-.nf-\f[C]-=\ QUERY-\ \ \ \ ACCT\ \ AMT-\ \ \ \ ACCT\ \ [AMT]-\ \ \ \ ...-\f[]-.fi-.PP-These posting rules look like normal postings, except the amount can be:-.IP \[bu] 2-a normal amount with a commodity symbol, eg \f[C]$2\f[].-This will be used as\-is.-.IP \[bu] 2-a number, eg \f[C]2\f[].-The commodity symbol (if any) from the matched posting will be added to-this.-.IP \[bu] 2-a numeric multiplier, eg \f[C]*2\f[] (a star followed by a number N).-The matched posting\[aq]s amount (and total price, if any) will be-multiplied by N.-.IP \[bu] 2-a multiplier with a commodity symbol, eg \f[C]*$2\f[] (a star, number N,-and symbol S).-The matched posting\[aq]s amount will be multiplied by N, and its-commodity symbol will be replaced with S.-.PP-Some examples:-.IP-.nf-\f[C]-;\ every\ time\ I\ buy\ food,\ schedule\ a\ dollar\ donation-=\ expenses:food-\ \ \ \ (liabilities:charity)\ \ \ $\-1--;\ when\ I\ buy\ a\ gift,\ also\ deduct\ that\ amount\ from\ a\ budget\ envelope\ subaccount-=\ expenses:gifts-\ \ \ \ assets:checking:gifts\ \ *\-1-\ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ *1--2017/12/1-\ \ expenses:food\ \ \ \ $10-\ \ assets:checking--2017/12/14-\ \ expenses:gifts\ \ \ $20-\ \ assets:checking-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ print\ \-\-auto-2017/12/01-\ \ \ \ expenses:food\ \ \ \ \ \ \ \ \ \ \ \ \ \ $10-\ \ \ \ assets:checking-\ \ \ \ (liabilities:charity)\ \ \ \ \ \ $\-1--2017/12/14-\ \ \ \ expenses:gifts\ \ \ \ \ \ \ \ \ \ \ \ \ $20-\ \ \ \ assets:checking-\ \ \ \ assets:checking:gifts\ \ \ \ \ \-$20-\ \ \ \ assets:checking\ \ \ \ \ \ \ \ \ \ \ \ $20-\f[]-.fi-.SS Auto postings and transaction balancing / inferred amounts / balance-assertions-.PP-Currently, transaction modifiers are applied / auto postings are added:-.IP \[bu] 2-after missing amounts are inferred, and transactions are checked for-balancedness,-.IP \[bu] 2-but before balance assertions are checked.-.PP-Note this means that journal entries must be balanced both before and-after auto postings are added.-This changed in hledger 1.12+; see #893 for background.-.SH EDITOR SUPPORT-.PP-Helper modes exist for popular text editors, which make working with-journal files easier.-They add colour, formatting, tab completion, and helpful commands, and-are quite recommended if you edit your journal with a text editor.-They include ledger\-mode or hledger\-mode for Emacs, vim\-ledger for-Vim, hledger\-vscode for Visual Studio Code, and others.-See the [[Cookbook]] at hledger.org for the latest information.---.SH "REPORTING BUGS"-Report bugs at http://bugs.hledger.org-(or on the #hledger IRC channel or hledger mail list)--.SH AUTHORS-Simon Michael <simon@joyful.com> and contributors--.SH COPYRIGHT--Copyright (C) 2007-2016 Simon Michael.-.br-Released under GNU GPL v3 or later.--.SH SEE ALSO-hledger(1), hledger\-ui(1), hledger\-web(1), hledger\-api(1),-hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_timedot(5),-ledger(1)--http://hledger.org
− hledger_journal.info 
@@ -1,1693 +0,0 @@-This is hledger_journal.info, produced by makeinfo version 6.5 from-stdin.---File: hledger_journal.info,  Node: Top,  Next: FILE FORMAT,  Up: (dir)--hledger_journal(5) hledger 1.14-*******************************--hledger's usual data source is a plain text file containing journal-entries in hledger journal format.  This file represents a standard-accounting general journal.  I use file names ending in '.journal', but-that's not required.  The journal file contains a number of transaction-entries, each describing a transfer of money (or any commodity) between-two or more named accounts, in a simple format readable by both hledger-and humans.--   hledger's journal format is a compatible subset, mostly, of ledger's-journal format, so hledger can work with compatible ledger journal files-as well.  It's safe, and encouraged, to run both hledger and ledger on-the same journal file, eg to validate the results you're getting.--   You can use hledger without learning any more about this file; just-use the add or web commands to create and update it.  Many users,-though, also edit the journal file directly with a text editor, perhaps-assisted by the helper modes for emacs or vim.--   Here's an example:--; A sample journal file. This is a comment.--2008/01/01 income               ; <- transaction's first line starts in column 0, contains date and description-    assets:bank:checking  $1    ; <- posting lines start with whitespace, each contains an account name-    income:salary        $-1    ;    followed by at least two spaces and an amount--2008/06/01 gift-    assets:bank:checking  $1    ; <- at least two postings in a transaction-    income:gifts         $-1    ; <- their amounts must balance to 0--2008/06/02 save-    assets:bank:saving    $1-    assets:bank:checking        ; <- one amount may be omitted; here $-1 is inferred--2008/06/03 eat & shop           ; <- description can be anything-    expenses:food         $1-    expenses:supplies     $1    ; <- this transaction debits two expense accounts-    assets:cash                 ; <- $-2 inferred--2008/10/01 take a loan-    assets:bank:checking  $1-    liabilities:debts    $-1--2008/12/31 * pay off            ; <- an optional * or ! after the date means "cleared" (or anything you want)-    liabilities:debts     $1-    assets:bank:checking--* Menu:--* FILE FORMAT::-* EDITOR SUPPORT::---File: hledger_journal.info,  Node: FILE FORMAT,  Next: EDITOR SUPPORT,  Prev: Top,  Up: Top--1 FILE FORMAT-*************--* Menu:--* Transactions::-* Postings::-* Dates::-* Status::-* Description::-* Account names::-* Amounts::-* Virtual Postings::-* Balance Assertions::-* Balance Assignments::-* Transaction prices::-* Comments::-* Tags::-* Directives::-* Periodic transactions::-* Transaction modifiers::---File: hledger_journal.info,  Node: Transactions,  Next: Postings,  Up: FILE FORMAT--1.1 Transactions-================--Transactions are movements of some quantity of commodities between named-accounts.  Each transaction is represented by a journal entry beginning-with a simple date in column 0.  This can be followed by any of the-following, separated by spaces:--   * (optional) a status character (empty, '!', or '*')-   * (optional) a transaction code (any short number or text, enclosed-     in parentheses)-   * (optional) a transaction description (any remaining text until end-     of line or a semicolon)-   * (optional) a transaction comment (any remaining text following a-     semicolon until end of line)--   Then comes zero or more (but usually at least 2) indented lines-representing...---File: hledger_journal.info,  Node: Postings,  Next: Dates,  Prev: Transactions,  Up: FILE FORMAT--1.2 Postings-============--A posting is an addition of some amount to, or removal of some amount-from, an account.  Each posting line begins with at least one space or-tab (2 or 4 spaces is common), followed by:--   * (optional) a status character (empty, '!', or '*'), followed by a-     space-   * (required) an account name (any text, optionally containing *single-     spaces*, until end of line or a double space)-   * (optional) *two or more spaces* or tabs followed by an amount.--   Positive amounts are being added to the account, negative amounts are-being removed.--   The amounts within a transaction must always sum up to zero.  As a-convenience, one amount may be left blank; it will be inferred so as to-balance the transaction.--   Be sure to note the unusual two-space delimiter between account name-and amount.  This makes it easy to write account names containing-spaces.  But if you accidentally leave only one space (or tab) before-the amount, the amount will be considered part of the account name.---File: hledger_journal.info,  Node: Dates,  Next: Status,  Prev: Postings,  Up: FILE FORMAT--1.3 Dates-=========--* Menu:--* Simple dates::-* Secondary dates::-* Posting dates::---File: hledger_journal.info,  Node: Simple dates,  Next: Secondary dates,  Up: Dates--1.3.1 Simple dates---------------------Within a journal file, transaction dates use Y/M/D (or Y-M-D or Y.M.D)-Leading zeros are optional.  The year may be omitted, in which case it-will be inferred from the context - the current transaction, the default-year set with a default year directive, or the current date when the-command is run.  Some examples: '2010/01/31', '1/31', '2010-01-31',-'2010.1.31'.---File: hledger_journal.info,  Node: Secondary dates,  Next: Posting dates,  Prev: Simple dates,  Up: Dates--1.3.2 Secondary dates------------------------Real-life transactions sometimes involve more than one date - eg the-date you write a cheque, and the date it clears in your bank.  When you-want to model this, eg for more accurate balances, you can specify-individual posting dates, which I recommend.  Or, you can use the-secondary dates (aka auxiliary/effective dates) feature, supported for-compatibility with Ledger.--   A secondary date can be written after the primary date, separated by-an equals sign.  The primary date, on the left, is used by default; the-secondary date, on the right, is used when the '--date2' flag is-specified ('--aux-date' or '--effective' also work).--   The meaning of secondary dates is up to you, but it's best to follow-a consistent rule.  Eg write the bank's clearing date as primary, and-when needed, the date the transaction was initiated as secondary.--   Here's an example.  Note that a secondary date will use the year of-the primary date if unspecified.--2010/2/23=2/19 movie ticket-  expenses:cinema                   $10-  assets:checking--$ hledger register checking-2010/02/23 movie ticket         assets:checking                $-10         $-10--$ hledger register checking --date2-2010/02/19 movie ticket         assets:checking                $-10         $-10--   Secondary dates require some effort; you must use them consistently-in your journal entries and remember whether to use or not use the-'--date2' flag for your reports.  They are included in hledger for-Ledger compatibility, but posting dates are a more powerful and less-confusing alternative.---File: hledger_journal.info,  Node: Posting dates,  Prev: Secondary dates,  Up: Dates--1.3.3 Posting dates----------------------You can give individual postings a different date from their parent-transaction, by adding a posting comment containing a tag (see below)-like 'date:DATE'.  This is probably the best way to control posting-dates precisely.  Eg in this example the expense should appear in May-reports, and the deduction from checking should be reported on 6/1 for-easy bank reconciliation:--2015/5/30-    expenses:food     $10   ; food purchased on saturday 5/30-    assets:checking         ; bank cleared it on monday, date:6/1--$ hledger -f t.j register food-2015/05/30                      expenses:food                  $10           $10--$ hledger -f t.j register checking-2015/06/01                      assets:checking               $-10          $-10--   DATE should be a simple date; if the year is not specified it will-use the year of the transaction's date.  You can set the secondary date-similarly, with 'date2:DATE2'.  The 'date:' or 'date2:' tags must have a-valid simple date value if they are present, eg a 'date:' tag with no-value is not allowed.--   Ledger's earlier, more compact bracketed date syntax is also-supported: '[DATE]', '[DATE=DATE2]' or '[=DATE2]'.  hledger will attempt-to parse any square-bracketed sequence of the '0123456789/-.='-characters in this way.  With this syntax, DATE infers its year from the-transaction and DATE2 infers its year from DATE.---File: hledger_journal.info,  Node: Status,  Next: Description,  Prev: Dates,  Up: FILE FORMAT--1.4 Status-==========--Transactions, or individual postings within a transaction, can have a-status mark, which is a single character before the transaction-description or posting account name, separated from it by a space,-indicating one of three statuses:--mark  status- -------------------      unmarked-'!'   pending-'*'   cleared--   When reporting, you can filter by status with the '-U/--unmarked',-'-P/--pending', and '-C/--cleared' flags; or the 'status:', 'status:!',-and 'status:*' queries; or the U, P, C keys in hledger-ui.--   Note, in Ledger and in older versions of hledger, the "unmarked"-state is called "uncleared".  As of hledger 1.3 we have renamed it to-unmarked for clarity.--   To replicate Ledger and old hledger's behaviour of also matching-pending, combine -U and -P.--   Status marks are optional, but can be helpful eg for reconciling with-real-world accounts.  Some editor modes provide highlighting and-shortcuts for working with status.  Eg in Emacs ledger-mode, you can-toggle transaction status with C-c C-e, or posting status with C-c C-c.--   What "uncleared", "pending", and "cleared" actually mean is up to-you.  Here's one suggestion:--status     meaning----------------------------------------------------------------------------uncleared  recorded but not yet reconciled; needs review-pending    tentatively reconciled (if needed, eg during a big-           reconciliation)-cleared    complete, reconciled as far as possible, and considered-           correct--   With this scheme, you would use '-PC' to see the current balance at-your bank, '-U' to see things which will probably hit your bank soon-(like uncashed checks), and no flags to see the most up-to-date state of-your finances.---File: hledger_journal.info,  Node: Description,  Next: Account names,  Prev: Status,  Up: FILE FORMAT--1.5 Description-===============--A transaction's description is the rest of the line following the date-and status mark (or until a comment begins).  Sometimes called the-"narration" in traditional bookkeeping, it can be used for whatever you-wish, or left blank.  Transaction descriptions can be queried, unlike-comments.-* Menu:--* Payee and note::---File: hledger_journal.info,  Node: Payee and note,  Up: Description--1.5.1 Payee and note-----------------------You can optionally include a '|' (pipe) character in a description to-subdivide it into a payee/payer name on the left and additional notes on-the right.  This may be worthwhile if you need to do more precise-querying and pivoting by payee.---File: hledger_journal.info,  Node: Account names,  Next: Amounts,  Prev: Description,  Up: FILE FORMAT--1.6 Account names-=================--Account names typically have several parts separated by a full colon,-from which hledger derives a hierarchical chart of accounts.  They can-be anything you like, but in finance there are traditionally five-top-level accounts: 'assets', 'liabilities', 'income', 'expenses', and-'equity'.--   Account names may contain single spaces, eg: 'assets:accounts-receivable'.  Because of this, they must always be followed by *two or-more spaces* (or newline).--   Account names can be aliased.---File: hledger_journal.info,  Node: Amounts,  Next: Virtual Postings,  Prev: Account names,  Up: FILE FORMAT--1.7 Amounts-===========--After the account name, there is usually an amount.  Important: between-account name and amount, there must be *two or more spaces*.--   Amounts consist of a number and (usually) a currency symbol or-commodity name.  Some examples:--   '2.00001'-'$1'-'4000 AAPL'-'3 "green apples"'-'-$1,000,000.00'-'INR 9,99,99,999.00'-'EUR -2.000.000,00'-'1 999 999.9455'-'EUR 1E3'-'1000E-6s'--   As you can see, the amount format is somewhat flexible:--   * amounts are a number (the "quantity") and optionally a currency-     symbol/commodity name (the "commodity").-   * the commodity is a symbol, word, or phrase, on the left or right,-     with or without a separating space.  If the commodity contains-     numbers, spaces or non-word punctuation it must be enclosed in-     double quotes.-   * negative amounts with a commodity on the left can have the minus-     sign before or after it-   * digit groups (thousands, or any other grouping) can be separated by-     space or comma or period and should be used as separator between-     all groups-   * decimal part can be separated by comma or period and should be-     different from digit groups separator-   * scientific E-notation is allowed.  Be careful not to use a digit-     group separator character in scientific notation, as it's not-     supported and it might get mistaken for a decimal point.-     (Declaring the digit group separator character explicitly with a-     commodity directive will prevent this.)--   You can use any of these variations when recording data.  However,-there is some ambiguous way of representing numbers like '$1.000' and-'$1,000' both may mean either one thousand or one dollar.  By default-hledger will assume that this is sole delimiter is used only for-decimals.  On the other hand commodity format declared prior to that-line will help to resolve that ambiguity differently:--commodity $1,000.00--2017/12/25 New life of Scrooge-    expenses:gifts  $1,000-    assets--   Though journal may contain mixed styles to represent amount, when-hledger displays amounts, it will choose a consistent format for each-commodity.  (Except for price amounts, which are always formatted as-written).  The display format is chosen as follows:--   * if there is a commodity directive specifying the format, that is-     used-   * otherwise the format is inferred from the first posting amount in-     that commodity in the journal, and the precision (number of decimal-     places) will be the maximum from all posting amounts in that-     commmodity-   * or if there are no such amounts in the journal, a default format is-     used (like '$1000.00').--   Price amounts and amounts in 'D' directives usually don't affect-amount format inference, but in some situations they can do so-indirectly.  (Eg when D's default commodity is applied to a-commodity-less amount, or when an amountless posting is balanced using a-price's commodity, or when -V is used.)  If you find this causing-problems, set the desired format with a commodity directive.---File: hledger_journal.info,  Node: Virtual Postings,  Next: Balance Assertions,  Prev: Amounts,  Up: FILE FORMAT--1.8 Virtual Postings-====================--When you parenthesise the account name in a posting, we call that a-_virtual posting_, which means:--   * it is ignored when checking that the transaction is balanced-   * it is excluded from reports when the '--real/-R' flag is used, or-     the 'real:1' query.--   You could use this, eg, to set an account's opening balance without-needing to use the 'equity:opening balances' account:--1/1 special unbalanced posting to set initial balance-  (assets:checking)   $1000--   When the account name is bracketed, we call it a _balanced virtual-posting_.  This is like an ordinary virtual posting except the balanced-virtual postings in a transaction must balance to 0, like the real-postings (but separately from them).  Balanced virtual postings are also-excluded by '--real/-R' or 'real:1'.--1/1 buy food with cash, and update some budget-tracking subaccounts elsewhere-  expenses:food                   $10-  assets:cash                    $-10-  [assets:checking:available]     $10-  [assets:checking:budget:food]  $-10--   Virtual postings have some legitimate uses, but those are few.  You-can usually find an equivalent journal entry using real postings, which-is more correct and provides better error checking.---File: hledger_journal.info,  Node: Balance Assertions,  Next: Balance Assignments,  Prev: Virtual Postings,  Up: FILE FORMAT--1.9 Balance Assertions-======================--hledger supports Ledger-style balance assertions in journal files.-These look like, for example, '= EXPECTEDBALANCE' following a posting's-amount.  Eg here we assert the expected dollar balance in accounts a and-b after each posting:--2013/1/1-  a   $1  =$1-  b       =$-1--2013/1/2-  a   $1  =$2-  b  $-1  =$-2--   After reading a journal file, hledger will check all balance-assertions and report an error if any of them fail.  Balance assertions-can protect you from, eg, inadvertently disrupting reconciled balances-while cleaning up old entries.  You can disable them temporarily with-the '-I/--ignore-assertions' flag, which can be useful for-troubleshooting or for reading Ledger files.-* Menu:--* Assertions and ordering::-* Assertions and included files::-* Assertions and multiple -f options::-* Assertions and commodities::-* Assertions and prices::-* Assertions and subaccounts::-* Assertions and virtual postings::-* Assertions and precision::---File: hledger_journal.info,  Node: Assertions and ordering,  Next: Assertions and included files,  Up: Balance Assertions--1.9.1 Assertions and ordering--------------------------------hledger sorts an account's postings and assertions first by date and-then (for postings on the same day) by parse order.  Note this is-different from Ledger, which sorts assertions only by parse order.-(Also, Ledger assertions do not see the accumulated effect of repeated-postings to the same account within a transaction.)--   So, hledger balance assertions keep working if you reorder-differently-dated transactions within the journal.  But if you reorder-same-dated transactions or postings, assertions might break and require-updating.  This order dependence does bring an advantage: precise-control over the order of postings and assertions within a day, so you-can assert intra-day balances.---File: hledger_journal.info,  Node: Assertions and included files,  Next: Assertions and multiple -f options,  Prev: Assertions and ordering,  Up: Balance Assertions--1.9.2 Assertions and included files--------------------------------------With included files, things are a little more complicated.  Including-preserves the ordering of postings and assertions.  If you have multiple-postings to an account on the same day, split across different files,-and you also want to assert the account's balance on the same day,-you'll have to put the assertion in the right file.---File: hledger_journal.info,  Node: Assertions and multiple -f options,  Next: Assertions and commodities,  Prev: Assertions and included files,  Up: Balance Assertions--1.9.3 Assertions and multiple -f options-------------------------------------------Balance assertions don't work well across files specified with multiple--f options.  Use include or concatenate the files instead.---File: hledger_journal.info,  Node: Assertions and commodities,  Next: Assertions and prices,  Prev: Assertions and multiple -f options,  Up: Balance Assertions--1.9.4 Assertions and commodities-----------------------------------The asserted balance must be a simple single-commodity amount, and in-fact the assertion checks only this commodity's balance within the-(possibly multi-commodity) account balance.-This is how assertions work in Ledger also.  We could call this a-"partial" balance assertion.--   To assert the balance of more than one commodity in an account, you-can write multiple postings, each asserting one commodity's balance.--   You can make a stronger "total" balance assertion by writing a double-equals sign ('== EXPECTEDBALANCE').  This asserts that there are no-other unasserted commodities in the account (or, that their balance is-0).--2013/1/1-  a   $1-  a    1€-  b  $-1-  c   -1€--2013/1/2  ; These assertions succeed-  a    0  =  $1-  a    0  =   1€-  b    0 == $-1-  c    0 ==  -1€--2013/1/3  ; This assertion fails as 'a' also contains 1€-  a    0 ==  $1--   It's not yet possible to make a complete assertion about a balance-that has multiple commodities.  One workaround is to isolate each-commodity into its own subaccount:--2013/1/1-  a:usd   $1-  a:euro   1€-  b--2013/1/2-  a        0 ==  0-  a:usd    0 == $1-  a:euro   0 ==  1€---File: hledger_journal.info,  Node: Assertions and prices,  Next: Assertions and subaccounts,  Prev: Assertions and commodities,  Up: Balance Assertions--1.9.5 Assertions and prices------------------------------Balance assertions ignore transaction prices, and should normally be-written without one:--2019/1/1-  (a)     $1 @ €1 = $1--   We do allow prices to be written there, however, and print shows-them, even though they don't affect whether the assertion passes or-fails.  This is for backward compatibility (hledger's close command used-to generate balance assertions with prices), and because balance-_assignments_ do use them (see below).---File: hledger_journal.info,  Node: Assertions and subaccounts,  Next: Assertions and virtual postings,  Prev: Assertions and prices,  Up: Balance Assertions--1.9.6 Assertions and subaccounts-----------------------------------The balance assertions above ('=' and '==') do not count the balance-from subaccounts; they check the account's exclusive balance only.  You-can assert the balance including subaccounts by writing '=*' or '==*',-eg:--2019/1/1-  equity:opening balances-  checking:a       5-  checking:b       5-  checking         1  ==* 11---File: hledger_journal.info,  Node: Assertions and virtual postings,  Next: Assertions and precision,  Prev: Assertions and subaccounts,  Up: Balance Assertions--1.9.7 Assertions and virtual postings----------------------------------------Balance assertions are checked against all postings, both real and-virtual.  They are not affected by the '--real/-R' flag or 'real:'-query.---File: hledger_journal.info,  Node: Assertions and precision,  Prev: Assertions and virtual postings,  Up: Balance Assertions--1.9.8 Assertions and precision---------------------------------Balance assertions compare the exactly calculated amounts, which are not-always what is shown by reports.  Eg a commodity directive may limit the-display precision, but this will not affect balance assertions.  Balance-assertion failure messages show exact amounts.---File: hledger_journal.info,  Node: Balance Assignments,  Next: Transaction prices,  Prev: Balance Assertions,  Up: FILE FORMAT--1.10 Balance Assignments-========================--Ledger-style balance assignments are also supported.  These are like-balance assertions, but with no posting amount on the left side of the-equals sign; instead it is calculated automatically so as to satisfy the-assertion.  This can be a convenience during data entry, eg when setting-opening balances:--; starting a new journal, set asset account balances -2016/1/1 opening balances-  assets:checking            = $409.32-  assets:savings             = $735.24-  assets:cash                 = $42-  equity:opening balances--   or when adjusting a balance to reality:--; no cash left; update balance, record any untracked spending as a generic expense-2016/1/15-  assets:cash    = $0-  expenses:misc--   The calculated amount depends on the account's balance in the-commodity at that point (which depends on the previously-dated postings-of the commodity to that account since the last balance assertion or-assignment).  Note that using balance assignments makes your journal a-little less explicit; to know the exact amount posted, you have to run-hledger or do the calculations yourself, instead of just reading it.-* Menu:--* Balance assignments and prices::---File: hledger_journal.info,  Node: Balance assignments and prices,  Up: Balance Assignments--1.10.1 Balance assignments and prices----------------------------------------A transaction price in a balance assignment will cause the calculated-amount to have that price attached:--2019/1/1-  (a)             = $1 @ €2--$ hledger print --explicit-2019/01/01-    (a)         $1 @ €2 = $1 @ €2---File: hledger_journal.info,  Node: Transaction prices,  Next: Comments,  Prev: Balance Assignments,  Up: FILE FORMAT--1.11 Transaction prices-=======================--Within a transaction, you can note an amount's price in another-commodity.  This can be used to document the cost (in a purchase) or-selling price (in a sale).  For example, transaction prices are useful-to record purchases of a foreign currency.  Note transaction prices are-fixed at the time of the transaction, and do not change over time.  See-also market prices, which represent prevailing exchange rates on a-certain date.--   There are several ways to record a transaction price:--  1. Write the price per unit, as '@ UNITPRICE' after the amount:--     2009/1/1-       assets:euros     €100 @ $1.35  ; one hundred euros purchased at $1.35 each-       assets:dollars                 ; balancing amount is -$135.00--  2. Write the total price, as '@@ TOTALPRICE' after the amount:--     2009/1/1-       assets:euros     €100 @@ $135  ; one hundred euros purchased at $135 for the lot-       assets:dollars--  3. Specify amounts for all postings, using exactly two commodities,-     and let hledger infer the price that balances the transaction:--     2009/1/1-       assets:euros     €100          ; one hundred euros purchased-       assets:dollars  $-135          ; for $135--   (Ledger users: Ledger uses a different syntax for fixed prices,-'{=UNITPRICE}', which hledger currently ignores).--   Use the '-B/--cost' flag to convert amounts to their transaction-price's commodity, if any.  (mnemonic: "B" is from "cost Basis", as in-Ledger).  Eg here is how -B affects the balance report for the example-above:--$ hledger bal -N --flat-               $-135  assets:dollars-                €100  assets:euros-$ hledger bal -N --flat -B-               $-135  assets:dollars-                $135  assets:euros    # <- the euros' cost--   Note -B is sensitive to the order of postings when a transaction-price is inferred: the inferred price will be in the commodity of the-last amount.  So if example 3's postings are reversed, while the-transaction is equivalent, -B shows something different:--2009/1/1-  assets:dollars  $-135               ; 135 dollars sold-  assets:euros     €100               ; for 100 euros--$ hledger bal -N --flat -B-               €-100  assets:dollars  # <- the dollars' selling price-                €100  assets:euros---File: hledger_journal.info,  Node: Comments,  Next: Tags,  Prev: Transaction prices,  Up: FILE FORMAT--1.12 Comments-=============--Lines in the journal beginning with a semicolon (';') or hash ('#') or-star ('*') are comments, and will be ignored.  (Star comments cause-org-mode nodes to be ignored, allowing emacs users to fold and navigate-their journals with org-mode or orgstruct-mode.)--   You can attach comments to a transaction by writing them after the-description and/or indented on the following lines (before the-postings).  Similarly, you can attach comments to an individual posting-by writing them after the amount and/or indented on the following lines.-Transaction and posting comments must begin with a semicolon (';').--   Some examples:--# a file comment--; also a file comment--comment-This is a multiline file comment,-which continues until a line-where the "end comment" string-appears on its own (or end of file).-end comment--2012/5/14 something  ; a transaction comment-    ; the transaction comment, continued-    posting1  1  ; a comment for posting 1-    posting2-    ; a comment for posting 2-    ; another comment line for posting 2-; a file comment (because not indented)--   You can also comment larger regions of a file using 'comment' and-'end comment' directives.---File: hledger_journal.info,  Node: Tags,  Next: Directives,  Prev: Comments,  Up: FILE FORMAT--1.13 Tags-=========--Tags are a way to add extra labels or labelled data to postings and-transactions, which you can then search or pivot on.--   A simple tag is a word (which may contain hyphens) followed by a full-colon, written inside a transaction or posting comment line:--2017/1/16 bought groceries    ; sometag:--   Tags can have a value, which is the text after the colon, up to the-next comma or end of line, with leading/trailing whitespace removed:--    expenses:food    $10   ; a-posting-tag: the tag value--   Note this means hledger's tag values can not contain commas or-newlines.  Ending at commas means you can write multiple short tags on-one line, comma separated:--    assets:checking       ; a comment containing tag1:, tag2: some value ...--   Here,--   * "'a comment containing'" is just comment text, not a tag-   * "'tag1'" is a tag with no value-   * "'tag2'" is another tag, whose value is "'some value ...'"--   Tags in a transaction comment affect the transaction and all of its-postings, while tags in a posting comment affect only that posting.  For-example, the following transaction has three tags ('A', 'TAG2',-'third-tag') and the posting has four (those plus 'posting-tag'):--1/1 a transaction  ; A:, TAG2:-    ; third-tag: a third transaction tag, <- with a value-    (a)  $1  ; posting-tag:--   Tags are like Ledger's metadata feature, except hledger's tag values-are simple strings.---File: hledger_journal.info,  Node: Directives,  Next: Periodic transactions,  Prev: Tags,  Up: FILE FORMAT--1.14 Directives-===============--A directive is a line in the journal beginning with a special keyword,-that influences how the journal is processed.  hledger's directives are-based on a subset of Ledger's, but there are many differences (and also-some differences between hledger versions).--   Directives' behaviour and interactions can get a little bit complex,-so here is a table summarising the directives and their effects, with-links to more detailed docs.--directiveend       subdirectivespurpose                  can affect (as of-         directive                                       2018/06)-------------------------------------------------------------------------------'account'          any     document account names,       all entries in-                   text    declare account types &       all files, before-                           display order                 or after-'alias'  'end              rewrite account names         following-         aliases'                                        inline/included-                                                         entries until end-                                                         of current file-                                                         or end directive-'apply   'end              prepend a common parent to    following-account' apply             account names                 inline/included-         account'                                        entries until end-                                                         of current file-                                                         or end directive-'comment''end              ignore part of journal        following-         comment'                                        inline/included-                                                         entries until end-                                                         of current file-                                                         or end directive-'commodity'        'format'declare a commodity and its   number notation:-                           number notation & display     following entries-                           style                         in that commodity-                                                         in all files;-                                                         display style:-                                                         amounts of that-                                                         commodity in-                                                         reports-'D'                        declare a commodity, number   commodity: all-                           notation & display style      commodityless-                           for commodityless amounts     entries in all-                                                         files; number-                                                         notation:-                                                         following-                                                         commodityless-                                                         entries and-                                                         entries in that-                                                         commodity in all-                                                         files; display-                                                         style: amounts of-                                                         that commodity in-                                                         reports-'include'                  include entries/directives    what the included-                           from another file             directives affect-'P'                        declare a market price for    amounts of that-                           a commodity                   commodity in-                                                         reports, when -V-                                                         is used-'Y'                        declare a year for yearless   following-                           dates                         inline/included-                                                         entries until end-                                                         of current file--   And some definitions:--subdirectiveoptional indented directive line immediately following a-          parent directive-number    how to interpret numbers when parsing journal entries (the-notation  identity of the decimal separator character).  (Currently-          each commodity can have its own notation, even in the same-          file.)-display   how to display amounts of a commodity in reports (symbol side-style     and spacing, digit groups, decimal separator, decimal places)-directive which entries and (when there are multiple files) which files-scope     are affected by a directive--   As you can see, directives vary in which journal entries and files-they affect, and whether they are focussed on input (parsing) or output-(reports).  Some directives have multiple effects.--   If you have a journal made up of multiple files, or pass multiple -f-options on the command line, note that directives which affect input-typically last only until the end of their defining file.  This provides-more simplicity and predictability, eg reports are not changed by-writing file options in a different order.  It can be surprising at-times though.-* Menu:--* Comment blocks::-* Including other files::-* Default year::-* Declaring commodities::-* Default commodity::-* Market prices::-* Declaring accounts::-* Rewriting accounts::-* Default parent account::---File: hledger_journal.info,  Node: Comment blocks,  Next: Including other files,  Up: Directives--1.14.1 Comment blocks------------------------A line containing just 'comment' starts a commented region of the file,-and a line containing just 'end comment' (or the end of the current-file) ends it.  See also comments.---File: hledger_journal.info,  Node: Including other files,  Next: Default year,  Prev: Comment blocks,  Up: Directives--1.14.2 Including other files-------------------------------You can pull in the content of additional files by writing an include-directive, like this:--include path/to/file.journal--   If the path does not begin with a slash, it is relative to the-current file.  The include file path may contain common glob patterns-(e.g.  '*').--   The 'include' directive can only be used in journal files.  It can-include journal, timeclock or timedot files, but not CSV files.---File: hledger_journal.info,  Node: Default year,  Next: Declaring commodities,  Prev: Including other files,  Up: Directives--1.14.3 Default year----------------------You can set a default year to be used for subsequent dates which don't-specify a year.  This is a line beginning with 'Y' followed by the year.-Eg:--Y2009      ; set default year to 2009--12/15      ; equivalent to 2009/12/15-  expenses  1-  assets--Y2010      ; change default year to 2010--2009/1/30  ; specifies the year, not affected-  expenses  1-  assets--1/31       ; equivalent to 2010/1/31-  expenses  1-  assets---File: hledger_journal.info,  Node: Declaring commodities,  Next: Default commodity,  Prev: Default year,  Up: Directives--1.14.4 Declaring commodities-------------------------------The 'commodity' directive declares commodities which may be used in the-journal (though currently we do not enforce this).  It may be written on-a single line, like this:--; commodity EXAMPLEAMOUNT--; display AAAA amounts with the symbol on the right, space-separated,-; using period as decimal point, with four decimal places, and-; separating thousands with comma.-commodity 1,000.0000 AAAA--   or on multiple lines, using the "format" subdirective.  In this case-the commodity symbol appears twice and should be the same in both-places:--; commodity SYMBOL-;   format EXAMPLEAMOUNT--; display indian rupees with currency name on the left,-; thousands, lakhs and crores comma-separated,-; period as decimal point, and two decimal places.-commodity INR-  format INR 9,99,99,999.00--   Commodity directives have a second purpose: they define the standard-display format for amounts in the commodity.  Normally the display-format is inferred from journal entries, but this can be unpredictable;-declaring it with a commodity directive overrides this and removes-ambiguity.  Towards this end, amounts in commodity directives must-always be written with a decimal point (a period or comma, followed by 0-or more decimal digits).---File: hledger_journal.info,  Node: Default commodity,  Next: Market prices,  Prev: Declaring commodities,  Up: Directives--1.14.5 Default commodity---------------------------The 'D' directive sets a default commodity (and display format), to be-used for amounts without a commodity symbol (ie, plain numbers).  (Note-this differs from Ledger's default commodity directive.)  The commodity-and display format will be applied to all subsequent commodity-less-amounts, or until the next 'D' directive.--# commodity-less amounts should be treated as dollars-# (and displayed with symbol on the left, thousands separators and two decimal places)-D $1,000.00--1/1-  a     5    ; <- commodity-less amount, becomes $1-  b--   As with the 'commodity' directive, the amount must always be written-with a decimal point.---File: hledger_journal.info,  Node: Market prices,  Next: Declaring accounts,  Prev: Default commodity,  Up: Directives--1.14.6 Market prices-----------------------The 'P' directive declares a market price, which is an exchange rate-between two commodities on a certain date.  (In Ledger, they are called-"historical prices".)  These are often obtained from a stock exchange,-cryptocurrency exchange, or the foreign exchange market.--   Here is the format:--P DATE COMMODITYA COMMODITYBAMOUNT--   * DATE is a simple date-   * COMMODITYA is the symbol of the commodity being priced-   * COMMODITYBAMOUNT is an amount (symbol and quantity) in a second-     commodity, giving the price in commodity B of one unit of commodity-     A.--   These two market price directives say that one euro was worth 1.35 US-dollars during 2009, and $1.40 from 2010 onward:--P 2009/1/1 € $1.35-P 2010/1/1 € $1.40--   The '-V/--value' flag can be used to convert reported amounts to-another commodity using these prices.---File: hledger_journal.info,  Node: Declaring accounts,  Next: Rewriting accounts,  Prev: Market prices,  Up: Directives--1.14.7 Declaring accounts----------------------------'account' directives can be used to pre-declare accounts.  Though not-required, they can provide several benefits:--   * They can document your intended chart of accounts, providing a-     reference.-   * They can store extra information about accounts (account numbers,-     notes, etc.)-   * They can help hledger know your accounts' types (asset, liability,-     equity, revenue, expense), useful for reports like balancesheet and-     incomestatement.-   * They control account display order in reports, allowing-     non-alphabetic sorting (eg Revenues to appear above Expenses).-   * They help with account name completion in the add command,-     hledger-iadd, hledger-web, ledger-mode etc.--   The simplest form is just the word 'account' followed by a-hledger-style account name, eg:--account assets:bank:checking--* Menu:--* Account comments::-* Account subdirectives::-* Account types::-* Account display order::---File: hledger_journal.info,  Node: Account comments,  Next: Account subdirectives,  Up: Declaring accounts--1.14.7.1 Account comments-.........................--Comments, beginning with a semicolon, optionally including tags, can be-written after the account name, and/or on following lines.  Eg:--account assets:bank:checking  ; a comment-  ; another comment-  ; acctno:12345, a tag--   Tip: comments on the same line require hledger 1.12+.  If you need-your journal to be compatible with older hledger versions, write-comments on the next line instead.---File: hledger_journal.info,  Node: Account subdirectives,  Next: Account types,  Prev: Account comments,  Up: Declaring accounts--1.14.7.2 Account subdirectives-..............................--We also allow (and ignore) Ledger-style indented subdirectives, just for-compatibility.:--account assets:bank:checking-  format blah blah  ; <- subdirective, ignored--   Here is the full syntax of account directives:--account ACCTNAME  [ACCTTYPE] [;COMMENT]-  [;COMMENTS]-  [LEDGER-STYLE SUBDIRECTIVES, IGNORED]---File: hledger_journal.info,  Node: Account types,  Next: Account display order,  Prev: Account subdirectives,  Up: Declaring accounts--1.14.7.3 Account types-......................--hledger recognises five types (or classes) of account: Asset, Liability,-Equity, Revenue, Expense.  This is used by a few accounting-aware-reports such as balancesheet, incomestatement and cashflow.-Auto-detected account types If you name your top-level accounts with-some variation of 'assets', 'liabilities'/'debts', 'equity',-'revenues'/'income', or 'expenses', their types are detected-automatically.  Account types declared with tags More generally, you can-declare an account's type with an account directive, by writing a-'type:' tag in a comment, followed by one of the words 'Asset',-'Liability', 'Equity', 'Revenue', 'Expense', or one of the letters-'ALERX' (case insensitive):--account assets       ; type:Asset-account liabilities  ; type:Liability-account equity       ; type:Equity-account revenues     ; type:Revenue-account expenses     ; type:Expenses--   Account types declared with account type codes Or, you can write one-of those letters separated from the account name by two or more spaces,-but this should probably be considered deprecated as of hledger 1.13:--account assets       A-account liabilities  L-account equity       E-account revenues     R-account expenses     X--   Overriding auto-detected types If you ever override the types of-those auto-detected english account names mentioned above, you might-need to help the reports a bit.  Eg:--; make "liabilities" not have the liability type - who knows why-account liabilities   ; type:E--; we need to ensure some other account has the liability type, -; otherwise balancesheet would still show "liabilities" under Liabilities -account -             ; type:L---File: hledger_journal.info,  Node: Account display order,  Prev: Account types,  Up: Declaring accounts--1.14.7.4 Account display order-..............................--Account directives also set the order in which accounts are displayed,-eg in reports, the hledger-ui accounts screen, and the hledger-web-sidebar.  By default accounts are listed in alphabetical order.  But if-you have these account directives in the journal:--account assets-account liabilities-account equity-account revenues-account expenses--   you'll see those accounts displayed in declaration order, not-alphabetically:--$ hledger accounts -1-assets-liabilities-equity-revenues-expenses--   Undeclared accounts, if any, are displayed last, in alphabetical-order.--   Note that sorting is done at each level of the account tree (within-each group of sibling accounts under the same parent).  And currently,-this directive:--account other:zoo--   would influence the position of 'zoo' among 'other''s subaccounts,-but not the position of 'other' among the top-level accounts.  This-means: - you will sometimes declare parent accounts (eg 'account other'-above) that you don't intend to post to, just to customize their display-order - sibling accounts stay together (you couldn't display 'x:y' in-between 'a:b' and 'a:c').---File: hledger_journal.info,  Node: Rewriting accounts,  Next: Default parent account,  Prev: Declaring accounts,  Up: Directives--1.14.8 Rewriting accounts----------------------------You can define account alias rules which rewrite your account names, or-parts of them, before generating reports.  This can be useful for:--   * expanding shorthand account names to their full form, allowing-     easier data entry and a less verbose journal-   * adapting old journals to your current chart of accounts-   * experimenting with new account organisations, like a new hierarchy-     or combining two accounts into one-   * customising reports--   Account aliases also rewrite account names in account directives.-They do not affect account names being entered via hledger add or-hledger-web.--   See also Cookbook: Rewrite account names.-* Menu:--* Basic aliases::-* Regex aliases::-* Multiple aliases::-* end aliases::---File: hledger_journal.info,  Node: Basic aliases,  Next: Regex aliases,  Up: Rewriting accounts--1.14.8.1 Basic aliases-......................--To set an account alias, use the 'alias' directive in your journal file.-This affects all subsequent journal entries in the current file or its-included files.  The spaces around the = are optional:--alias OLD = NEW--   Or, you can use the '--alias 'OLD=NEW'' option on the command line.-This affects all entries.  It's useful for trying out aliases-interactively.--   OLD and NEW are case sensitive full account names.  hledger will-replace any occurrence of the old account name with the new one.-Subaccounts are also affected.  Eg:--alias checking = assets:bank:wells fargo:checking-# rewrites "checking" to "assets:bank:wells fargo:checking", or "checking:a" to "assets:bank:wells fargo:checking:a"---File: hledger_journal.info,  Node: Regex aliases,  Next: Multiple aliases,  Prev: Basic aliases,  Up: Rewriting accounts--1.14.8.2 Regex aliases-......................--There is also a more powerful variant that uses a regular expression,-indicated by the forward slashes:--alias /REGEX/ = REPLACEMENT--   or '--alias '/REGEX/=REPLACEMENT''.--   REGEX is a case-insensitive regular expression.  Anywhere it matches-inside an account name, the matched part will be replaced by-REPLACEMENT. If REGEX contains parenthesised match groups, these can be-referenced by the usual numeric backreferences in REPLACEMENT. Eg:--alias /^(.+):bank:([^:]+)(.*)/ = \1:\2 \3-# rewrites "assets:bank:wells fargo:checking" to  "assets:wells fargo checking"--   Also note that REPLACEMENT continues to the end of line (or on-command line, to end of option argument), so it can contain trailing-whitespace.---File: hledger_journal.info,  Node: Multiple aliases,  Next: end aliases,  Prev: Regex aliases,  Up: Rewriting accounts--1.14.8.3 Multiple aliases-.........................--You can define as many aliases as you like using directives or-command-line options.  Aliases are recursive - each alias sees the-result of applying previous ones.  (This is different from Ledger, where-aliases are non-recursive by default).  Aliases are applied in the-following order:--  1. alias directives, most recently seen first (recent directives take-     precedence over earlier ones; directives not yet seen are ignored)-  2. alias options, in the order they appear on the command line---File: hledger_journal.info,  Node: end aliases,  Prev: Multiple aliases,  Up: Rewriting accounts--1.14.8.4 'end aliases'-......................--You can clear (forget) all currently defined aliases with the 'end-aliases' directive:--end aliases---File: hledger_journal.info,  Node: Default parent account,  Prev: Rewriting accounts,  Up: Directives--1.14.9 Default parent account--------------------------------You can specify a parent account which will be prepended to all accounts-within a section of the journal.  Use the 'apply account' and 'end apply-account' directives like so:--apply account home--2010/1/1-    food    $10-    cash--end apply account--   which is equivalent to:--2010/01/01-    home:food           $10-    home:cash          $-10--   If 'end apply account' is omitted, the effect lasts to the end of the-file.  Included files are also affected, eg:--apply account business-include biz.journal-end apply account-apply account personal-include personal.journal--   Prior to hledger 1.0, legacy 'account' and 'end' spellings were also-supported.--   A default parent account also affects account directives.  It does-not affect account names being entered via hledger add or hledger-web.-If account aliases are present, they are applied after the default-parent account.---File: hledger_journal.info,  Node: Periodic transactions,  Next: Transaction modifiers,  Prev: Directives,  Up: FILE FORMAT--1.15 Periodic transactions-==========================--Periodic transaction rules describe transactions that recur.  They allow-you to generate future transactions for forecasting, without having to-write them out explicitly in the journal (with '--forecast').  Secondly,-they also can be used to define budget goals (with '--budget').--   A periodic transaction rule looks like a normal journal entry, with-the date replaced by a tilde ('~') followed by a period expression-(mnemonic: '~' looks like a recurring sine wave.):--~ monthly-    expenses:rent          $2000-    assets:bank:checking--   There is an additional constraint on the period expression: the start-date must fall on a natural boundary of the interval.  Eg 'monthly from-2018/1/1' is valid, but 'monthly from 2018/1/15' is not.--   Partial or relative dates (M/D, D, tomorrow, last week) in the period-expression can work (useful or not).  They will be relative to today's-date, unless a Y default year directive is in effect, in which case they-will be relative to Y/1/1.-* Menu:--* Two spaces after the period expression::-* Forecasting with periodic transactions::-* Budgeting with periodic transactions::---File: hledger_journal.info,  Node: Two spaces after the period expression,  Next: Forecasting with periodic transactions,  Up: Periodic transactions--1.15.1 Two spaces after the period expression------------------------------------------------If the period expression is followed by a transaction description, these-must be separated by *two or more spaces*.  This helps hledger know-where the period expression ends, so that descriptions can not-accidentally alter their meaning, as in this example:--; 2 or more spaces needed here, so the period is not understood as "every 2 months in 2020"-;               ||-;               vv-~ every 2 months  in 2020, we will review-    assets:bank:checking   $1500-    income:acme inc---File: hledger_journal.info,  Node: Forecasting with periodic transactions,  Next: Budgeting with periodic transactions,  Prev: Two spaces after the period expression,  Up: Periodic transactions--1.15.2 Forecasting with periodic transactions------------------------------------------------With the '--forecast' flag, each periodic transaction rule generates-future transactions recurring at the specified interval.  These are not-saved in the journal, but appear in all reports.  They will look like-normal transactions, but with an extra tag named 'recur', whose value is-the generating period expression.--   Forecast transactions start on the first occurrence, and end on the-last occurrence, of their interval within the forecast period.  The-forecast period:--   * begins on the later of-        * the report start date if specified with -b/-p/date:-        * the day after the latest normal (non-periodic) transaction in-          the journal, or today if there are no normal transactions.--   * ends on the report end date if specified with -e/-p/date:, or 180-     days from today.--   where "today" means the current date at report time.  The "later of"-rule ensures that forecast transactions do not overlap normal-transactions in time; they will begin only after normal transactions-end.--   Forecasting can be useful for estimating balances into the future,-and experimenting with different scenarios.  Note the start date logic-means that forecasted transactions are automatically replaced by normal-transactions as you add those.--   Forecasting can also help with data entry: describe most of your-transactions with periodic rules, and every so often copy the output of-'print --forecast' to the journal.--   You can generate one-time transactions too: just write a period-expression specifying a date with no report interval.  (You could also-write a normal transaction with a future date, but remember this-disables forecast transactions on previous dates.)---File: hledger_journal.info,  Node: Budgeting with periodic transactions,  Prev: Forecasting with periodic transactions,  Up: Periodic transactions--1.15.3 Budgeting with periodic transactions----------------------------------------------With the '--budget' flag, currently supported by the balance command,-each periodic transaction rule declares recurring budget goals for the-specified accounts.  Eg the first example above declares a goal of-spending $2000 on rent (and also, a goal of depositing $2000 into-checking) every month.  Goals and actual performance can then be-compared in budget reports.--   For more details, see: balance: Budget report and Cookbook: Budgeting-and Forecasting.---File: hledger_journal.info,  Node: Transaction modifiers,  Prev: Periodic transactions,  Up: FILE FORMAT--1.16 Transaction modifiers-==========================--Transaction modifier rules describe changes that should be applied-automatically to certain transactions.  They can be enabled by using the-'--auto' flag.  Currently, just one kind of change is possible: adding-extra postings.  These rule-generated postings are known as "automated-postings" or "auto postings".--   A transaction modifier rule looks quite like a normal transaction,-except the first line is an equals sign followed by a query that matches-certain postings (mnemonic: '=' suggests matching).  And each "posting"-is actually a posting-generating rule:--= QUERY-    ACCT  AMT-    ACCT  [AMT]-    ...--   These posting rules look like normal postings, except the amount can-be:--   * a normal amount with a commodity symbol, eg '$2'.  This will be-     used as-is.-   * a number, eg '2'.  The commodity symbol (if any) from the matched-     posting will be added to this.-   * a numeric multiplier, eg '*2' (a star followed by a number N). The-     matched posting's amount (and total price, if any) will be-     multiplied by N.-   * a multiplier with a commodity symbol, eg '*$2' (a star, number N,-     and symbol S). The matched posting's amount will be multiplied by-     N, and its commodity symbol will be replaced with S.--   Some examples:--; every time I buy food, schedule a dollar donation-= expenses:food-    (liabilities:charity)   $-1--; when I buy a gift, also deduct that amount from a budget envelope subaccount-= expenses:gifts-    assets:checking:gifts  *-1-    assets:checking         *1--2017/12/1-  expenses:food    $10-  assets:checking--2017/12/14-  expenses:gifts   $20-  assets:checking--$ hledger print --auto-2017/12/01-    expenses:food              $10-    assets:checking-    (liabilities:charity)      $-1--2017/12/14-    expenses:gifts             $20-    assets:checking-    assets:checking:gifts     -$20-    assets:checking            $20--* Menu:--* Auto postings and transaction balancing / inferred amounts / balance assertions::---File: hledger_journal.info,  Node: Auto postings and transaction balancing / inferred amounts / balance assertions,  Up: Transaction modifiers--1.16.1 Auto postings and transaction balancing / inferred amounts /----------------------------------------------------------------------balance assertions Currently, transaction modifiers are applied / auto-postings are added:--   * after missing amounts are inferred, and transactions are checked-     for balancedness,-   * but before balance assertions are checked.--   Note this means that journal entries must be balanced both before and-after auto postings are added.  This changed in hledger 1.12+; see #893-for background.---File: hledger_journal.info,  Node: EDITOR SUPPORT,  Prev: FILE FORMAT,  Up: Top--2 EDITOR SUPPORT-****************--Helper modes exist for popular text editors, which make working with-journal files easier.  They add colour, formatting, tab completion, and-helpful commands, and are quite recommended if you edit your journal-with a text editor.  They include ledger-mode or hledger-mode for Emacs,-vim-ledger for Vim, hledger-vscode for Visual Studio Code, and others.-See the [[Cookbook]] at hledger.org for the latest information.---Tag Table:-Node: Top76-Node: FILE FORMAT2372-Ref: #file-format2496-Node: Transactions2783-Ref: #transactions2904-Node: Postings3588-Ref: #postings3715-Node: Dates4710-Ref: #dates4825-Node: Simple dates4890-Ref: #simple-dates5016-Node: Secondary dates5382-Ref: #secondary-dates5536-Node: Posting dates7099-Ref: #posting-dates7228-Node: Status8602-Ref: #status8722-Node: Description10430-Ref: #description10568-Node: Payee and note10887-Ref: #payee-and-note11001-Node: Account names11243-Ref: #account-names11386-Node: Amounts11873-Ref: #amounts12009-Node: Virtual Postings15026-Ref: #virtual-postings15185-Node: Balance Assertions16405-Ref: #balance-assertions16580-Node: Assertions and ordering17538-Ref: #assertions-and-ordering17724-Node: Assertions and included files18424-Ref: #assertions-and-included-files18665-Node: Assertions and multiple -f options18998-Ref: #assertions-and-multiple--f-options19252-Node: Assertions and commodities19384-Ref: #assertions-and-commodities19614-Node: Assertions and prices20770-Ref: #assertions-and-prices20982-Node: Assertions and subaccounts21422-Ref: #assertions-and-subaccounts21649-Node: Assertions and virtual postings21973-Ref: #assertions-and-virtual-postings22213-Node: Assertions and precision22355-Ref: #assertions-and-precision22546-Node: Balance Assignments22813-Ref: #balance-assignments22994-Node: Balance assignments and prices24158-Ref: #balance-assignments-and-prices24330-Node: Transaction prices24554-Ref: #transaction-prices24723-Node: Comments26991-Ref: #comments27125-Node: Tags28295-Ref: #tags28413-Node: Directives29815-Ref: #directives29958-Node: Comment blocks35565-Ref: #comment-blocks35710-Node: Including other files35886-Ref: #including-other-files36066-Node: Default year36474-Ref: #default-year36643-Node: Declaring commodities37066-Ref: #declaring-commodities37249-Node: Default commodity38476-Ref: #default-commodity38652-Node: Market prices39288-Ref: #market-prices39453-Node: Declaring accounts40294-Ref: #declaring-accounts40470-Node: Account comments41395-Ref: #account-comments41558-Node: Account subdirectives41953-Ref: #account-subdirectives42148-Node: Account types42461-Ref: #account-types42645-Node: Account display order44289-Ref: #account-display-order44459-Node: Rewriting accounts45588-Ref: #rewriting-accounts45773-Node: Basic aliases46507-Ref: #basic-aliases46653-Node: Regex aliases47357-Ref: #regex-aliases47528-Node: Multiple aliases48246-Ref: #multiple-aliases48421-Node: end aliases48919-Ref: #end-aliases49066-Node: Default parent account49167-Ref: #default-parent-account49333-Node: Periodic transactions50217-Ref: #periodic-transactions50399-Node: Two spaces after the period expression51524-Ref: #two-spaces-after-the-period-expression51769-Node: Forecasting with periodic transactions52254-Ref: #forecasting-with-periodic-transactions52544-Node: Budgeting with periodic transactions54231-Ref: #budgeting-with-periodic-transactions54470-Node: Transaction modifiers54929-Ref: #transaction-modifiers55092-Node: Auto postings and transaction balancing / inferred amounts / balance assertions57076-Ref: #auto-postings-and-transaction-balancing-inferred-amounts-balance-assertions57377-Node: EDITOR SUPPORT57755-Ref: #editor-support57873--End Tag Table
− hledger_journal.txt 
@@ -1,1304 +0,0 @@--hledger_journal(5)           hledger User Manuals           hledger_journal(5)----NAME-       Journal - hledger's default file format, representing a General Journal--DESCRIPTION-       hledger's usual data source is a plain  text  file  containing  journal-       entries  in  hledger  journal  format.  This file represents a standard-       accounting general journal.  I use file names ending in  .journal,  but-       that's not required.  The journal file contains a number of transaction-       entries, each describing a transfer of money (or any commodity) between-       two or more named accounts, in a simple format readable by both hledger-       and humans.--       hledger's journal format is a compatible subset,  mostly,  of  ledger's-       journal  format,  so  hledger  can  work with compatible ledger journal-       files as well.  It's safe, and encouraged,  to  run  both  hledger  and-       ledger on the same journal file, eg to validate the results you're get--       ting.--       You can use hledger without learning any more about this file; just use-       the  add  or web commands to create and update it.  Many users, though,-       also edit the  journal  file  directly  with  a  text  editor,  perhaps-       assisted by the helper modes for emacs or vim.--       Here's an example:--              ; A sample journal file. This is a comment.--              2008/01/01 income               ; <- transaction's first line starts in column 0, contains date and description-                  assets:bank:checking  $1    ; <- posting lines start with whitespace, each contains an account name-                  income:salary        $-1    ;    followed by at least two spaces and an amount--              2008/06/01 gift-                  assets:bank:checking  $1    ; <- at least two postings in a transaction-                  income:gifts         $-1    ; <- their amounts must balance to 0--              2008/06/02 save-                  assets:bank:saving    $1-                  assets:bank:checking        ; <- one amount may be omitted; here $-1 is inferred--              2008/06/03 eat & shop           ; <- description can be anything-                  expenses:food         $1-                  expenses:supplies     $1    ; <- this transaction debits two expense accounts-                  assets:cash                 ; <- $-2 inferred--              2008/10/01 take a loan-                  assets:bank:checking  $1-                  liabilities:debts    $-1--              2008/12/31 * pay off            ; <- an optional * or ! after the date means "cleared" (or anything you want)-                  liabilities:debts     $1-                  assets:bank:checking--FILE FORMAT-   Transactions-       Transactions  are  movements  of  some  quantity of commodities between-       named accounts.  Each transaction is represented  by  a  journal  entry-       beginning  with a simple date in column 0.  This can be followed by any-       of the following, separated by spaces:--       o (optional) a status character (empty, !, or *)--       o (optional) a transaction code (any short number or text, enclosed  in-         parentheses)--       o (optional) a transaction description (any remaining text until end of-         line or a semicolon)--       o (optional) a transaction comment  (any  remaining  text  following  a-         semicolon until end of line)--       Then  comes zero or more (but usually at least 2) indented lines repre--       senting...--   Postings-       A posting is an addition of some amount to, or removal of  some  amount-       from,  an account.  Each posting line begins with at least one space or-       tab (2 or 4 spaces is common), followed by:--       o (optional) a status character (empty, !, or *), followed by a space--       o (required) an account name (any text,  optionally  containing  single-         spaces, until end of line or a double space)--       o (optional) two or more spaces or tabs followed by an amount.--       Positive  amounts  are being added to the account, negative amounts are-       being removed.--       The amounts within a transaction must always sum up to zero.  As a con--       venience,  one  amount  may be left blank; it will be inferred so as to-       balance the transaction.--       Be sure to note the unusual two-space delimiter  between  account  name-       and  amount.  This makes it easy to write account names containing spa--       ces.  But if you accidentally leave only one space (or tab) before  the-       amount, the amount will be considered part of the account name.--   Dates-   Simple dates-       Within  a journal file, transaction dates use Y/M/D (or Y-M-D or Y.M.D)-       Leading zeros are optional.  The year may be omitted, in which case  it-       will  be  inferred  from  the  context  -  the current transaction, the-       default year set with a default year directive,  or  the  current  date-       when  the command is run.  Some examples: 2010/01/31, 1/31, 2010-01-31,-       2010.1.31.--   Secondary dates-       Real-life transactions sometimes involve more than one date  -  eg  the-       date you write a cheque, and the date it clears in your bank.  When you-       want to model this, eg for more  accurate  balances,  you  can  specify-       individual  posting dates, which I recommend.  Or, you can use the sec--       ondary dates (aka auxiliary/effective  dates)  feature,  supported  for-       compatibility with Ledger.--       A secondary date can be written after the primary date, separated by an-       equals sign.  The primary date, on the left, is used  by  default;  the-       secondary  date,  on the right, is used when the --date2 flag is speci--       fied (--aux-date or --effective also work).--       The meaning of secondary dates is up to you, but it's best to follow  a-       consistent  rule.   Eg  write  the bank's clearing date as primary, and-       when needed, the date the transaction was initiated as secondary.--       Here's an example.  Note that a secondary date will use the year of the-       primary date if unspecified.--              2010/2/23=2/19 movie ticket-                expenses:cinema                   $10-                assets:checking--              $ hledger register checking-              2010/02/23 movie ticket         assets:checking                $-10         $-10--              $ hledger register checking --date2-              2010/02/19 movie ticket         assets:checking                $-10         $-10--       Secondary  dates require some effort; you must use them consistently in-       your journal entries and remember whether to use or not use the --date2-       flag for your reports.  They are included in hledger for Ledger compat--       ibility, but posting dates are  a  more  powerful  and  less  confusing-       alternative.--   Posting dates-       You  can  give  individual  postings a different date from their parent-       transaction, by adding a posting comment containing a tag  (see  below)-       like date:DATE.  This is probably the best way to control posting dates-       precisely.  Eg in  this  example  the  expense  should  appear  in  May-       reports,  and the deduction from checking should be reported on 6/1 for-       easy bank reconciliation:--              2015/5/30-                  expenses:food     $10   ; food purchased on saturday 5/30-                  assets:checking         ; bank cleared it on monday, date:6/1--              $ hledger -f t.j register food-              2015/05/30                      expenses:food                  $10           $10--              $ hledger -f t.j register checking-              2015/06/01                      assets:checking               $-10          $-10--       DATE should be a simple date; if the year is not specified it will  use-       the  year  of  the  transaction's date.  You can set the secondary date-       similarly, with date2:DATE2.  The date: or  date2:  tags  must  have  a-       valid  simple  date  value  if they are present, eg a date: tag with no-       value is not allowed.--       Ledger's earlier, more compact bracketed date syntax is also supported:-       [DATE],  [DATE=DATE2]  or  [=DATE2].  hledger will attempt to parse any-       square-bracketed sequence of the 0123456789/-.= characters in this way.-       With  this  syntax, DATE infers its year from the transaction and DATE2-       infers its year from DATE.--   Status-       Transactions, or individual postings within a transaction, can  have  a-       status  mark,  which  is  a  single  character  before  the transaction-       description or posting account name, separated  from  it  by  a  space,-       indicating one of three statuses:---       mark     status-       -------------------                unmarked-       !        pending-       *        cleared--       When  reporting,  you  can  filter  by  status  with the -U/--unmarked,-       -P/--pending, and -C/--cleared flags; or  the  status:,  status:!,  and-       status:* queries; or the U, P, C keys in hledger-ui.--       Note,  in Ledger and in older versions of hledger, the "unmarked" state-       is called "uncleared".  As  of  hledger  1.3  we  have  renamed  it  to-       unmarked for clarity.--       To  replicate Ledger and old hledger's behaviour of also matching pend--       ing, combine -U and -P.--       Status marks are optional, but can be helpful eg for  reconciling  with-       real-world accounts.  Some editor modes provide highlighting and short--       cuts for working with status.  Eg in Emacs ledger-mode, you can  toggle-       transaction status with C-c C-e, or posting status with C-c C-c.--       What  "uncleared", "pending", and "cleared" actually mean is up to you.-       Here's one suggestion:---       status       meaning-       ---------------------------------------------------------------------------       uncleared    recorded but not yet reconciled; needs review-       pending      tentatively reconciled (if needed, eg during a big reconcil--                    iation)-       cleared      complete, reconciled as far as possible, and considered cor--                    rect--       With this scheme, you would use -PC to see the current balance at  your-       bank,  -U  to  see  things which will probably hit your bank soon (like-       uncashed checks), and no flags to see the most up-to-date state of your-       finances.--   Description-       A  transaction's description is the rest of the line following the date-       and status mark (or until a  comment  begins).   Sometimes  called  the-       "narration" in traditional bookkeeping, it can be used for whatever you-       wish, or left blank.  Transaction descriptions can be  queried,  unlike-       comments.--   Payee and note-       You  can  optionally  include  a | (pipe) character in a description to-       subdivide it into a payee/payer name on the left and  additional  notes-       on  the  right.   This may be worthwhile if you need to do more precise-       querying and pivoting by payee.--   Account names-       Account names typically have several parts separated by a  full  colon,-       from  which hledger derives a hierarchical chart of accounts.  They can-       be anything you like, but  in  finance  there  are  traditionally  five-       top-level  accounts: assets, liabilities, income, expenses, and equity.--       Account names may contain single  spaces,  eg:  assets:accounts receiv--       able.   Because  of  this,  they must always be followed by two or more-       spaces (or newline).--       Account names can be aliased.--   Amounts-       After the account name, there is usually an amount.  Important: between-       account name and amount, there must be two or more spaces.--       Amounts  consist of a number and (usually) a currency symbol or commod--       ity name.  Some examples:--       2.00001-       $1-       4000 AAPL-       3 "green apples"-       -$1,000,000.00-       INR 9,99,99,999.00-       EUR -2.000.000,00-       1 999 999.9455-       EUR 1E3-       1000E-6s--       As you can see, the amount format is somewhat flexible:--       o amounts are a number (the "quantity") and optionally a currency  sym--         bol/commodity name (the "commodity").--       o the  commodity  is  a  symbol, word, or phrase, on the left or right,-         with or without a separating space.  If the commodity  contains  num--         bers,  spaces  or  non-word punctuation it must be enclosed in double-         quotes.--       o negative amounts with a commodity on the left can have the minus sign-         before or after it--       o digit  groups  (thousands, or any other grouping) can be separated by-         space or comma or period and should be used as separator between  all-         groups--       o decimal  part  can be separated by comma or period and should be dif--         ferent from digit groups separator--       o scientific E-notation is allowed.  Be careful  not  to  use  a  digit-         group  separator  character  in scientific notation, as it's not sup--         ported and it might get mistaken for a decimal point.  (Declaring the-         digit group separator character explicitly with a commodity directive-         will prevent this.)--       You can use any of these  variations  when  recording  data.   However,-       there  is  some  ambiguous  way of representing numbers like $1.000 and-       $1,000 both may mean either one thousand or  one  dollar.   By  default-       hledger  will assume that this is sole delimiter is used only for deci--       mals.  On the other hand commodity format declared prior to  that  line-       will help to resolve that ambiguity differently:--              commodity $1,000.00--              2017/12/25 New life of Scrooge-                  expenses:gifts  $1,000-                  assets--       Though  journal  may  contain  mixed  styles  to represent amount, when-       hledger displays amounts, it will choose a consistent format  for  each-       commodity.   (Except  for  price amounts, which are always formatted as-       written).  The display format is chosen as follows:--       o if there is a commodity directive specifying the format, that is used--       o otherwise  the  format  is  inferred from the first posting amount in-         that commodity in the journal, and the precision (number  of  decimal-         places) will be the maximum from all posting amounts in that commmod--         ity--       o or if there are no such amounts in the journal, a default  format  is-         used (like $1000.00).--       Price  amounts  and amounts in D directives usually don't affect amount-       format inference, but in some situations they  can  do  so  indirectly.-       (Eg  when  D's default commodity is applied to a commodity-less amount,-       or when an amountless posting is balanced using a price's commodity, or-       when  -V  is  used.) If you find this causing problems, set the desired-       format with a commodity directive.--   Virtual Postings-       When you parenthesise the account name in a posting,  we  call  that  a-       virtual posting, which means:--       o it is ignored when checking that the transaction is balanced--       o it  is  excluded from reports when the --real/-R flag is used, or the-         real:1 query.--       You could use this, eg, to set an  account's  opening  balance  without-       needing to use the equity:opening balances account:--              1/1 special unbalanced posting to set initial balance-                (assets:checking)   $1000--       When the account name is bracketed, we call it a balanced virtual post--       ing.  This is like an ordinary virtual posting except the balanced vir--       tual  postings  in a transaction must balance to 0, like the real post--       ings (but separately from them).  Balanced virtual  postings  are  also-       excluded by --real/-R or real:1.--              1/1 buy food with cash, and update some budget-tracking subaccounts elsewhere-                expenses:food                   $10-                assets:cash                    $-10-                [assets:checking:available]     $10-                [assets:checking:budget:food]  $-10--       Virtual postings have some legitimate uses, but those are few.  You can-       usually find an equivalent journal entry using real postings, which  is-       more correct and provides better error checking.--   Balance Assertions-       hledger  supports  Ledger-style  balance  assertions  in journal files.-       These look like, for example, = EXPECTEDBALANCE following  a  posting's-       amount.   Eg  here  we assert the expected dollar balance in accounts a-       and b after each posting:--              2013/1/1-                a   $1  =$1-                b       =$-1--              2013/1/2-                a   $1  =$2-                b  $-1  =$-2--       After reading a journal file, hledger will check all balance assertions-       and  report  an error if any of them fail.  Balance assertions can pro--       tect you from, eg, inadvertently disrupting reconciled  balances  while-       cleaning  up  old  entries.   You can disable them temporarily with the-       -I/--ignore-assertions flag, which can be useful for troubleshooting or-       for reading Ledger files.--   Assertions and ordering-       hledger  sorts  an  account's postings and assertions first by date and-       then (for postings on the same day) by parse order.  Note this is  dif--       ferent from Ledger, which sorts assertions only by parse order.  (Also,-       Ledger assertions do not see the accumulated effect of  repeated  post--       ings to the same account within a transaction.)--       So,  hledger  balance  assertions  keep  working if you reorder differ--       ently-dated transactions  within  the  journal.   But  if  you  reorder-       same-dated transactions or postings, assertions might break and require-       updating.  This order dependence does bring an advantage: precise  con--       trol over the order of postings and assertions within a day, so you can-       assert intra-day balances.--   Assertions and included files-       With included files, things are a little more  complicated.   Including-       preserves  the ordering of postings and assertions.  If you have multi--       ple postings to an account on the  same  day,  split  across  different-       files,  and  you  also want to assert the account's balance on the same-       day, you'll have to put the assertion in the right file.--   Assertions and multiple -f options-       Balance assertions don't work well across files specified with multiple-       -f options.  Use include or concatenate the files instead.--   Assertions and commodities-       The  asserted  balance must be a simple single-commodity amount, and in-       fact the assertion checks only  this  commodity's  balance  within  the-       (possibly multi-commodity) account balance.-       This is how assertions work in Ledger also.  We could call this a "par--       tial" balance assertion.--       To assert the balance of more than one commodity in an account, you can-       write multiple postings, each asserting one commodity's balance.--       You  can  make a stronger "total" balance assertion by writing a double-       equals sign (== EXPECTEDBALANCE).  This asserts that there are no other-       unasserted commodities in the account (or, that their balance is 0).--              2013/1/1-                a   $1-                a    1-                b  $-1-                c   -1--              2013/1/2  ; These assertions succeed-                a    0  =  $1-                a    0  =   1-                b    0 == $-1-                c    0 ==  -1--              2013/1/3  ; This assertion fails as 'a' also contains 1-                a    0 ==  $1--       It's not yet possible to make a complete assertion about a balance that-       has multiple commodities.  One workaround is to isolate each  commodity-       into its own subaccount:--              2013/1/1-                a:usd   $1-                a:euro   1-                b--              2013/1/2-                a        0 ==  0-                a:usd    0 == $1-                a:euro   0 ==  1--   Assertions and prices-       Balance  assertions  ignore  transaction prices, and should normally be-       written without one:--              2019/1/1-                (a)     $1 @ 1 = $1--       We do allow prices to be written there, however, and print shows  them,-       even  though  they  don't affect whether the assertion passes or fails.-       This is for backward compatibility (hledger's  close  command  used  to-       generate  balance  assertions with prices), and because balance assign--       ments do use them (see below).--   Assertions and subaccounts-       The balance assertions above (= and ==) do not count the  balance  from-       subaccounts;  they check the account's exclusive balance only.  You can-       assert the balance including subaccounts by writing =* or ==*, eg:--              2019/1/1-                equity:opening balances-                checking:a       5-                checking:b       5-                checking         1  ==* 11--   Assertions and virtual postings-       Balance assertions are checked against all postings, both real and vir--       tual.  They are not affected by the --real/-R flag or real: query.--   Assertions and precision-       Balance  assertions  compare  the exactly calculated amounts, which are-       not always what is shown by reports.   Eg  a  commodity  directive  may-       limit  the  display  precision, but this will not affect balance asser--       tions.  Balance assertion failure messages show exact amounts.--   Balance Assignments-       Ledger-style balance assignments are also supported.   These  are  like-       balance  assertions, but with no posting amount on the left side of the-       equals sign; instead it is calculated automatically so  as  to  satisfy-       the  assertion.   This  can be a convenience during data entry, eg when-       setting opening balances:--              ; starting a new journal, set asset account balances-              2016/1/1 opening balances-                assets:checking            = $409.32-                assets:savings             = $735.24-                assets:cash                 = $42-                equity:opening balances--       or when adjusting a balance to reality:--              ; no cash left; update balance, record any untracked spending as a generic expense-              2016/1/15-                assets:cash    = $0-                expenses:misc--       The calculated amount depends on the account's balance in the commodity-       at  that  point  (which depends on the previously-dated postings of the-       commodity to that account since the last balance assertion  or  assign--       ment).  Note that using balance assignments makes your journal a little-       less explicit; to know the exact amount posted, you have to run hledger-       or do the calculations yourself, instead of just reading it.--   Balance assignments and prices-       A  transaction  price in a balance assignment will cause the calculated-       amount to have that price attached:--              2019/1/1-                (a)             = $1 @ 2--              $ hledger print --explicit-              2019/01/01-                  (a)         $1 @ 2 = $1 @ 2--   Transaction prices-       Within a transaction, you can note an amount's price in another commod--       ity.   This can be used to document the cost (in a purchase) or selling-       price (in a sale).  For  example,  transaction  prices  are  useful  to-       record  purchases  of  a foreign currency.  Note transaction prices are-       fixed at the time of the transaction, and do not change over time.  See-       also market prices, which represent prevailing exchange rates on a cer--       tain date.--       There are several ways to record a transaction price:--       1. Write the price per unit, as @ UNITPRICE after the amount:--                  2009/1/1-                    assets:euros     100 @ $1.35  ; one hundred euros purchased at $1.35 each-                    assets:dollars                 ; balancing amount is -$135.00--       2. Write the total price, as @@ TOTALPRICE after the amount:--                  2009/1/1-                    assets:euros     100 @@ $135  ; one hundred euros purchased at $135 for the lot-                    assets:dollars--       3. Specify amounts for all postings, using exactly two commodities, and-          let hledger infer the price that balances the transaction:--                  2009/1/1-                    assets:euros     100          ; one hundred euros purchased-                    assets:dollars  $-135          ; for $135--       (Ledger users: Ledger uses a different syntax for fixed prices, {=UNIT--       PRICE}, which hledger currently ignores).--       Use the -B/--cost flag to convert amounts to their transaction  price's-       commodity, if any.  (mnemonic: "B" is from "cost Basis", as in Ledger).-       Eg here is how -B affects the balance report for the example above:--              $ hledger bal -N --flat-                             $-135  assets:dollars-                              100  assets:euros-              $ hledger bal -N --flat -B-                             $-135  assets:dollars-                              $135  assets:euros    # <- the euros' cost--       Note -B is sensitive to the order of postings when a transaction  price-       is  inferred:  the  inferred price will be in the commodity of the last-       amount.  So if example 3's postings are reversed, while the transaction-       is equivalent, -B shows something different:--              2009/1/1-                assets:dollars  $-135               ; 135 dollars sold-                assets:euros     100               ; for 100 euros--              $ hledger bal -N --flat -B-                             -100  assets:dollars  # <- the dollars' selling price-                              100  assets:euros--   Comments-       Lines in the journal beginning with a semicolon (;) or hash (#) or star-       (*) are comments, and will be ignored.  (Star comments  cause  org-mode-       nodes  to  be  ignored, allowing emacs users to fold and navigate their-       journals with org-mode or orgstruct-mode.)--       You can attach comments to a transaction  by  writing  them  after  the-       description  and/or  indented  on the following lines (before the post--       ings).  Similarly, you can attach comments to an individual posting  by-       writing  them  after the amount and/or indented on the following lines.-       Transaction and posting comments must begin with a semicolon (;).--       Some examples:--              # a file comment--              ; also a file comment--              comment-              This is a multiline file comment,-              which continues until a line-              where the "end comment" string-              appears on its own (or end of file).-              end comment--              2012/5/14 something  ; a transaction comment-                  ; the transaction comment, continued-                  posting1  1  ; a comment for posting 1-                  posting2-                  ; a comment for posting 2-                  ; another comment line for posting 2-              ; a file comment (because not indented)--       You can also comment  larger  regions  of  a  file  using  comment  and-       end comment directives.--   Tags-       Tags  are  a  way  to add extra labels or labelled data to postings and-       transactions, which you can then search or pivot on.--       A simple tag is a word (which may contain hyphens) followed by  a  full-       colon, written inside a transaction or posting comment line:--              2017/1/16 bought groceries    ; sometag:--       Tags  can  have  a  value, which is the text after the colon, up to the-       next comma or end of line, with leading/trailing whitespace removed:--                  expenses:food    $10   ; a-posting-tag: the tag value--       Note this means hledger's tag values can not  contain  commas  or  new--       lines.  Ending at commas means you can write multiple short tags on one-       line, comma separated:--                  assets:checking       ; a comment containing tag1:, tag2: some value ...--       Here,--       o "a comment containing" is just comment text, not a tag--       o "tag1" is a tag with no value--       o "tag2" is another tag, whose value is "some value ..."--       Tags in a transaction comment affect the transaction  and  all  of  its-       postings,  while  tags  in  a posting comment affect only that posting.-       For example,  the  following  transaction  has  three  tags  (A,  TAG2,-       third-tag) and the posting has four (those plus posting-tag):--              1/1 a transaction  ; A:, TAG2:-                  ; third-tag: a third transaction tag, <- with a value-                  (a)  $1  ; posting-tag:--       Tags  are  like  Ledger's metadata feature, except hledger's tag values-       are simple strings.--   Directives-       A directive is a line in the journal beginning with a special  keyword,-       that influences how the journal is processed.  hledger's directives are-       based on a subset of Ledger's, but there are many differences (and also-       some differences between hledger versions).--       Directives' behaviour and interactions can get a little bit complex, so-       here is a table summarising the  directives  and  their  effects,  with-       links to more detailed docs.---       direc-          end                 subdi-    purpose                        can affect  (as  of-       tive            directive           rec-                                     2018/06)-                                           tives-       --------------------------------------------------------------------------------------------------       account                             any       document   account    names,   all entries in  all-                                           text      declare account types & dis-   files,   before  or-                                                     play order                     after-----       alias           end aliases                   rewrite account names          following-                                                                                    inline/included-                                                                                    entries  until  end-                                                                                    of current file  or-                                                                                    end directive-       apply account   end apply account             prepend  a  common parent to   following-                                                     account names                  inline/included-                                                                                    entries  until  end-                                                                                    of  current file or-                                                                                    end directive-       comment         end comment                   ignore part of journal         following-                                                                                    inline/included-                                                                                    entries  until  end-                                                                                    of  current file or-                                                                                    end directive-       commodity                           format    declare a commodity and  its   number    notation:-                                                     number  notation  &  display   following   entries-                                                     style                          in  that  commodity-                                                                                    in  all files; dis--                                                                                    play style: amounts-                                                                                    of  that  commodity-                                                                                    in reports-       D                                             declare a commodity,  number   commodity: all com--                                                     notation & display style for   modityless  entries-                                                     commodityless amounts          in all files;  num--                                                                                    ber  notation: fol--                                                                                    lowing   commodity--                                                                                    less   entries  and-                                                                                    entries   in   that-                                                                                    commodity   in  all-                                                                                    files;      display-                                                                                    style:  amounts  of-                                                                                    that  commodity  in-                                                                                    reports-       include                                       include   entries/directives   what  the  included-                                                     from another file              directives affect-       P                                             declare a market price for a   amounts   of   that-                                                     commodity                      commodity        in-                                                                                    reports, when -V is-                                                                                    used-       Y                                             declare  a year for yearless   following-                                                     dates                          inline/included-                                                                                    entries  until  end-                                                                                    of current file--       And some definitions:---       subdirec-   optional indented directive line immediately following a par--       tive        ent directive-       number      how to interpret numbers when parsing  journal  entries  (the-       notation    identity  of  the  decimal  separator character).  (Currently-                   each commodity can have its own notation, even  in  the  same-                   file.)-       display     how to display amounts of a commodity in reports (symbol side-       style       and spacing, digit groups, decimal separator, decimal places)-       directive   which entries and (when there are multiple files) which files-       scope       are affected by a directive--       As you can see, directives vary in which journal entries and files they-       affect,  and  whether  they  are  focussed on input (parsing) or output-       (reports).  Some directives have multiple effects.--       If you have a journal made up of multiple files, or  pass  multiple  -f-       options  on  the  command line, note that directives which affect input-       typically last only until the end of their defining  file.   This  pro--       vides more simplicity and predictability, eg reports are not changed by-       writing file options in a different order.  It  can  be  surprising  at-       times though.--   Comment blocks-       A  line  containing just comment starts a commented region of the file,-       and a line containing just end comment (or the end of the current file)-       ends it.  See also comments.--   Including other files-       You  can  pull in the content of additional files by writing an include-       directive, like this:--              include path/to/file.journal--       If the path does not begin with a slash, it is relative to the  current-       file.   The  include  file  path may contain common glob patterns (e.g.-       *).--       The include directive can only  be  used  in  journal  files.   It  can-       include journal, timeclock or timedot files, but not CSV files.--   Default year-       You  can set a default year to be used for subsequent dates which don't-       specify a year.  This is a line beginning with Y followed by the  year.-       Eg:--              Y2009      ; set default year to 2009--              12/15      ; equivalent to 2009/12/15-                expenses  1-                assets--              Y2010      ; change default year to 2010--              2009/1/30  ; specifies the year, not affected-                expenses  1-                assets--              1/31       ; equivalent to 2010/1/31-                expenses  1-                assets--   Declaring commodities-       The  commodity  directive declares commodities which may be used in the-       journal (though currently we do not enforce this).  It may  be  written-       on a single line, like this:--              ; commodity EXAMPLEAMOUNT--              ; display AAAA amounts with the symbol on the right, space-separated,-              ; using period as decimal point, with four decimal places, and-              ; separating thousands with comma.-              commodity 1,000.0000 AAAA--       or  on  multiple  lines, using the "format" subdirective.  In this case-       the commodity symbol appears twice and  should  be  the  same  in  both-       places:--              ; commodity SYMBOL-              ;   format EXAMPLEAMOUNT--              ; display indian rupees with currency name on the left,-              ; thousands, lakhs and crores comma-separated,-              ; period as decimal point, and two decimal places.-              commodity INR-                format INR 9,99,99,999.00--       Commodity  directives  have  a second purpose: they define the standard-       display format for amounts in the commodity.  Normally the display for--       mat  is  inferred  from journal entries, but this can be unpredictable;-       declaring it with a commodity  directive  overrides  this  and  removes-       ambiguity.   Towards  this  end,  amounts  in commodity directives must-       always be written with a decimal point (a period or comma, followed  by-       0 or more decimal digits).--   Default commodity-       The  D  directive  sets a default commodity (and display format), to be-       used for amounts without a commodity symbol (ie, plain numbers).  (Note-       this  differs from Ledger's default commodity directive.) The commodity-       and display format will be applied  to  all  subsequent  commodity-less-       amounts, or until the next D directive.--              # commodity-less amounts should be treated as dollars-              # (and displayed with symbol on the left, thousands separators and two decimal places)-              D $1,000.00--              1/1-                a     5    ; <- commodity-less amount, becomes $1-                b--       As with the commodity directive, the amount must always be written with-       a decimal point.--   Market prices-       The P directive declares a market price,  which  is  an  exchange  rate-       between two commodities on a certain date.  (In Ledger, they are called-       "historical prices".) These are often obtained from a  stock  exchange,-       cryptocurrency exchange, or the foreign exchange market.--       Here is the format:--              P DATE COMMODITYA COMMODITYBAMOUNT--       o DATE is a simple date--       o COMMODITYA is the symbol of the commodity being priced--       o COMMODITYBAMOUNT  is an amount (symbol and quantity) in a second com--         modity, giving the price in commodity B of one unit of commodity A.--       These two market price directives say that one euro was worth  1.35  US-       dollars during 2009, and $1.40 from 2010 onward:--              P 2009/1/1  $1.35-              P 2010/1/1  $1.40--       The  -V/--value flag can be used to convert reported amounts to another-       commodity using these prices.--   Declaring accounts-       account directives can be used to  pre-declare  accounts.   Though  not-       required, they can provide several benefits:--       o They can document your intended chart of accounts, providing a refer--         ence.--       o They can store extra information  about  accounts  (account  numbers,-         notes, etc.)--       o They  can  help  hledger know your accounts' types (asset, liability,-         equity, revenue, expense), useful for reports like  balancesheet  and-         incomestatement.--       o They  control  account  display order in reports, allowing non-alpha--         betic sorting (eg Revenues to appear above Expenses).--       o They  help  with  account  name  completion  in  the   add   command,-         hledger-iadd, hledger-web, ledger-mode etc.--       The  simplest form is just the word account followed by a hledger-style-       account name, eg:--              account assets:bank:checking--   Account comments-       Comments, beginning with a semicolon, optionally including tags, can be-       written after the account name, and/or on following lines.  Eg:--              account assets:bank:checking  ; a comment-                ; another comment-                ; acctno:12345, a tag--       Tip: comments on the same line require hledger 1.12+.  If you need your-       journal to be compatible with older hledger versions, write comments on-       the next line instead.--   Account subdirectives-       We  also  allow  (and ignore) Ledger-style indented subdirectives, just-       for compatibility.:--              account assets:bank:checking-                format blah blah  ; <- subdirective, ignored--       Here is the full syntax of account directives:--              account ACCTNAME  [ACCTTYPE] [;COMMENT]-                [;COMMENTS]-                [LEDGER-STYLE SUBDIRECTIVES, IGNORED]--   Account types-       hledger recognises five types (or classes) of account:  Asset,  Liabil--       ity,  Equity, Revenue, Expense.  This is used by a few accounting-aware-       reports such as balancesheet, incomestatement and cashflow.--   Auto-detected account types-       If you name your top-level accounts with some variation of assets, lia--       bilities/debts,  equity,  revenues/income, or expenses, their types are-       detected automatically.--   Account types declared with tags-       More generally, you can declare  an  account's  type  with  an  account-       directive,  by writing a type: tag in a comment, followed by one of the-       words Asset, Liability, Equity, Revenue, Expense, or one of the letters-       ALERX (case insensitive):--              account assets       ; type:Asset-              account liabilities  ; type:Liability-              account equity       ; type:Equity-              account revenues     ; type:Revenue-              account expenses     ; type:Expenses--   Account types declared with account type codes-       Or,  you can write one of those letters separated from the account name-       by two or more spaces, but this should probably  be  considered  depre--       cated as of hledger 1.13:--              account assets       A-              account liabilities  L-              account equity       E-              account revenues     R-              account expenses     X--   Overriding auto-detected types-       If  you  ever override the types of those auto-detected english account-       names mentioned above, you might need to help the reports a bit.  Eg:--              ; make "liabilities" not have the liability type - who knows why-              account liabilities   ; type:E--              ; we need to ensure some other account has the liability type,-              ; otherwise balancesheet would still show "liabilities" under Liabilities-              account -             ; type:L--   Account display order-       Account directives also set the order in which accounts are  displayed,-       eg  in  reports,  the  hledger-ui  accounts screen, and the hledger-web-       sidebar.  By default accounts are listed in alphabetical order.  But if-       you have these account directives in the journal:--              account assets-              account liabilities-              account equity-              account revenues-              account expenses--       you'll see those accounts displayed in declaration order, not alphabet--       ically:--              $ hledger accounts -1-              assets-              liabilities-              equity-              revenues-              expenses--       Undeclared accounts, if any, are displayed last, in alphabetical order.--       Note  that  sorting  is  done at each level of the account tree (within-       each group of sibling accounts under the same parent).  And  currently,-       this directive:--              account other:zoo--       would  influence the position of zoo among other's subaccounts, but not-       the position of other among the top-level accounts.  This means: -  you-       will  sometimes  declare  parent accounts (eg account other above) that-       you don't intend to post to, just to customize their  display  order  --       sibling accounts stay together (you couldn't display x:y in between a:b-       and a:c).--   Rewriting accounts-       You can define account alias rules which rewrite your account names, or-       parts of them, before generating reports.  This can be useful for:--       o expanding shorthand account names to their full form, allowing easier-         data entry and a less verbose journal--       o adapting old journals to your current chart of accounts--       o experimenting with new account organisations, like a new hierarchy or-         combining two accounts into one--       o customising reports--       Account aliases also rewrite account names in account directives.  They-       do  not  affect  account  names  being  entered  via  hledger  add   or-       hledger-web.--       See also Cookbook: Rewrite account names.--   Basic aliases-       To  set an account alias, use the alias directive in your journal file.-       This affects all subsequent journal entries in the current file or  its-       included files.  The spaces around the = are optional:--              alias OLD = NEW--       Or, you can use the --alias 'OLD=NEW' option on the command line.  This-       affects all entries.  It's useful for trying out aliases interactively.--       OLD  and  NEW  are  case  sensitive  full  account names.  hledger will-       replace any occurrence of the old account name with the new one.   Sub--       accounts are also affected.  Eg:--              alias checking = assets:bank:wells fargo:checking-              # rewrites "checking" to "assets:bank:wells fargo:checking", or "checking:a" to "assets:bank:wells fargo:checking:a"--   Regex aliases-       There  is  also a more powerful variant that uses a regular expression,-       indicated by the forward slashes:--              alias /REGEX/ = REPLACEMENT--       or --alias '/REGEX/=REPLACEMENT'.--       REGEX is a case-insensitive regular expression.   Anywhere  it  matches-       inside  an  account name, the matched part will be replaced by REPLACE--       MENT.  If REGEX contains parenthesised match groups, these can be  ref--       erenced by the usual numeric backreferences in REPLACEMENT.  Eg:--              alias /^(.+):bank:([^:]+)(.*)/ = \1:\2 \3-              # rewrites "assets:bank:wells fargo:checking" to  "assets:wells fargo checking"--       Also  note that REPLACEMENT continues to the end of line (or on command-       line, to end of option argument), so it  can  contain  trailing  white--       space.--   Multiple aliases-       You  can  define  as  many aliases as you like using directives or com--       mand-line options.  Aliases are recursive - each alias sees the  result-       of  applying  previous  ones.   (This  is  different from Ledger, where-       aliases are non-recursive by default).  Aliases are applied in the fol--       lowing order:--       1. alias  directives,  most recently seen first (recent directives take-          precedence over earlier ones; directives not yet seen are ignored)--       2. alias options, in the order they appear on the command line--   end aliases-       You  can  clear  (forget)  all  currently  defined  aliases  with   the-       end aliases directive:--              end aliases--   Default parent account-       You  can  specify  a  parent  account  which  will  be prepended to all-       accounts within a section of the journal.  Use  the  apply account  and-       end apply account directives like so:--              apply account home--              2010/1/1-                  food    $10-                  cash--              end apply account--       which is equivalent to:--              2010/01/01-                  home:food           $10-                  home:cash          $-10--       If  end apply account  is  omitted,  the effect lasts to the end of the-       file.  Included files are also affected, eg:--              apply account business-              include biz.journal-              end apply account-              apply account personal-              include personal.journal--       Prior to hledger 1.0, legacy account and end spellings were  also  sup--       ported.--       A  default parent account also affects account directives.  It does not-       affect account names being entered via hledger add or hledger-web.   If-       account  aliases are present, they are applied after the default parent-       account.--   Periodic transactions-       Periodic transaction rules  describe  transactions  that  recur.   They-       allow you to generate future transactions for forecasting, without hav--       ing to write them out explicitly  in  the  journal  (with  --forecast).-       Secondly, they also can be used to define budget goals (with --budget).--       A periodic transaction rule looks like a normal journal entry, with the-       date replaced by a tilde (~) followed by a period expression (mnemonic:-       ~ looks like a recurring sine wave.):--              ~ monthly-                  expenses:rent          $2000-                  assets:bank:checking--       There is an additional constraint on the period expression:  the  start-       date   must   fall   on   a  natural  boundary  of  the  interval.   Eg-       monthly from 2018/1/1 is valid, but monthly from 2018/1/15 is not.--       Partial or relative dates (M/D, D, tomorrow, last week) in  the  period-       expression  can work (useful or not).  They will be relative to today's-       date, unless a Y default year directive is in  effect,  in  which  case-       they will be relative to Y/1/1.--   Two spaces after the period expression-       If  the  period  expression  is  followed by a transaction description,-       these must be separated by two or more spaces.  This helps hledger know-       where the period expression ends, so that descriptions can not acciden--       tally alter their meaning, as in this example:--              ; 2 or more spaces needed here, so the period is not understood as "every 2 months in 2020"-              ;               ||-              ;               vv-              ~ every 2 months  in 2020, we will review-                  assets:bank:checking   $1500-                  income:acme inc--   Forecasting with periodic transactions-       With the --forecast flag,  each  periodic  transaction  rule  generates-       future transactions recurring at the specified interval.  These are not-       saved in the journal, but appear in all reports.  They will  look  like-       normal  transactions, but with an extra tag named recur, whose value is-       the generating period expression.--       Forecast transactions start on the first occurrence,  and  end  on  the-       last  occurrence,  of  their  interval within the forecast period.  The-       forecast period:--       o begins on the later of--         o the report start date if specified with -b/-p/date:--         o the day after the latest normal (non-periodic) transaction  in  the-           journal, or today if there are no normal transactions.--       o ends  on  the  report  end date if specified with -e/-p/date:, or 180-         days from today.--       where "today" means the current date at report time.   The  "later  of"-       rule  ensures that forecast transactions do not overlap normal transac--       tions in time; they will begin only after normal transactions end.--       Forecasting can be useful for estimating balances into the future,  and-       experimenting  with  different  scenarios.   Note  the start date logic-       means that forecasted transactions are automatically replaced by normal-       transactions as you add those.--       Forecasting can also help with data entry: describe most of your trans--       actions with periodic rules, and every so  often  copy  the  output  of-       print --forecast to the journal.--       You can generate one-time transactions too: just write a period expres--       sion specifying a date with no report interval.  (You could also  write-       a  normal  transaction  with  a future date, but remember this disables-       forecast transactions on previous dates.)--   Budgeting with periodic transactions-       With the --budget flag, currently supported  by  the  balance  command,-       each  periodic transaction rule declares recurring budget goals for the-       specified accounts.  Eg the first example  above  declares  a  goal  of-       spending  $2000  on  rent  (and  also,  a goal of depositing $2000 into-       checking) every month.  Goals and actual performance can then  be  com--       pared in budget reports.--       For  more  details, see: balance: Budget report and Cookbook: Budgeting-       and Forecasting.---   Transaction modifiers-       Transaction modifier rules describe  changes  that  should  be  applied-       automatically  to  certain  transactions.  They can be enabled by using-       the --auto flag.  Currently, just  one  kind  of  change  is  possible:-       adding  extra  postings.   These  rule-generated  postings are known as-       "automated postings" or "auto postings".--       A transaction modifier rule looks  quite  like  a  normal  transaction,-       except  the  first  line  is  an  equals  sign followed by a query that-       matches certain postings (mnemonic: =  suggests  matching).   And  each-       "posting" is actually a posting-generating rule:--              = QUERY-                  ACCT  AMT-                  ACCT  [AMT]-                  ...--       These  posting  rules  look like normal postings, except the amount can-       be:--       o a normal amount with a commodity symbol, eg $2.  This  will  be  used-         as-is.--       o a number, eg 2.  The commodity symbol (if any) from the matched post--         ing will be added to this.--       o a numeric multiplier, eg *2 (a star followed by  a  number  N).   The-         matched posting's amount (and total price, if any) will be multiplied-         by N.--       o a multiplier with a commodity symbol, eg *$2 (a star, number  N,  and-         symbol S).  The matched posting's amount will be multiplied by N, and-         its commodity symbol will be replaced with S.--       Some examples:--              ; every time I buy food, schedule a dollar donation-              = expenses:food-                  (liabilities:charity)   $-1--              ; when I buy a gift, also deduct that amount from a budget envelope subaccount-              = expenses:gifts-                  assets:checking:gifts  *-1-                  assets:checking         *1--              2017/12/1-                expenses:food    $10-                assets:checking--              2017/12/14-                expenses:gifts   $20-                assets:checking--              $ hledger print --auto-              2017/12/01-                  expenses:food              $10-                  assets:checking-                  (liabilities:charity)      $-1--              2017/12/14-                  expenses:gifts             $20-                  assets:checking-                  assets:checking:gifts     -$20-                  assets:checking            $20--   Auto postings and transaction balancing / inferred amounts / balance-       assertions--       Currently, transaction modifiers are applied / auto postings are added:--       o after  missing amounts are inferred, and transactions are checked for-         balancedness,--       o but before balance assertions are checked.--       Note this means that journal entries must be balanced both  before  and-       after auto postings are added.  This changed in hledger 1.12+; see #893-       for background.--EDITOR SUPPORT-       Helper modes exist for popular text editors, which  make  working  with-       journal files easier.  They add colour, formatting, tab completion, and-       helpful commands, and are quite recommended if you  edit  your  journal-       with  a  text  editor.   They  include  ledger-mode or hledger-mode for-       Emacs, vim-ledger for Vim, hledger-vscode for Visual Studio  Code,  and-       others.   See  the  [[Cookbook]] at hledger.org for the latest informa--       tion.----REPORTING BUGS-       Report bugs at http://bugs.hledger.org (or on the #hledger IRC  channel-       or hledger mail list)---AUTHORS-       Simon Michael <simon@joyful.com> and contributors---COPYRIGHT-       Copyright (C) 2007-2016 Simon Michael.-       Released under GNU GPL v3 or later.---SEE ALSO-       hledger(1),      hledger-ui(1),     hledger-web(1),     hledger-api(1),-       hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_time--       dot(5), ledger(1)--       http://hledger.org----hledger 1.14                      March 2019                hledger_journal(5)
− hledger_timeclock.5 
@@ -1,92 +0,0 @@--.TH "hledger_timeclock" "5" "March 2019" "hledger 1.14" "hledger User Manuals"----.SH NAME-.PP-Timeclock \- the time logging format of timeclock.el, as read by hledger-.SH DESCRIPTION-.PP-hledger can read timeclock files.-As with Ledger, these are (a subset of) timeclock.el\[aq]s format,-containing clock\-in and clock\-out entries as in the example below.-The date is a simple date.-The time format is HH:MM[:SS][+\-ZZZZ].-Seconds and timezone are optional.-The timezone, if present, must be four digits and is ignored (currently-the time is always interpreted as a local time).-.IP-.nf-\f[C]-i\ 2015/03/30\ 09:00:00\ some:account\ name\ \ optional\ description\ after\ two\ spaces-o\ 2015/03/30\ 09:20:00-i\ 2015/03/31\ 22:21:45\ another\ account-o\ 2015/04/01\ 02:00:34-\f[]-.fi-.PP-hledger treats each clock\-in/clock\-out pair as a transaction posting-some number of hours to an account.-Or if the session spans more than one day, it is split into several-transactions, one for each day.-For the above time log, \f[C]hledger\ print\f[] generates these journal-entries:-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.timeclock\ print-2015/03/30\ *\ optional\ description\ after\ two\ spaces-\ \ \ \ (some:account\ name)\ \ \ \ \ \ \ \ \ 0.33h--2015/03/31\ *\ 22:21\-23:59-\ \ \ \ (another\ account)\ \ \ \ \ \ \ \ \ 1.64h--2015/04/01\ *\ 00:00\-02:00-\ \ \ \ (another\ account)\ \ \ \ \ \ \ \ \ 2.01h-\f[]-.fi-.PP-Here is a sample.timeclock to download and some queries to try:-.IP-.nf-\f[C]-$\ hledger\ \-f\ sample.timeclock\ balance\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ #\ current\ time\ balances-$\ hledger\ \-f\ sample.timeclock\ register\ \-p\ 2009/3\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ #\ sessions\ in\ march\ 2009-$\ hledger\ \-f\ sample.timeclock\ register\ \-p\ weekly\ \-\-depth\ 1\ \-\-empty\ \ #\ time\ summary\ by\ week-\f[]-.fi-.PP-To generate time logs, ie to clock in and clock out, you could:-.IP \[bu] 2-use emacs and the built\-in timeclock.el, or the extended-timeclock\-x.el and perhaps the extras in ledgerutils.el-.IP \[bu] 2-at the command line, use these bash aliases:-\f[C]shell\ \ \ alias\ ti="echo\ i\ `date\ \[aq]+%Y\-%m\-%d\ %H:%M:%S\[aq]`\ \\$*\ >>$TIMELOG"\ \ \ alias\ to="echo\ o\ `date\ \[aq]+%Y\-%m\-%d\ %H:%M:%S\[aq]`\ >>$TIMELOG"\f[]-.IP \[bu] 2-or use the old \f[C]ti\f[] and \f[C]to\f[] scripts in the ledger 2.x-repository.-These rely on a "timeclock" executable which I think is just the ledger-2 executable renamed.---.SH "REPORTING BUGS"-Report bugs at http://bugs.hledger.org-(or on the #hledger IRC channel or hledger mail list)--.SH AUTHORS-Simon Michael <simon@joyful.com> and contributors--.SH COPYRIGHT--Copyright (C) 2007-2016 Simon Michael.-.br-Released under GNU GPL v3 or later.--.SH SEE ALSO-hledger(1), hledger\-ui(1), hledger\-web(1), hledger\-api(1),-hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_timedot(5),-ledger(1)--http://hledger.org
− hledger_timeclock.info 
@@ -1,60 +0,0 @@-This is hledger_timeclock.info, produced by makeinfo version 6.5 from-stdin.---File: hledger_timeclock.info,  Node: Top,  Up: (dir)--hledger_timeclock(5) hledger 1.14-*********************************--hledger can read timeclock files.  As with Ledger, these are (a subset-of) timeclock.el's format, containing clock-in and clock-out entries as-in the example below.  The date is a simple date.  The time format is-HH:MM[:SS][+-ZZZZ]. Seconds and timezone are optional.  The timezone, if-present, must be four digits and is ignored (currently the time is-always interpreted as a local time).--i 2015/03/30 09:00:00 some:account name  optional description after two spaces-o 2015/03/30 09:20:00-i 2015/03/31 22:21:45 another account-o 2015/04/01 02:00:34--   hledger treats each clock-in/clock-out pair as a transaction posting-some number of hours to an account.  Or if the session spans more than-one day, it is split into several transactions, one for each day.  For-the above time log, 'hledger print' generates these journal entries:--$ hledger -f t.timeclock print-2015/03/30 * optional description after two spaces-    (some:account name)         0.33h--2015/03/31 * 22:21-23:59-    (another account)         1.64h--2015/04/01 * 00:00-02:00-    (another account)         2.01h--   Here is a sample.timeclock to download and some queries to try:--$ hledger -f sample.timeclock balance                               # current time balances-$ hledger -f sample.timeclock register -p 2009/3                    # sessions in march 2009-$ hledger -f sample.timeclock register -p weekly --depth 1 --empty  # time summary by week--   To generate time logs, ie to clock in and clock out, you could:--   * use emacs and the built-in timeclock.el, or the extended-     timeclock-x.el and perhaps the extras in ledgerutils.el--   * at the command line, use these bash aliases: 'shell alias ti="echo-     i `date '+%Y-%m-%d %H:%M:%S'` \$* >>$TIMELOG" alias to="echo o-     `date '+%Y-%m-%d %H:%M:%S'` >>$TIMELOG"'-   * or use the old 'ti' and 'to' scripts in the ledger 2.x repository.-     These rely on a "timeclock" executable which I think is just the-     ledger 2 executable renamed.----Tag Table:-Node: Top78--End Tag Table
− hledger_timeclock.txt 
@@ -1,80 +0,0 @@--hledger_timeclock(5)         hledger User Manuals         hledger_timeclock(5)----NAME-       Timeclock - the time logging format of timeclock.el, as read by hledger--DESCRIPTION-       hledger can read timeclock files.  As with Ledger, these are (a  subset-       of) timeclock.el's format, containing clock-in and clock-out entries as-       in the example below.  The date is a simple date.  The time  format  is-       HH:MM[:SS][+-ZZZZ].   Seconds and timezone are optional.  The timezone,-       if present, must be four digits and is ignored (currently the  time  is-       always interpreted as a local time).--              i 2015/03/30 09:00:00 some:account name  optional description after two spaces-              o 2015/03/30 09:20:00-              i 2015/03/31 22:21:45 another account-              o 2015/04/01 02:00:34--       hledger  treats  each  clock-in/clock-out pair as a transaction posting-       some number of hours to an account.  Or if the session spans more  than-       one  day, it is split into several transactions, one for each day.  For-       the above time log, hledger print generates these journal entries:--              $ hledger -f t.timeclock print-              2015/03/30 * optional description after two spaces-                  (some:account name)         0.33h--              2015/03/31 * 22:21-23:59-                  (another account)         1.64h--              2015/04/01 * 00:00-02:00-                  (another account)         2.01h--       Here is a sample.timeclock to download and some queries to try:--              $ hledger -f sample.timeclock balance                               # current time balances-              $ hledger -f sample.timeclock register -p 2009/3                    # sessions in march 2009-              $ hledger -f sample.timeclock register -p weekly --depth 1 --empty  # time summary by week--       To generate time logs, ie to clock in and clock out, you could:--       o use emacs and  the  built-in  timeclock.el,  or  the  extended  time--         clock-x.el and perhaps the extras in ledgerutils.el--       o at     the     command     line,     use    these    bash    aliases:-         shell   alias ti="echo i `date '+%Y-%m-%d %H:%M:%S'` \$* >>$TIMELOG"   alias to="echo o `date '+%Y-%m-%d %H:%M:%S'` >>$TIMELOG"--       o or use the old ti and to scripts in the ledger 2.x repository.  These-         rely on a "timeclock" executable which I think is just the  ledger  2-         executable renamed.----REPORTING BUGS-       Report  bugs at http://bugs.hledger.org (or on the #hledger IRC channel-       or hledger mail list)---AUTHORS-       Simon Michael <simon@joyful.com> and contributors---COPYRIGHT-       Copyright (C) 2007-2016 Simon Michael.-       Released under GNU GPL v3 or later.---SEE ALSO-       hledger(1),     hledger-ui(1),     hledger-web(1),      hledger-api(1),-       hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_time--       dot(5), ledger(1)--       http://hledger.org----hledger 1.14                      March 2019              hledger_timeclock(5)
− hledger_timedot.5 
@@ -1,154 +0,0 @@--.TH "hledger_timedot" "5" "March 2019" "hledger 1.14" "hledger User Manuals"----.SH NAME-.PP-Timedot \- hledger\[aq]s human\-friendly time logging format-.SH DESCRIPTION-.PP-Timedot is a plain text format for logging dated, categorised quantities-(of time, usually), supported by hledger.-It is convenient for approximate and retroactive time logging, eg when-the real\-time clock\-in/out required with a timeclock file is too-precise or too interruptive.-It can be formatted like a bar chart, making clear at a glance where-time was spent.-.PP-Though called "timedot", this format is read by hledger as commodityless-quantities, so it could be used to represent dated quantities other than-time.-In the docs below we\[aq]ll assume it\[aq]s time.-.SH FILE FORMAT-.PP-A timedot file contains a series of day entries.-A day entry begins with a date, and is followed by category/quantity-pairs, one per line.-Dates are hledger\-style simple dates (see hledger_journal(5)).-Categories are hledger\-style account names, optionally indented.-As in a hledger journal, there must be at least two spaces between the-category (account name) and the quantity.-.PP-Quantities can be written as:-.IP \[bu] 2-a sequence of dots (.) representing quarter hours.-Spaces may optionally be used for grouping and readability.-Eg: ....-\&..-.IP \[bu] 2-an integral or decimal number, representing hours.-Eg: 1.5-.IP \[bu] 2-an integral or decimal number immediately followed by a unit symbol-\f[C]s\f[], \f[C]m\f[], \f[C]h\f[], \f[C]d\f[], \f[C]w\f[], \f[C]mo\f[],-or \f[C]y\f[], representing seconds, minutes, hours, days weeks, months-or years respectively.-Eg: 90m.-The following equivalencies are assumed, currently: 1m = 60s, 1h = 60m,-1d = 24h, 1w = 7d, 1mo = 30d, 1y=365d.-.PP-Blank lines and lines beginning with #, ; or * are ignored.-An example:-.IP-.nf-\f[C]-#\ on\ this\ day,\ 6h\ was\ spent\ on\ client\ work,\ 1.5h\ on\ haskell\ FOSS\ work,\ etc.-2016/2/1-inc:client1\ \ \ ....\ ....\ ....\ ....\ ....\ ....-fos:haskell\ \ \ ....\ ..\ -biz:research\ \ .--2016/2/2-inc:client1\ \ \ ....\ ....-biz:research\ \ .-\f[]-.fi-.PP-Or with numbers:-.IP-.nf-\f[C]-2016/2/3-inc:client1\ \ \ 4-fos:hledger\ \ \ 3-biz:research\ \ 1-\f[]-.fi-.PP-Reporting:-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.timedot\ print\ date:2016/2/2-2016/02/02\ *-\ \ \ \ (inc:client1)\ \ \ \ \ \ \ \ \ \ 2.00--2016/02/02\ *-\ \ \ \ (biz:research)\ \ \ \ \ \ \ \ \ \ 0.25-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.timedot\ bal\ \-\-daily\ \-\-tree-Balance\ changes\ in\ 2016/02/01\-2016/02/03:--\ \ \ \ \ \ \ \ \ \ \ \ ||\ \ 2016/02/01d\ \ 2016/02/02d\ \ 2016/02/03d\ -============++========================================-\ biz\ \ \ \ \ \ \ \ ||\ \ \ \ \ \ \ \ \ 0.25\ \ \ \ \ \ \ \ \ 0.25\ \ \ \ \ \ \ \ \ 1.00\ -\ \ \ research\ ||\ \ \ \ \ \ \ \ \ 0.25\ \ \ \ \ \ \ \ \ 0.25\ \ \ \ \ \ \ \ \ 1.00\ -\ fos\ \ \ \ \ \ \ \ ||\ \ \ \ \ \ \ \ \ 1.50\ \ \ \ \ \ \ \ \ \ \ \ 0\ \ \ \ \ \ \ \ \ 3.00\ -\ \ \ haskell\ \ ||\ \ \ \ \ \ \ \ \ 1.50\ \ \ \ \ \ \ \ \ \ \ \ 0\ \ \ \ \ \ \ \ \ \ \ \ 0\ -\ \ \ hledger\ \ ||\ \ \ \ \ \ \ \ \ \ \ \ 0\ \ \ \ \ \ \ \ \ \ \ \ 0\ \ \ \ \ \ \ \ \ 3.00\ -\ inc\ \ \ \ \ \ \ \ ||\ \ \ \ \ \ \ \ \ 6.00\ \ \ \ \ \ \ \ \ 2.00\ \ \ \ \ \ \ \ \ 4.00\ -\ \ \ client1\ \ ||\ \ \ \ \ \ \ \ \ 6.00\ \ \ \ \ \ \ \ \ 2.00\ \ \ \ \ \ \ \ \ 4.00\ -\-\-\-\-\-\-\-\-\-\-\-\-++\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\--\ \ \ \ \ \ \ \ \ \ \ \ ||\ \ \ \ \ \ \ \ \ 7.75\ \ \ \ \ \ \ \ \ 2.25\ \ \ \ \ \ \ \ \ 8.00\ -\f[]-.fi-.PP-I prefer to use period for separating account components.-We can make this work with an account alias:-.IP-.nf-\f[C]-2016/2/4-fos.hledger.timedot\ \ 4-fos.ledger\ \ \ \ \ \ \ \ \ \ \ ..-\f[]-.fi-.IP-.nf-\f[C]-$\ hledger\ \-f\ t.timedot\ \-\-alias\ /\\\\./=:\ bal\ date:2016/2/4-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 4.50\ \ fos-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 4.00\ \ \ \ hledger:timedot-\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 0.50\ \ \ \ ledger-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\-\--\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 4.50-\f[]-.fi-.PP-Here is a sample.timedot.---.SH "REPORTING BUGS"-Report bugs at http://bugs.hledger.org-(or on the #hledger IRC channel or hledger mail list)--.SH AUTHORS-Simon Michael <simon@joyful.com> and contributors--.SH COPYRIGHT--Copyright (C) 2007-2016 Simon Michael.-.br-Released under GNU GPL v3 or later.--.SH SEE ALSO-hledger(1), hledger\-ui(1), hledger\-web(1), hledger\-api(1),-hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_timedot(5),-ledger(1)--http://hledger.org
− hledger_timedot.info 
@@ -1,116 +0,0 @@-This is hledger_timedot.info, produced by makeinfo version 6.5 from-stdin.---File: hledger_timedot.info,  Node: Top,  Next: FILE FORMAT,  Up: (dir)--hledger_timedot(5) hledger 1.14-*******************************--Timedot is a plain text format for logging dated, categorised quantities-(of time, usually), supported by hledger.  It is convenient for-approximate and retroactive time logging, eg when the real-time-clock-in/out required with a timeclock file is too precise or too-interruptive.  It can be formatted like a bar chart, making clear at a-glance where time was spent.--   Though called "timedot", this format is read by hledger as-commodityless quantities, so it could be used to represent dated-quantities other than time.  In the docs below we'll assume it's time.-* Menu:--* FILE FORMAT::---File: hledger_timedot.info,  Node: FILE FORMAT,  Prev: Top,  Up: Top--1 FILE FORMAT-*************--A timedot file contains a series of day entries.  A day entry begins-with a date, and is followed by category/quantity pairs, one per line.-Dates are hledger-style simple dates (see hledger_journal(5)).-Categories are hledger-style account names, optionally indented.  As in-a hledger journal, there must be at least two spaces between the-category (account name) and the quantity.--   Quantities can be written as:--   * a sequence of dots (.)  representing quarter hours.  Spaces may-     optionally be used for grouping and readability.  Eg: ....  ..--   * an integral or decimal number, representing hours.  Eg: 1.5--   * an integral or decimal number immediately followed by a unit symbol-     's', 'm', 'h', 'd', 'w', 'mo', or 'y', representing seconds,-     minutes, hours, days weeks, months or years respectively.  Eg: 90m.-     The following equivalencies are assumed, currently: 1m = 60s, 1h =-     60m, 1d = 24h, 1w = 7d, 1mo = 30d, 1y=365d.--   Blank lines and lines beginning with #, ; or * are ignored.  An-example:--# on this day, 6h was spent on client work, 1.5h on haskell FOSS work, etc.-2016/2/1-inc:client1   .... .... .... .... .... ....-fos:haskell   .... .. -biz:research  .--2016/2/2-inc:client1   .... ....-biz:research  .--   Or with numbers:--2016/2/3-inc:client1   4-fos:hledger   3-biz:research  1--   Reporting:--$ hledger -f t.timedot print date:2016/2/2-2016/02/02 *-    (inc:client1)          2.00--2016/02/02 *-    (biz:research)          0.25--$ hledger -f t.timedot bal --daily --tree-Balance changes in 2016/02/01-2016/02/03:--            ||  2016/02/01d  2016/02/02d  2016/02/03d -============++========================================- biz        ||         0.25         0.25         1.00 -   research ||         0.25         0.25         1.00 - fos        ||         1.50            0         3.00 -   haskell  ||         1.50            0            0 -   hledger  ||            0            0         3.00 - inc        ||         6.00         2.00         4.00 -   client1  ||         6.00         2.00         4.00 -------------++-----------------------------------------            ||         7.75         2.25         8.00 --   I prefer to use period for separating account components.  We can-make this work with an account alias:--2016/2/4-fos.hledger.timedot  4-fos.ledger           ..--$ hledger -f t.timedot --alias /\\./=: bal date:2016/2/4-                4.50  fos-                4.00    hledger:timedot-                0.50    ledger----------------------                4.50--   Here is a sample.timedot.---Tag Table:-Node: Top76-Node: FILE FORMAT807-Ref: #file-format908--End Tag Table
− hledger_timedot.txt 
@@ -1,127 +0,0 @@--hledger_timedot(5)           hledger User Manuals           hledger_timedot(5)----NAME-       Timedot - hledger's human-friendly time logging format--DESCRIPTION-       Timedot  is  a plain text format for logging dated, categorised quanti--       ties (of time, usually), supported by hledger.  It  is  convenient  for-       approximate  and  retroactive  time  logging,  eg  when  the  real-time-       clock-in/out required with a timeclock  file  is  too  precise  or  too-       interruptive.   It can be formatted like a bar chart, making clear at a-       glance where time was spent.--       Though called "timedot", this format is read by hledger  as  commodity--       less  quantities,  so  it  could  be used to represent dated quantities-       other than time.  In the docs below we'll assume it's time.--FILE FORMAT-       A timedot file contains a series of day entries.  A  day  entry  begins-       with  a date, and is followed by category/quantity pairs, one per line.-       Dates are hledger-style simple dates (see  hledger_journal(5)).   Cate--       gories  are  hledger-style account names, optionally indented.  As in a-       hledger journal, there must be at least two spaces between the category-       (account name) and the quantity.--       Quantities can be written as:--       o a  sequence  of  dots  (.)  representing  quarter  hours.  Spaces may-         optionally be used for grouping and readability.  Eg: ....  ..--       o an integral or decimal number, representing hours.  Eg: 1.5--       o an integral or decimal number immediately followed by a  unit  symbol-         s,  m,  h, d, w, mo, or y, representing seconds, minutes, hours, days-         weeks, months or years respectively.  Eg: 90m.  The following equiva--         lencies  are  assumed,  currently: 1m = 60s, 1h = 60m, 1d = 24h, 1w =-         7d, 1mo = 30d, 1y=365d.--       Blank lines and lines beginning with #, ; or * are ignored.   An  exam--       ple:--              # on this day, 6h was spent on client work, 1.5h on haskell FOSS work, etc.-              2016/2/1-              inc:client1   .... .... .... .... .... ....-              fos:haskell   .... ..-              biz:research  .--              2016/2/2-              inc:client1   .... ....-              biz:research  .--       Or with numbers:--              2016/2/3-              inc:client1   4-              fos:hledger   3-              biz:research  1--       Reporting:--              $ hledger -f t.timedot print date:2016/2/2-              2016/02/02 *-                  (inc:client1)          2.00--              2016/02/02 *-                  (biz:research)          0.25--              $ hledger -f t.timedot bal --daily --tree-              Balance changes in 2016/02/01-2016/02/03:--                          ||  2016/02/01d  2016/02/02d  2016/02/03d-              ============++========================================-               biz        ||         0.25         0.25         1.00-                 research ||         0.25         0.25         1.00-               fos        ||         1.50            0         3.00-                 haskell  ||         1.50            0            0-                 hledger  ||            0            0         3.00-               inc        ||         6.00         2.00         4.00-                 client1  ||         6.00         2.00         4.00-              ------------++-----------------------------------------                          ||         7.75         2.25         8.00--       I  prefer to use period for separating account components.  We can make-       this work with an account alias:--              2016/2/4-              fos.hledger.timedot  4-              fos.ledger           ..--              $ hledger -f t.timedot --alias /\\./=: bal date:2016/2/4-                              4.50  fos-                              4.00    hledger:timedot-                              0.50    ledger-              ---------------------                              4.50--       Here is a sample.timedot.----REPORTING BUGS-       Report bugs at http://bugs.hledger.org (or on the #hledger IRC  channel-       or hledger mail list)---AUTHORS-       Simon Michael <simon@joyful.com> and contributors---COPYRIGHT-       Copyright (C) 2007-2016 Simon Michael.-       Released under GNU GPL v3 or later.---SEE ALSO-       hledger(1),      hledger-ui(1),     hledger-web(1),     hledger-api(1),-       hledger_csv(5), hledger_journal(5), hledger_timeclock(5), hledger_time--       dot(5), ledger(1)--       http://hledger.org----hledger 1.14                      March 2019                hledger_timedot(5)
test/doctests.hs view
@@ -1,21 +1,25 @@-{- +{- Run doctests in Hledger source files under the current directory (./Hledger.hs, ./Hledger/**, ./Text/**) using the doctest runner. +https://github.com/sol/doctest#readme+ Arguments are case-insensitive file path substrings, to limit the files searched. --verbose shows files being searched for doctests and progress while running. --slow reloads ghci between each test (https://github.com/sol/doctest#a-note-on-performance).  Eg, in hledger source dir:- + $ make ghci-doctest, :main [--verbose] [--slow] [CIFILEPATHSUBSTRINGS]  or: -$ stack test hledger-lib:test:doctests [--test-arguments '[--verbose] [--slow] [CIFILEPATHSUBSTRINGS]']+$ stack test hledger-lib:test:doctest --test-arguments="--verbose --slow [CIFILEPATHSUBSTRINGS]"  -}+-- This file can't be called doctest.hs ("File name does not match module name") + {-# LANGUAGE PackageImports #-}  import Control.Monad@@ -25,6 +29,7 @@ import "Glob" System.FilePath.Glob import Test.DocTest +main :: IO () main = do   args <- getArgs   let@@ -40,20 +45,20 @@     ]    -- filter by patterns (case insensitive infix substring match)-  let +  let     fs | null pats = sourcefiles        | otherwise = [f | f <- sourcefiles, let f' = map toLower f, any (`isInfixOf` f') pats']           where pats' = map (map toLower) pats     fslen = length fs-  +   if (null fs)   then do     putStrLn $ "No file paths found matching: " ++ unwords pats    else do-    putStrLn $ -      "Loading and searching for doctests in " -      ++ show fslen +    putStrLn $+      "Loading and searching for doctests in "+      ++ show fslen       ++ if fslen > 1 then " files, plus any files they import:" else " file, plus any files it imports:"     when verbose $ putStrLn $ unwords fs
− test/easytests.hs 
@@ -1,5 +0,0 @@-{--Run hledger-lib's easytest tests using the easytest runner.--}-import Hledger-main = run tests_Hledger
+ test/unittest.hs view
@@ -0,0 +1,13 @@+{-+Run the hledger-lib package's unit tests using the tasty test runner.+-}++import Hledger (tests_Hledger)+import System.Environment (setEnv)+import Test.Tasty (defaultMain)++main :: IO ()+main = do+  setEnv "TASTY_HIDE_SUCCESSES" "true"+  setEnv "TASTY_ANSI_TRICKS" "false"  -- helps the above+  defaultMain tests_Hledger