packages feed

hledger-lib 0.16.1 → 1.52.1

raw patch · 77 files changed

Files

+ CHANGES.md view
@@ -0,0 +1,2159 @@+<!--+ _ _ _+| (_) |__+| | | '_ \+| | | |_) |+|_|_|_.__/++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++-   split up journalFinalise, reorder journal finalisation steps (#893) (Jesse Rosenthal)+    The `journalFinalise` function has been split up, allowing more granular+    control.++-   journalSetTime --> journalSetLastReadTime++-   journalSetFilePath has been removed, use journalAddFile instead++# 1.11.1 (2018/10/06)++-   add, lib: fix wrong transaction rendering in balance assertion errors+    and when using the add command++# 1.11 (2018/9/30)++-   compilation now works when locale is unset (#849)++-   all unit tests have been converted from HUnit+test-framework to easytest++-   doctests now run quicker by default, by skipping reloading between tests.+    This can be disabled by passing --slow to the doctests test suite+    executable.++-   doctests test suite executable now supports --verbose, which shows+    progress output as tests are run if doctest 0.16.0+ is installed+    (and hopefully is harmless otherwise).++-   doctests now support file pattern arguments, provide more informative output.+    Limiting to just the file(s) you're interested can make doctest start+    much quicker. With one big caveat: you can limit the starting files,+    but it always imports and tests all other local files those import.++-   a bunch of custom Show instances have been replaced with defaults,+    for easier troubleshooting. These were sometimes obscuring+    important details, eg in test failure output. Our new policy is:+    stick with default derived Show instances as far as possible, but+    when necessary adjust them to valid haskell syntax so pretty-show+    can pretty-print them (eg when they contain Day values, cf+    https://github.com/haskell/time/issues/101). By convention, when+    fields are shown in less than full detail, and/or in double-quoted+    pseudo syntax, we show a double period (..) in the output.++-   Amount has a new Show instance. Amount's show instance hid+    important details by default, and showing more details required+    increasing the debug level, which was inconvenient. Now it has a+    single show instance which shows more information, is fairly+    compact, and is pretty-printable.++        ghci> usd 1+        OLD:+        Amount {acommodity="$", aquantity=1.00, ..}+        NEW:+        Amount {acommodity = "$", aquantity = 1.00, aprice = NoPrice, astyle = AmountStyle "L False 2 Just '.' Nothing..", amultiplier = False}++    MixedAmount's show instance is unchanged, but showMixedAmountDebug+    is affected by this change:++        ghci> putStrLn $ showMixedAmountDebug $ Mixed [usd 1]+        OLD:+        Mixed [Amount {acommodity="$", aquantity=1.00, aprice=, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}}]+        NEW:+        Mixed [Amount {acommodity="$", aquantity=1.00, aprice=, astyle=AmountStyle "L False 2 Just '.' Nothing.."}]++-   Same-line & next-line comments of transactions, postings, etc.+    are now parsed a bit more precisely (followingcommentp).+    Previously, parsing no comment gave the same result as an empty+    comment (a single newline); now it gives an empty string.\+    Also, and perhaps as a consequence of the above, when there's no+    same-line comment but there is a next-line comment, we'll insert an+    empty first line, since otherwise next-line comments would get moved+    up to the same line when rendered.++-   Hledger.Utils.Test exports HasCallStack++-   queryDateSpan, queryDateSpan' now intersect date AND'ed date spans+    instead of unioning them, and docs are clearer.++-   pushAccount -> pushDeclaredAccount++-   jaccounts -> jdeclaredaccounts++-   AutoTransaction.hs -> PeriodicTransaction.hs & TransactionModifier.hs++-   Hledger.Utils.Debug helpers have been renamed/cleaned up++# 1.10 (2018/6/30)++-   build cleanly with all supported GHC versions again (7.10 to 8.4)++-   support/use latest base-compat (#794)++-   support/require megaparsec 6.4+++-   extensive refactoring and cleanup of parsers and related types and utilities++-   readJournalFile(s) cleanup, these now use InputOpts++-   doctests now run a bit faster (#802)++# 1.9.1 (2018/4/30)++-   new generic PeriodicReport, and some report-related type aliases++-   new BudgetReport++-   make (readJournal\|tryReader)s?WithOpts the default api, dropping "WithOpts"++-   automated postings and command line account aliases happen earlier+    in journal processing (see hledger changelog)++# 1.9 (2018/3/31)++-   support ghc 8.4, latest deps++-   when the system text encoding is UTF-8, ignore any UTF-8 BOM prefix+    found when reading files.++-   CompoundBalanceReport amounts are now normally positive.+    The bs/bse/cf/is commands now show normal income, liability and equity+    balances as positive. Negative numbers now indicate a contra-balance+    (eg an overdrawn checking account), a net loss, a negative net worth,+    etc. This makes these reports more like conventional financial+    statements, and easier to read and share with others. (experimental)++-   splitSpan now returns no spans for an empty datespan++-   don't count periodic/modifier txns in Journal debug output++-   lib/ui/web/api: move embedded manual files to extra-source-files++-   Use skipMany/skipSome for parsing spacenonewline (Moritz Kiefer)+    This avoids allocating the list of space characters only to then+    discard it.++-   rename, clarify purpose of balanceReportFromMultiBalanceReport++-   fix some hlint warnings++-   add some easytest tests++# 1.5 (2017/12/31)++-   -V/--value uses today's market prices by default, not those of last transaction date. #683, #648)++-   csv: allow balance assignment (balance assertion only, no amount) in csv records (Nadrieril)++-   journal: allow space as digit group separator character, #330 (Mykola Orliuk)++-   journal: balance assertion errors now show line of failed assertion posting, #481 (Sam Jeeves)++-   journal: better errors for directives, #402 (Mykola Orliuk)++-   journal: better errors for included files, #660 (Mykola Orliuk)++-   journal: commodity directives in parent files are inherited by included files, #487 (Mykola Orliuk)++-   journal: commodity directives limits precision even after -B, #509 (Mykola Orliuk)++-   journal: decimal point/digit group separator chars are now inferred from an applicable commodity directive or default commodity directive. #399, #487 (Mykola Orliuk)++-   journal: numbers are parsed more strictly (Mykola Orliuk)++-   journal: support Ledger-style automated postings, enabled with --auto flag (Dmitry Astapov)++-   journal: support Ledger-style periodic transactions, enabled with --forecast flag (Dmitry Astapov)++-   period expressions: fix "nth day of {week,month}", which could generate wrong intervals (Dmitry Astapov)++-   period expressions: month names are now case-insensitive (Dmitry Astapov)++-   period expressions: stricter checking for invalid expressions (Mykola Orliuk)++-   period expressions: support "every 11th Nov" (Dmitry Astapov)++-   period expressions: support "every 2nd Thursday of month" (Dmitry Astapov)++-   period expressions: support "every Tuesday", short for "every <n>th day of week" (Dmitry Astapov)++-   remove upper bounds on all but hledger* and base (experimental)+    It's rare that my deps break their api or that newer versions must+    be avoided, and very common that they release new versions which I+    must tediously and promptly test and release hackage revisions for+    or risk falling out of stackage. Trying it this way for a bit.++# 1.4 (2017/9/30)++-   add readJournalFile\[s\]WithOpts, with simpler arguments and support+    for detecting new transactions since the last read.++-   query: add payee: and note: query terms, improve description/payee/note docs (Jakub Zárybnický, Simon Michael, #598, #608)++-   journal, cli: make trailing whitespace significant in regex account aliases+    Trailing whitespace in the replacement part of a regular expression+    account alias is now significant. Eg, converting a parent account to+    just an account name prefix: --alias '/:acct:/=:acct'++-   timedot: allow a quantity of seconds, minutes, days, weeks, months+    or years to be logged as Ns, Nm, Nd, Nw, Nmo, Ny++-   csv: switch the order of generated postings, so account1 is first.+    This simplifies things and facilitates future improvements.++-   csv: show the "creating/using rules file" message only with --debug++-   csv: fix multiple includes in one rules file++-   csv: add "newest-first" rule for more robust same-day ordering++-   deps: allow ansi-terminal 0.7++-   deps: add missing parsec lower bound, possibly related to #596, fpco/stackage#2835++-   deps: drop oldtime flag, require time 1.5+++-   deps: remove ghc < 7.6 support, remove obsolete CPP conditionals++-   deps: fix test suite with ghc 8.2++# 1.3.1 (2017/8/25)++-   Fix a bug with -H showing nothing for empty periods (#583, Nicholas Niro)+    This patch fixes a bug that happened when using the -H option on+    a period without any transaction. Previously, the behavior was no+    output at all even though it should have shown the previous ending balances+    of past transactions. (This is similar to previously using -H with -E,+    but with the extra advantage of not showing empty accounts)++-   allow megaparsec 6 (#594)++-   allow megaparsec-6.1 (Hans-Peter Deifel)++-   fix test suite with Cabal 2 (#596)++# 1.3 (2017/6/30)++journal: The "uncleared" transaction/posting status, and associated UI flags+and keys, have been renamed to "unmarked" to remove ambiguity and+confusion. This means that we have dropped the `--uncleared` flag,+and our `-U` flag now matches only unmarked things and not pending+ones. See the issue and linked mail list discussion for more+background. (#564)++csv: assigning to the "balance" field name creates balance+assertions (#537, Dmitry Astapov).++csv: Doubled minus signs are handled more robustly (fixes #524, Nicolas Wavrant, Simon Michael)++Multiple "status:" query terms are now OR'd together. (#564)++deps: allow megaparsec 5.3.++# 1.2 (2017/3/31)++## journal format++A pipe character can optionally be used to delimit payee names in+transaction descriptions, for more accurate querying and pivoting by+payee. Eg, for a description like `payee name | additional notes`,+the two parts will be accessible as pseudo-fields/tags named `payee`+and `note`.++Some journal parse errors now show the range of lines involved, not just the first.++## ledger format++The experimental `ledger:` reader based on the WIP ledger4 project has+been disabled, reducing build dependencies.++## Misc++Fix a bug when tying the knot between postings and their parent transaction, reducing memory usage by about 10% (#483) (Mykola Orliuk)++Fix a few spaceleaks (#413) (Moritz Kiefer)++Add Ledger.Parse.Text to package.yaml, fixing a potential build failure.++Allow megaparsec 5.2 (#503)++Rename optserror -> usageError, consolidate with other error functions++# 1.1 (2016/12/31)++## journal format++-   balance assignments are now supported (#438, #129, #157, #288)++    This feature also brings a slight performance drop (\~5%);+    optimisations welcome.++-   also recognise `*.hledger` files as hledger journal format++## ledger format++-   use ledger-parse from the ledger4 project as an alternate reader for C++ Ledger journals++    The idea is that some day we might get better compatibility with Ledger files this way.+    Right now this reader is not very useful and will be used only if you explicitly select it with a `ledger:` prefix.+    It parses transaction dates, descriptions, accounts and amounts, and ignores everything else.+    Amount parsing is delegated to hledger's journal parser, and malformed amounts might be silently ignored.++    This adds at least some of the following as new dependencies for hledger-lib:+    parsers, parsec, attoparsec, trifecta.++## misc++-   update base lower bound to enforce GHC 7.10+++    hledger-lib had a valid install plan with GHC 7.8, but currently requires GHC 7.10 to compile.+    Now we require base 4.8+ everywhere to ensure the right GHC version at the start.++-   Hledger.Read api cleanups++-   rename dbgIO to dbg0IO, consistent with dbg0, and document a bug in dbg*IO++-   make readJournalFiles \[f\] equivalent to readJournalFile f (#437)++-   more general parser types enabling reuse outside of IO (#439)++# 1.0.1 (2016/10/27)++-   allow megaparsec 5.0 or 5.1++# 1.0 (2016/10/26)++## timedot format++-   new "timedot" format for retroactive/approximate time logging.++    Timedot is a plain text format for logging dated, categorised+    quantities (eg time), 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.++## timeclock format++-   renamed "timelog" format to "timeclock", matching the emacs package++-   sessions can no longer span file boundaries (unclocked-out++    sessions will be auto-closed at the end of the file).++-   transaction ids now count up rather than down (#394)++-   timeclock files no longer support default year directives++-   removed old code for appending timeclock transactions to journal transactions.++    A holdover from the days when both were allowed in one file.++## csv format++-   fix empty field assignment parsing, rule parse errors after megaparsec port (#407) (Hans-Peter Deifel)++## journal format++-   journal files can now include timeclock or timedot files (#320)++    (but not yet CSV files).++-   fixed an issue with ordering of same-date transactions included from other files++-   the "commodity" directive and "format" subdirective are now supported, allowing++    full control of commodity style (#295) The commodity directive's+    format subdirective can now be used to override the inferred+    style for a commodity, eg to increase or decrease the+    precision. This is at least a good workaround for #295.++-   Ledger-style "apply account"/"end apply account" directives are now used to set a default parent account.++-   the Ledger-style "account" directive is now accepted (and ignored).++-   bracketed posting dates are more robust (#304)++    Bracketed posting dates were fragile; they worked only if you+    wrote full 10-character dates. Also some semantics were a bit+    unclear. Now they should be robust, and have been documented+    more clearly. This is a legacy undocumented Ledger syntax, but+    it improves compatibility and might be preferable to the more+    verbose "date:" tags if you write posting dates often (as I do).+    Internally, bracketed posting dates are no longer considered to+    be tags. Journal comment, tag, and posting date parsers have+    been reworked, all with doctests.++-   balance assertion failure messages are clearer++-   with --debug=2, more detail about balance assertions is shown.++## misc++-   file parsers have been ported from Parsec to Megaparsec \o/ (#289, #366) (Alexey Shmalko, Moritz Kiefer)++-   most hledger types have been converted from String to Text, reducing memory usage by 30%+ on large files++-   file parsers have been simplified for easier troubleshooting (#275).++    The journal/timeclock/timedot parsers, instead of constructing+    opaque journal update functions which are later applied to build+    the journal, now construct the journal directly by modifying the+    parser state. This is easier to understand and debug. It also+    rules out the possibility of journal updates being a space+    leak. (They weren't, in fact this change increased memory usage+    slightly, but that has been addressed in other ways). The+    ParsedJournal type alias has been added to distinguish+    "being-parsed" journals and "finalised" journals.++-   file format detection is more robust.++    The Journal, Timelog and Timedot readers' detectors now check+    each line in the sample data, not just the first one. I think the+    sample data is only about 30 chars right now, but even so this+    fixed a format detection issue I was seeing.+    Also, we now always try parsing stdin as journal format (not just sometimes).++-   all file formats now produce transaction ids, not just journal (#394)++-   git clone of the hledger repo on windows now works (#345)++-   added missing benchmark file (#342)++-   our stack.yaml files are more compatible across stack versions (#300)++-   use newer file-embed to fix ghci working directory dependence (<https://github.com/snoyberg/file-embed/issues/18>)++-   report more accurate dates in account transaction report when postings have their own dates++    (affects hledger-ui and hledger-web registers).+    The newly-named "transaction register date" is the date to be+    displayed for that transaction in a transaction register, for+    some current account and filter query. It is either the+    transaction date from the journal ("transaction general date"),+    or if postings to the current account and matched by the+    register's filter query have their own dates, the earliest of+    those posting dates.++-   simplify account transactions report's running total.++    The account transactions report used for hledger-ui and -web+    registers now gives either the "period total" or "historical+    total", depending strictly on the --historical flag. It doesn't+    try to indicate whether the historical total is the accurate+    historical balance (which depends on the user's report query).++-   reloading a file now preserves the effect of options, query arguments etc.++-   reloading a journal should now reload all included files as well.++-   the Hledger.Read.* modules have been reorganised for better reuse.++    Hledger.Read.Utils has been renamed Hledger.Read.Common+    and holds low-level parsers & utilities; high-level read+    utilities are now in Hledger.Read.++-   clarify amount display style canonicalisation code and terminology a bit.++    Individual amounts still have styles; from these we derive+    the standard "commodity styles". In user docs, we might call+    these "commodity formats" since they can be controlled by the+    "format" subdirective in journal files.++-   Journal is now a monoid++-   expandPath now throws a proper IO error++-   more unit tests, start using doctest++0.27 (2015/10/30)++-   The main hledger types now derive NFData, which makes it easier to+    time things with criterion.++-   Utils has been split up more.++-   Utils.Regex: regular expression compilation has been memoized, and+    memoizing versions of regexReplace\[CI\] have been added, since+    compiling regular expressions every time seems to be quite+    expensive (#244).++-   Utils.String: strWidth is now aware of multi-line strings (#242).++-   Read: parsers now use a consistent p suffix.++-   New dependencies: deepseq, uglymemo.++-   All the hledger packages' cabal files are now generated from+    simpler, less redundant yaml files by hpack, in principle. In+    practice, manual fixups are still needed until hpack gets better,+    but it's still a win.++0.26 (2015/7/12)++-   allow year parser to handle arbitrarily large years+-   Journal's Show instance reported one too many accounts+-   some cleanup of debug trace helpers+-   tighten up some date and account name parsers (don't accept leading spaces; hadddocks)+-   drop regexpr dependency++0.25.1 (2015/4/29)++-   support/require base-compat >0.8 (#245)++0.25 (2015/4/7)++-   GHC 7.10 compatibility (#239)++0.24.1 (2015/3/15)++-   fix JournalReader "ctx" compilation warning+-   add some type signatures in Utils to help make ghci-web++0.24 (2014/12/25)++-   fix combineJournalUpdates folding order+-   fix a regexReplaceCI bug+-   fix a splitAtElement bug with adjacent separators+-   mostly replace slow regexpr with regex-tdfa (fixes #189)+-   use the modern Text.Parsec API+-   allow transformers 0.4*+-   regexReplace now supports backreferences+-   Transactions now remember their parse location in the journal file+-   export Regexp types, disambiguate CsvReader's similarly-named type+-   export failIfInvalidMonth/Day (fixes #216)+-   track the commodity of zero amounts when possible+    (useful eg for hledger-web's multi-commodity charts)+-   show posting dates in debug output+-   more debug helpers++0.23.3 (2014/9/12)++-   allow transformers 0.4*++0.23.2 (2014/5/8)++-   postingsReport: also fix date sorting of displayed postings (#184)++0.23.1 (2014/5/7)++-   postingsReport: with disordered journal entries, postings before the+    report start date could get wrongly included. (#184)++0.23 (2014/5/1)++-   orDatesFrom -> spanDefaultsFrom++0.22.2 (2014/4/16)++-   display years before 1000 with four digits, not three+-   avoid pretty-show to build with GHC < 7.4+-   allow text 1.1, drop data-pprint to build with GHC 7.8.x++0.22.1 (2014/1/6) and older: see http://hledger.org/release-notes or doc/CHANGES.md.
Hledger.hs view
@@ -1,11 +1,388 @@+{-|+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 (-                module Hledger.Data-               ,module Hledger.Read-               ,module Hledger.Reports-               ,module Hledger.Utils+  -- $DOCS+  module X+ ,tests_Hledger ) where-import Hledger.Data-import Hledger.Read-import Hledger.Reports-import Hledger.Utils++import           Hledger.Data    as X+import           Hledger.Read    as X+import           Hledger.Reports as X+import           Hledger.Query   as X+import           Hledger.Utils   as X++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
@@ -1,4 +1,5 @@-{-| +{-# LANGUAGE OverloadedStrings #-}+{-|  The Hledger.Data library allows parsing and querying of C++ ledger-style journal files.  It generally provides a compatible subset of C++ ledger's@@ -11,45 +12,71 @@                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.Matching,+               module Hledger.Data.Period,+               module Hledger.Data.PeriodData,+               module Hledger.Data.PeriodicTransaction,                module Hledger.Data.Posting,-               module Hledger.Data.TimeLog,+               module Hledger.Data.RawOptions,+               module Hledger.Data.StringFormat,+               module Hledger.Data.Timeclock,                module Hledger.Data.Transaction,+               module Hledger.Data.TransactionModifier,                module Hledger.Data.Types,-               tests_Hledger_Data+               module Hledger.Data.Valuation,+               tests_Data               ) where-import Test.HUnit +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.Matching+import Hledger.Data.Period+import Hledger.Data.PeriodData+import Hledger.Data.PeriodicTransaction import Hledger.Data.Posting-import Hledger.Data.TimeLog+import Hledger.Data.RawOptions+import Hledger.Data.StringFormat+import Hledger.Data.Timeclock import Hledger.Data.Transaction-import Hledger.Data.Types+import Hledger.Data.TransactionModifier+import Hledger.Data.Types hiding (MixedAmountKey, Mixed)+import Hledger.Data.Valuation -tests_Hledger_Data = TestList-    [-     tests_Hledger_Data_Account-    ,tests_Hledger_Data_AccountName-    ,tests_Hledger_Data_Amount-    ,tests_Hledger_Data_Commodity-    ,tests_Hledger_Data_Dates-    ,tests_Hledger_Data_Journal-    ,tests_Hledger_Data_Ledger-    ,tests_Hledger_Data_Matching-    ,tests_Hledger_Data_Posting-    ,tests_Hledger_Data_TimeLog-    ,tests_Hledger_Data_Transaction-    -- ,tests_Hledger_Data_Types-    ]+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,32 +1,393 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} {-| -An 'Account' stores -- an 'AccountName',--- all 'Posting's in the account, excluding subaccounts--- a 'MixedAmount' representing the account balance, including subaccounts.+An 'Account' has a name, a list of subaccounts, an optional parent+account, and subaccounting-excluding and -including balances.  -}  module Hledger.Data.Account-where-import Test.HUnit-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.Types+import Hledger.Utils  -instance Show Account where-    show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b)+-- deriving instance Show Account+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-    (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2+instance Eq (Account a) where+  (==) a b = aname a == aname b -- quick equality test for speed+             -- and+             -- [ aname a == aname b+             -- -- , aparent a == aparent b  -- avoid infinite recursion+             -- , asubs a == asubs b+             -- , aebalance a == aebalance b+             -- , aibalance a == aibalance b+             -- ] -nullacct = Account "" [] nullmixedamt+nullacct :: Account BalanceData+nullacct = accountFromBalances "" mempty -tests_Hledger_Data_Account = TestList [- ]+-- | 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+  , adata            = bal+  } +-- | 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 -> Maybe Day) -> [Posting] -> [Account BalanceData]+accountsFromPostings getPostingDate = flattenAccounts . accountFromPostings getPostingDate++-- | 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 :: 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') =+      (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 a -> Account a+tieAccountParents = tie Nothing+  where+    tie parent a@Account{..} = a'+      where+        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 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 a -> [[Account a]]+accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[])++-- | Map a (non-tree-structure-modifying) function over this and sub accounts.+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 a -> Bool) -> Account a -> Bool+anyAccounts p a+    | p a = True+    | otherwise = any (anyAccounts p) $ asubs a++-- | 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+    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 a -> Account a+clipAccounts 0 a = a{asubs=[]}+clipAccounts d a = a{asubs=subs}+    where+      subs = map (clipAccounts (d-1)) $ asubs a++-- | 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).+-- 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 depthSpec $ aname a} | a <- as]+      combined = [a{adata=foldMap adata same}+                 | same@(a:|_) <- groupWith aname clipped]++{-+test cases, assuming d=1:++assets:cash 1 1+assets:checking 1 1+->+as:       [assets:cash 1 1, assets:checking 1 1]+clipped:  [assets 1 1, assets 1 1]+combined: [assets 2 2]++assets 0 2+ assets:cash 1 1+ assets:checking 1 1+->+as:       [assets 0 2, assets:cash 1 1, assets:checking 1 1]+clipped:  [assets 0 2, assets 1 1, assets 1 1]+combined: [assets 2 2]++assets 0 2+ assets:bank 1 2+  assets:bank:checking 1 1+->+as:       [assets 0 2, assets:bank 1 2, assets:bank:checking 1 1]+clipped:  [assets 0 2, assets 1 2, assets 1 1]+combined: [assets 2 2]++-}++-- | Remove all leaf accounts and subtrees matching a predicate.+pruneAccounts :: (Account a -> Bool) -> Account a -> Maybe (Account a)+pruneAccounts p = headMay . prune+  where+    prune a+      | null prunedsubs = if p a then [] else [a']+      | otherwise       = [a']+      where+        prunedsubs = concatMap prune $ asubs a+        a' = a{asubs=prunedsubs}++-- | 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 a -> [Account a]+flattenAccounts a = squish a []+  where squish a' as = a' : Prelude.foldr squish as (asubs a')++-- | Filter an account tree (to a list).+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)++-- | 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+    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 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.+-- 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)+-- or removed (suitable for a flat-mode report).+--+sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName]+sortAccountNamesByDeclaration j keepparents 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 a -> Account a+sortAccountTreeByDeclaration a+  | null $ asubs a = a+  | otherwise      = a{asubs=+      sortOn accountDeclarationOrderAndName $+      map sortAccountTreeByDeclaration $ asubs a+      }++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 a] -> Maybe (Account a)+lookupAccount a = find ((==a).aname)++-- debug helpers++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 %s %4s"+                     (aname 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,4 +1,5 @@-{-# LANGUAGE NoMonomorphismRestriction#-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-} {-|  'AccountName's are strings like @assets:cash:petty@, with multiple@@ -7,152 +8,303 @@  -} -module Hledger.Data.AccountName+module Hledger.Data.AccountName (+   accountLeafName+  ,accountNameComponents+  ,accountNameDrop+  ,accountNameFromComponents+  ,accountNameLevel+  ,accountNameToAccountOnlyRegex+  ,accountNameToAccountOnlyRegexCI+  ,accountNameToAccountRegex+  ,accountNameToAccountRegexCI+  ,accountNameTreeFrom+  ,accountSummarisedName+  ,accountNameInferType+  ,accountNameInferTypeExcept+  ,accountNameType+  ,defaultBaseConversionAccount+  ,assetAccountRegex+  ,cashAccountRegex+  ,liabilityAccountRegex+  ,equityAccountRegex+  ,conversionAccountRegex+  ,revenueAccountRegex+  ,gainAccountRegex+  ,expenseAccountRegex+  ,acctsep+  ,acctsepchar+  ,clipAccountName+  ,clipOrEllipsifyAccountName+  ,getAccountNameClippedDepth+  ,elideAccountName+  ,escapeName+  ,expandAccountName+  ,expandAccountNames+  ,isAccountNamePrefixOf+--  ,isAccountRegex+  ,isSubAccountNameOf+  ,parentAccountName+  ,parentAccountNames+  ,subAccountNamesFrom+  ,topAccountNames+  ,topAccountName+  ,unbudgetedAccountName+  ,accountNamePostingType+  ,accountNameWithoutPostingType+  ,accountNameWithPostingType+  ,joinAccountNames+  ,concatAccountNames+  ,accountNameApplyAliases+  ,accountNameApplyAliasesMemo+  ,tests_AccountName+) where-import Data.List-import Data.Map (Map)-import Data.Tree-import Test.HUnit-import Text.Printf-import qualified Data.Map as M -import Hledger.Data.Types-import Hledger.Utils+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 Data.Text qualified as T+import Data.Tree (Tree(..), unfoldTree)+import Safe+import Text.DocLayout (realLength) +import Hledger.Data.Types hiding (asubs)+import Hledger.Utils+import Data.List (partition) +-- $setup+-- >>> :set -XOverloadedStrings --- change to use a different separator for nested accounts+acctsepchar :: Char acctsepchar = ':' -accountNameComponents :: AccountName -> [String]-accountNameComponents = splitAtElement acctsepchar--accountNameFromComponents :: [String] -> AccountName-accountNameFromComponents = concat . intersperse [acctsepchar]+acctsep :: Text+acctsep = T.pack [acctsepchar] -accountLeafName :: AccountName -> String-accountLeafName = last . accountNameComponents+-- The base conversion account name used by --infer-equity,+-- when no other account of type V/Conversion has been declared.+defaultBaseConversionAccount = "equity:conversion" -accountNameLevel :: AccountName -> Int-accountNameLevel "" = 0-accountNameLevel a = length (filter (==acctsepchar) a) + 1+-- | 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?(:|$)" -accountNameDrop :: Int -> AccountName -> AccountName-accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents+-- | 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 --- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]-expandAccountNames :: [AccountName] -> [AccountName]-expandAccountNames as = nub $ concatMap expand as-    where expand = map accountNameFromComponents . tail . inits . accountNameComponents+-- | 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 --- | ["a:b:c","d:e"] -> ["a","d"]-topAccountNames :: [AccountName] -> [AccountName]-topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]+-- 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 -parentAccountName :: AccountName -> AccountName-parentAccountName = accountNameFromComponents . init . accountNameComponents+-- accountNameComponents :: AccountName -> [String]+-- accountNameComponents = splitAtElement acctsepchar -parentAccountNames :: AccountName -> [AccountName]-parentAccountNames a = parentAccountNames' $ parentAccountName a-    where-      parentAccountNames' "" = []-      parentAccountNames' a = a : parentAccountNames' (parentAccountName a)+accountNameComponents :: AccountName -> [Text]+accountNameComponents = T.splitOn acctsep -isAccountNamePrefixOf :: AccountName -> AccountName -> Bool-isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])+accountNameFromComponents :: [Text] -> AccountName+accountNameFromComponents = T.intercalate acctsep -isSubAccountNameOf :: AccountName -> AccountName -> Bool-s `isSubAccountNameOf` p = -    (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))+accountLeafName :: AccountName -> Text+accountLeafName = last . accountNameComponents --- | 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+-- | Truncate all account name components but the last to two characters.+accountSummarisedName :: AccountName -> Text+accountSummarisedName a+  --   length cs > 1 = take 2 (head cs) ++ ":" ++ a'+  | length cs > 1 = T.intercalate ":" (map (T.take 2) $ init cs) <> ":" <> a'+  | otherwise     = a'+    where+      cs = accountNameComponents a+      a' = accountLeafName a --- | Convert a list of account names to a tree.-accountNameTreeFrom :: [AccountName] -> Tree AccountName-accountNameTreeFrom = accountNameTreeFrom1+-- | 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 -accountNameTreeFrom1 accts = -    Node "top" (accounttreesfrom (topAccountNames accts))-        where-          accounttreesfrom :: [AccountName] -> [Tree AccountName]-          accounttreesfrom [] = []-          accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]-          subs = subAccountNamesFrom (expandAccountNames accts)+-- | A top-level account prefixed to some accounts in budget reports.+-- Defined here so it can be ignored by accountNameDrop.+unbudgetedAccountName :: T.Text+unbudgetedAccountName = "<unbudgeted>" -nullaccountnametree = Node "top" []+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 -accountNameTreeFrom2 accts = -   Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts-        where-          subs = subAccountNamesFrom allaccts-          allaccts = expandAccountNames accts-          -- subs' a = subsmap ! a-          -- subsmap :: Map AccountName [AccountName]-          -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]+accountNameWithoutPostingType :: AccountName -> AccountName+accountNameWithoutPostingType a = case accountNamePostingType a of+                                    BalancedVirtualPosting -> textUnbracket a+                                    VirtualPosting -> textUnbracket a+                                    RegularPosting -> a -accountNameTreeFrom3 accts = -    Node "top" $ forestfrom allaccts $ topAccountNames accts-        where-          -- drop accts from the list of potential subs as we add them to the tree-          forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName-          forestfrom subaccts accts = -              [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]-          allaccts = expandAccountNames accts-          +accountNameWithPostingType :: PostingType -> AccountName -> AccountName+accountNameWithPostingType BalancedVirtualPosting = wrap "[" "]" . accountNameWithoutPostingType+accountNameWithPostingType VirtualPosting         = wrap "(" ")" . accountNameWithoutPostingType+accountNameWithPostingType RegularPosting         = accountNameWithoutPostingType --- a more efficient tree builder from Cale Gibbard-newtype Tree' a = T (Map a (Tree' a))-  deriving (Show, Eq, Ord)+-- | 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] -mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a-mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')+-- | 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 -emptyTree = T M.empty+-- | 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 -pathtree :: [a] -> Tree' a-pathtree []     = T M.empty-pathtree (x:xs) = T (M.singleton x (pathtree xs))+-- | Memoising version of accountNameApplyAliases, maybe overkill.+accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName+accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)+  -- XXX re-test this memoisation -fromPaths :: (Ord a) => [[a]] -> Tree' a-fromPaths = foldl' mergeTrees emptyTree . map pathtree+-- aliasMatches :: AccountAlias -> AccountName -> Bool+-- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a+-- aliasMatches (RegexAlias re  _) a = regexMatchesCI re a --- the above, but trying to build Tree directly+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 --- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a--- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')+-- | 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.+accountNameDrop :: Int -> AccountName -> AccountName+accountNameDrop n a+  | a == unbudgetedAccountName = a+  | unbudgetedAccountAndSep `T.isPrefixOf` a =+      case accountNameDrop n $ T.drop (T.length unbudgetedAccountAndSep) a of+        "" -> unbudgetedAccountName+        a' -> unbudgetedAccountAndSep <> a'+  | otherwise = accountNameFromComponentsOrElide . drop n $ accountNameComponents a+  where+    unbudgetedAccountAndSep = unbudgetedAccountName <> acctsep+    accountNameFromComponentsOrElide [] = "..."+    accountNameFromComponentsOrElide xs = accountNameFromComponents xs --- emptyTree' = Node "top" []+-- | 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 = toList . foldMap (S.fromList . expandAccountName) --- pathtree' :: [a] -> Tree a--- pathtree' []     = Node undefined []--- pathtree' (x:xs) = Node x [pathtree' xs]+-- | "a:b:c" -> ["a","a:b","a:b:c"]+expandAccountName :: AccountName -> [AccountName]+expandAccountName = map accountNameFromComponents . NE.tail . NE.inits . accountNameComponents --- fromPaths' :: (Ord a) => [[a]] -> Tree a--- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'+-- | ["a:b:c","d:e"] -> ["a","d"]+topAccountNames :: [AccountName] -> [AccountName]+topAccountNames = filter ((1==) . accountNameLevel) . expandAccountNames +-- | "a:b:c" -> "a"+topAccountName :: AccountName -> AccountName+topAccountName = T.takeWhile (/= acctsepchar) --- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]--- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]+parentAccountName :: AccountName -> AccountName+parentAccountName = accountNameFromComponents . init . accountNameComponents --- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName--- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)+parentAccountNames :: AccountName -> [AccountName]+parentAccountNames a = parentAccountNames' $ parentAccountName a+    where+      parentAccountNames' "" = []+      parentAccountNames' a2 = a2 : parentAccountNames' (parentAccountName a2) -converttree :: Tree' AccountName -> [Tree AccountName]-converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]+-- | Is the first account a parent or other ancestor of (and not the same as) the second ?+isAccountNamePrefixOf :: AccountName -> AccountName -> Bool+isAccountNamePrefixOf = T.isPrefixOf . (<> acctsep) -expandTreeNames :: Tree AccountName -> Tree AccountName-expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)+isSubAccountNameOf :: AccountName -> AccountName -> Bool+s `isSubAccountNameOf` p =+  (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) -accountNameTreeFrom4 :: [AccountName] -> Tree AccountName-accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents+-- | 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, efficiently.+accountNameTreeFrom :: [AccountName] -> Tree AccountName+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:--- +-- -- @ --   What Ledger now does is that if an account name is too long, it will --   start abbreviating the first parts of the account name down to two@@ -166,59 +318,160 @@ --     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided! -- @ elideAccountName :: Int -> AccountName -> AccountName-elideAccountName width s = -    elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s+elideAccountName width s+  -- XXX special case for transactions register's multi-account pseudo-names+  | " (split)" `T.isSuffixOf` s =+    let+      names = T.splitOn ", " $ T.take (T.length s - 8) s+      widthpername = max 0 (width - 8 - 2 * (max 1 (length names) - 1)) `div` length names+    in+     fitText Nothing (Just width) True False $+     (<>" (split)") $+     T.intercalate ", "+     [accountNameFromComponents $ elideparts widthpername [] $ accountNameComponents s' | s' <- names]+  | otherwise =+    fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where-        elideparts :: Int -> [String] -> [String] -> [String]-        elideparts width done ss-          | length (accountNameFromComponents $ done++ss) <= width = done++ss-          | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)+        elideparts :: Int -> [Text] -> [Text] -> [Text]+        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 -clipAccountName :: Int -> AccountName -> AccountName-clipAccountName n = accountNameFromComponents . take n . accountNameComponents+-- | Keep only the first n components of an account name, where n+-- is a positive integer.+clipAccountNameTo :: Int -> AccountName -> AccountName+clipAccountNameTo n = accountNameFromComponents . take n . accountNameComponents --- | Convert an account name to a regular expression matching it and its subaccounts.-accountNameToAccountRegex :: String -> String-accountNameToAccountRegex "" = ""-accountNameToAccountRegex a = printf "^%s(:|$)" a+-- | 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) --- | Convert an account name to a regular expression matching it and its subaccounts.-accountNameToAccountOnlyRegex :: String -> String-accountNameToAccountOnlyRegex "" = ""-accountNameToAccountOnlyRegex a = printf "^%s$" a+    -- 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 --- | Convert an exact account-matching regular expression to a plain account name.-accountRegexToAccountName :: String -> String-accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1"+-- | 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 --- | Does this string look like an exact account-matching regular expression ?-isAccountRegex  :: String -> Bool-isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:("+-- | 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 -tests_Hledger_Data_AccountName = TestList- [-  "accountNameTreeFrom" ~: do-    accountNameTreeFrom ["a"]       `is` Node "top" [Node "a" []]-    accountNameTreeFrom ["a","b"]   `is` Node "top" [Node "a" [], Node "b" []]-    accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]-    accountNameTreeFrom ["a:b:c"]   `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]+-- | Escape an AccountName for use within a regular expression.+-- >>> putStr . T.unpack $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"+-- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#+escapeName :: AccountName -> Text+escapeName = T.concatMap escapeChar+  where+    escapeChar c = if c `elem` escapedChars then T.snoc "\\" c else T.singleton c+    escapedChars = ['[', '?', '+', '|', '(', ')', '*', '$', '^', '\\'] -  ,"expandAccountNames" ~:-    expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`-     ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]+-- | Convert an account name to a regular expression matching it and its subaccounts.+accountNameToAccountRegex :: AccountName -> Regexp+accountNameToAccountRegex a = toRegex' $ "^" <> escapeName a <> "(:|$)"  -- PARTIAL: Is this safe after escapeName? -  ,"isAccountNamePrefixOf" ~: do-    "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+-- | 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? -  ,"isSubAccountNameOf" ~: do-    "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+-- | Convert an account name to a regular expression matching it but not its subaccounts.+accountNameToAccountOnlyRegex :: AccountName -> Regexp+accountNameToAccountOnlyRegex a = toRegex' $ "^" <> escapeName a <> "$" -- PARTIAL: Is this safe after escapeName? +-- | 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 = 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"]+  ,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
@@ -1,465 +1,1477 @@-{-# LANGUAGE StandaloneDeriving #-}-{-|-A simple 'Amount' is some quantity of money, shares, or anything else.-It has a (possibly null) 'Commodity' and a numeric quantity:--@-  $1 -  £-50-  EUR 3.44 -  GOOG 500-  1.5h-  90 apples-  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.---}--module Hledger.Data.Amount (-  -- * Amount-  nullamt,-  amountWithCommodity,-  canonicaliseAmountCommodity,-  setAmountPrecision,-  -- ** arithmetic-  costOfAmount,-  divideAmount,-  -- ** rendering-  showAmount,-  showAmountDebug,-  showAmountWithoutPrice,-  maxprecision,-  maxprecisionwithpoint,-  -- * MixedAmount-  nullmixedamt,-  missingamt,-  amounts,-  normaliseMixedAmount,-  canonicaliseMixedAmountCommodity,-  mixedAmountWithCommodity,-  setMixedAmountPrecision,-  -- ** arithmetic-  costOfMixedAmount,-  divideMixedAmount,-  isNegativeMixedAmount,-  isZeroMixedAmount,-  isReallyZeroMixedAmountCost,-  -- ** rendering-  showMixedAmount,-  showMixedAmountDebug,-  showMixedAmountWithoutPrice,-  showMixedAmountWithPrecision,-  -- * misc.-  tests_Hledger_Data_Amount-) where--import Data.Char (isDigit)-import Data.List-import Data.Map (findWithDefault)-import Test.HUnit-import Text.Printf-import qualified Data.Map as Map--import Hledger.Data.Types-import Hledger.Data.Commodity-import Hledger.Utils---deriving instance Show HistoricalPrice------------------------------------------------------------------------------------ Amount--instance Show Amount where show = showAmount--instance Num Amount where-    abs (Amount c q p) = Amount c (abs q) p-    signum (Amount c q p) = Amount c (signum q) p-    fromInteger i = Amount (comm "") (fromInteger i) Nothing-    negate a@Amount{quantity=q} = a{quantity=(-q)}-    (+) = similarAmountsOp (+)-    (-) = similarAmountsOp (-)-    (*) = similarAmountsOp (*)---- | The empty simple amount.-nullamt :: Amount-nullamt = Amount unknown 0 Nothing---- | Apply a binary arithmetic operator to two amounts, ignoring and--- discarding any assigned prices, and converting the first to the--- commodity of the second in a simplistic way (1-1 exchange rate).--- The highest precision of either amount is preserved in the result.-similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) =-    Amount bc{precision=max ap bp} (quantity (amountWithCommodity bc a) `op` bq) Nothing---- | Convert an amount to the specified commodity, ignoring and discarding--- any assigned prices and assuming an exchange rate of 1.-amountWithCommodity :: Commodity -> Amount -> Amount-amountWithCommodity c (Amount _ q _) = Amount c q Nothing---- | 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)------ - price amounts should be positive, though this is not currently enforced-costOfAmount :: Amount -> Amount-costOfAmount a@(Amount _ q price) =-    case price of-      Nothing -> a-      Just (UnitPrice  (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*q) Nothing-      Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing-      _ -> error' "costOfAmount: Malformed price encountered, programmer error"---- | Divide an amount's quantity by a constant.-divideAmount :: Amount -> Double -> Amount-divideAmount a@Amount{quantity=q} d = a{quantity=q/d}---- | Is this amount negative ? The price is ignored.-isNegativeAmount :: Amount -> Bool-isNegativeAmount Amount{quantity=q} = q < 0---- | Does this amount appear to be zero when displayed with its given precision ?-isZeroAmount :: Amount -> Bool-isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity---- | Is this amount "really" zero, regardless of the display precision ?--- Since we are using floating point, for now just test to some high precision.-isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity-    where zeroprecision = 8---- | 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 the display precision in the amount's commodity.-setAmountPrecision :: Int -> Amount -> Amount-setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}}---- | Get the unambiguous string representation of an amount, for debugging.-showAmountDebug :: Amount -> String-showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}"-                                   (show c) (show q) (maybe "" showPriceDebug pri)---- | Get the string representation of an amount, without any \@ price.-showAmountWithoutPrice :: Amount -> String-showAmountWithoutPrice a = showAmount a{price=Nothing}---- | Get the string representation of an amount, without any price or commodity symbol.-showAmountWithoutPriceOrCommodity :: Amount -> String-showAmountWithoutPriceOrCommodity a@Amount{commodity=c} = showAmount a{commodity=c{symbol=""}, price=Nothing}--showPrice :: Price -> String-showPrice (UnitPrice pa)  = " @ "  ++ showMixedAmount pa-showPrice (TotalPrice pa) = " @@ " ++ showMixedAmount pa--showPriceDebug :: Price -> String-showPriceDebug (UnitPrice pa)  = " @ "  ++ showMixedAmountDebug pa-showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa---- | Get the string representation of an amount, based on its commodity's--- display settings. String representations equivalent to zero are--- converted to just \"0\".-showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message-showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =-    case side of-      L -> printf "%s%s%s%s" sym' space quantity' price-      R -> printf "%s%s%s%s" quantity' space sym' price-    where-      quantity = showamountquantity a-      displayingzero = null $ filter (`elem` "123456789") $ quantity-      (quantity',sym') | displayingzero = ("0","")-                       | otherwise      = (quantity,quoteCommoditySymbolIfNeeded sym)-      space = if (not (null sym') && spaced) then " " else ""-      price = maybe "" showPrice pri---- | Get the string representation of the number part of of an amount,--- using the display settings from its commodity.-showamountquantity :: Amount -> String-showamountquantity (Amount (Commodity {decimalpoint=d,precision=p,separator=s,separatorpositions=spos}) q _) =-    punctuatenumber d s spos $ qstr-    where-    -- isint n = fromIntegral (round n) == n-    qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer)-         | p == maxprecisionwithpoint    = printf "%f" q-         | p == maxprecision             = chopdotzero $ printf "%f" q-         | otherwise                    = printf ("%."++show p++"f") q---- | Replace a number string's decimal point with the specified character,--- and add the specified digit group separators.-punctuatenumber :: Char -> Char -> [Int] -> String -> String-punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac''-    where-      (sign,num) = break isDigit str-      (int,frac) = break (=='.') num-      frac' = dropWhile (=='.') frac-      frac'' | null frac' = ""-             | otherwise  = dec:frac'-      extend [] = []-      extend gs = init gs ++ repeat (last gs)-      addseps _ [] str = str-      addseps sep (g:gs) str-          | length str <= g = str-          | otherwise = let (s,rest) = splitAt g str-                        in s ++ [sep] ++ addseps sep gs rest--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---- | Replace an amount's commodity with the canonicalised version from--- the provided commodity map.-canonicaliseAmountCommodity :: Maybe (Map.Map String Commodity) -> Amount -> Amount-canonicaliseAmountCommodity Nothing                      = id-canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount-    where-      -- like journalCanonicaliseAmounts-      fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c}-      fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap------------------------------------------------------------------------------------ MixedAmount--instance Show MixedAmount where show = showMixedAmount--instance Num MixedAmount where-    fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]-    negate (Mixed as) = Mixed $ map negate as-    (+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrice $ Mixed $ as ++ bs-    (*)    = error' "programming error, mixed amounts do not support multiplication"-    abs    = error' "programming error, mixed amounts do not support abs"-    signum = error' "programming 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.-missingamt :: MixedAmount-missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing]---- | Simplify a mixed amount's component amounts: combine amounts with the--- same commodity and price, remove any zero amounts, and replace an empty--- amount list with a single zero amount.-normaliseMixedAmountPreservingPrice :: MixedAmount -> MixedAmount-normaliseMixedAmountPreservingPrice (Mixed as) = Mixed as''-    where-      as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'-      as' = map sumAmountsUsingFirstPrice $ group $ sort as-      sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2))-      group = groupBy (\a1 a2 -> sym a1 == sym a2 && price a1 == price a2)-      sym = symbol . commodity---- | Simplify a mixed amount's component amounts: combine amounts with the--- same commodity, remove any zero amounts, and replace an empty amount--- list with a single zero amount. Unlike normaliseMixedAmountPreservingPrice,--- this one discards all but the first price encountered in each commodity.--- (This is used more for display than arithmetic, but seems a bit odd. XXX)-normaliseMixedAmount :: MixedAmount -> MixedAmount-normaliseMixedAmount (Mixed as) = Mixed as''-    where -      as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'-      as' = map sumAmountsUsingFirstPrice $ group $ sort as-      sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))-      group = groupBy (\a1 a2 -> sym a1 == sym a2)-      sym = symbol . commodity--sumAmountsUsingFirstPrice [] = nullamt-sumAmountsUsingFirstPrice as = (sum as){price=price $ head as}---- | Get a mixed amount's component amounts.-amounts :: MixedAmount -> [Amount]-amounts (Mixed as) = 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 :: MixedAmount -> Double -> MixedAmount-divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) 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 $ normaliseMixedAmount m---- | Does this mixed amount appear to be zero when displayed with its given precision ?-isZeroMixedAmount :: MixedAmount -> Bool-isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount---- | Is this mixed amount "really" zero ? See isReallyZeroAmount.-isReallyZeroMixedAmount :: MixedAmount -> Bool-isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount---- | Is this mixed amount "really" zero, after converting to cost--- commodities where possible ?-isReallyZeroMixedAmountCost :: MixedAmount -> Bool-isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount---- -- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1.-mixedAmountWithCommodity :: Commodity -> MixedAmount -> Amount-mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing-    where-      total = sum $ map (quantity . amountWithCommodity c) as---- -- | 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' = normaliseMixedAmount a---           b' = normaliseMixedAmount b---- | Get the string representation of a mixed amount, showing each of--- its component amounts. NB a mixed amount can have an empty amounts--- list in which case it shows as \"\".-showMixedAmount :: MixedAmount -> String-showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m---- | 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 $ normaliseMixedAmount m---- | Get an unambiguous string representation of a mixed amount for debugging.-showMixedAmountDebug :: MixedAmount -> String-showMixedAmountDebug m = printf "Mixed [%s]" as-    where as = intercalate "\n       " $ map showAmountDebug $ amounts $ normaliseMixedAmount m---- | Get the string representation of a mixed amount, but without--- any \@ prices.-showMixedAmountWithoutPrice :: MixedAmount -> String-showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as-    where-      (Mixed as) = normaliseMixedAmount $ stripPrices m-      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing}-      width = maximum $ map (length . show) as-      showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice---- | Replace a mixed amount's commodity with the canonicalised version from--- the provided commodity map.-canonicaliseMixedAmountCommodity :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount-canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmountCommodity canonicalcommoditymap) as------------------------------------------------------------------------------------ misc--tests_Hledger_Data_Amount = TestList [--  -- Amount--   "costOfAmount" ~: do-    costOfAmount (euros 1) `is` euros 1-    costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4-    costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2-    costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2)--  ,"isZeroAmount" ~: do-    assertBool "" $ isZeroAmount $ Amount unknown 0 Nothing-    assertBool "" $ isZeroAmount $ dollars 0--  ,"negating amounts" ~: do-    let a = dollars 1-    negate a `is` a{quantity=(-1)}-    let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}-    negate b `is` b{quantity=(-1)}--  ,"adding amounts" ~: do-    let a1 = dollars 1.23-    let a2 = dollars (-1.23)-    let a3 = dollars (-1.23)-    (a1 + a2) `is` Amount (comm "$") 0 Nothing-    (a1 + a3) `is` Amount (comm "$") 0 Nothing-    (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing-    (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing-    sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing-    -- highest precision is preserved-    let ap1 = (dollars 1){commodity=dollar{precision=1}}-        ap3 = (dollars 1){commodity=dollar{precision=3}}-    (sum [ap1,ap3]) `is` ap3{quantity=2}-    (sum [ap3,ap1]) `is` ap3{quantity=2}-    -- adding different commodities assumes conversion rate 1-    assertBool "" $ isZeroAmount (a1 - euros 1.23)--  ,"showAmount" ~: do-    showAmount (dollars 0 + pounds 0) `is` "0"--  -- MixedAmount--  ,"normaliseMixedAmount" ~: do-    normaliseMixedAmount (Mixed []) `is` Mixed [nullamt]-    assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10,    price=Nothing}-                                                                    ,Amount {commodity=dollar, quantity=10,    price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}-                                                                    ,Amount {commodity=dollar, quantity=(-10), price=Nothing}-                                                                    ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}-                                                                    ])--  ,"adding mixed amounts" ~: do-    let dollar0 = dollar{precision=0}-    (sum $ map (Mixed . (\a -> [a]))-             [Amount dollar 1.25 Nothing,-              Amount dollar0 (-1) Nothing,-              Amount dollar (-0.25) Nothing])-      `is` Mixed [Amount unknown 0 Nothing]--  ,"showMixedAmount" ~: do-    showMixedAmount (Mixed [dollars 1]) `is` "$1.00"-    showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00"-    showMixedAmount (Mixed [dollars 0]) `is` "0"-    showMixedAmount (Mixed []) `is` "0"-    showMixedAmount missingamt `is` ""--  ,"showMixedAmountWithoutPrice" ~: do-    let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}-    showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"-    showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0"--  ]+{-|+A simple 'Amount' is some quantity of money, shares, or anything else.+It has a (possibly null) 'CommoditySymbol' and a numeric quantity:++@+  $1+  £-50+  EUR 3.44+  GOOG 500+  1.5h+  90 apples+  0+@++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,67 +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.---}-module Hledger.Data.Commodity-where-import Data.List-import Data.Map ((!))-import Data.Maybe-import Test.HUnit-import qualified Data.Map as Map--import Hledger.Data.Types-import Hledger.Utils---nonsimplecommoditychars = "0123456789-.@;\n \""--quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\""-                               | otherwise = s---- convenient amount and commodity constructors, for tests etc.--unknown = Commodity {symbol="", side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]}-dollar  = Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}-euro    = Commodity {symbol="€",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}-pound   = Commodity {symbol="£",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}-hour    = Commodity {symbol="h",side=R,spaced=False,decimalpoint='.',precision=1,separator=',',separatorpositions=[]}--dollars n = Amount dollar n Nothing-euros n   = Amount euro   n Nothing-pounds n  = Amount pound  n Nothing-hours n   = Amount hour   n Nothing--defaultcommodities = [dollar, euro, pound, hour, unknown]---- | Look up one of the hard-coded default commodities. For use in tests.-comm :: String -> Commodity-comm sym = fromMaybe -              (error' "commodity lookup failed") -              $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities---- | Find the conversion rate between two commodities. Currently returns 1.-conversionRate :: Commodity -> Commodity -> Double-conversionRate _ _ = 1---- | Convert a list of commodities to a map from commodity symbols to--- unique, display-preference-canonicalised commodities.-canonicaliseCommodities :: [Commodity] -> Map.Map String Commodity-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--tests_Hledger_Data_Commodity = TestList [- ]-
+ 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,685 +1,1242 @@-{-|--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.---}---- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?--module Hledger.Data.Dates-where--import Control.Monad-import Data.List-import Data.Maybe-import Data.Time.Format-import Data.Time.Calendar-import Data.Time.Calendar.OrdinalDate-import Data.Time.Clock-import Data.Time.LocalTime-import Safe (readMay)-import System.Locale (defaultTimeLocale)-import Test.HUnit-import Text.ParserCombinators.Parsec-import Text.Printf--import Hledger.Data.Types-import Hledger.Utils---showDate :: Day -> String-showDate = formatTime defaultTimeLocale "%C%y/%m/%d"---- | Get the current local date.-getCurrentDay :: IO Day-getCurrentDay = do-    t <- getZonedTime-    return $ localDay (zonedTimeToLocalTime t)---- | Get the current local month number.-getCurrentMonth :: IO Int-getCurrentMonth = do-  (_,m,_) <- toGregorian `fmap` getCurrentDay-  return m---- | Get the current local year.-getCurrentYear :: IO Integer-getCurrentYear = do-  (y,_,_) <- toGregorian `fmap` getCurrentDay-  return y--elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a-elapsedSeconds t1 = realToFrac . diffUTCTime t1---- | Split a DateSpan into one or more consecutive spans at the specified interval.-splitSpan :: Interval -> DateSpan -> [DateSpan]-splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]-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) (applyN (n-1) nextday . nextmonth) s-splitSpan (DayOfWeek n)  s = splitspan (nthdayofweekcontaining n)  (applyN (n-1) nextday . nextweek)  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---- | 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-    --- | Combine two datespans, filling any unspecified dates in the first--- with dates from the second.-orDatesFrom (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 intersection of two datespans.-spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e-    where-      b = latest b1 b2-      e = earliest 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 -> String -> Either ParseError (Interval, DateSpan)-parsePeriodExpr refdate = parsewith (periodexpr refdate)--maybePeriod :: Day -> String -> 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 -> String -> String-fixSmartDateStr d s = either-                       (\e->error' $ printf "could not parse date %s %s" (show s) (show e))-                       id-                       $ fixSmartDateStrEither d s---- | A safe version of fixSmartDateStr.-fixSmartDateStrEither :: Day -> String -> Either ParseError String-fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d--fixSmartDateStrEither' :: Day -> String -> Either ParseError Day-fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of-                               Right sd -> Right $ fixSmartDate d sd-                               Left e -> Left e---- | Convert a SmartDate to an absolute date using the provided reference date.-fixSmartDate :: Day -> SmartDate -> Day-fixSmartDate refdate sdate = fix sdate-    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--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--nthdayofmonthcontaining n d | d1 >= d    = d1-                            | otherwise = d2-    where d1 = addDays (fromIntegral n-1) s-          d2 = addDays (fromIntegral n-1) $ nextmonth s-          s = startofmonth d--nthdayofweekcontaining n d | d1 >= d    = d1-                           | otherwise = d2-    where d1 = addDays (fromIntegral n-1) s-          d2 = addDays (fromIntegral n-1) $ nextweek s-          s = startofweek d--------------------------------------------------------------------------- parsing--firstJust ms = case dropWhile (==Nothing) ms of-    [] -> Nothing-    (md:_) -> md---- | 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-    ]---- | 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 date string to a time type, or raise an error.-parsedate :: String -> Day-parsedate s =  fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"")-                         (parsedateM s)---- | Parse a time string to a time type using the provided pattern, or--- return the default.-parsetimewith :: ParseTime t => String -> String -> t -> t-parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s--{-| -Parse a date in any of the formats allowed in ledger's period expressions,-and maybe some others:--> 2004-> 2004/10-> 2004/10/1-> 10/1-> 21-> october, oct-> yesterday, today, tomorrow-> this/next/last week/day/month/quarter/year--Returns a SmartDate, to be converted to a full date later (see fixSmartDate).-Assumes any text in the parse stream has been lowercased.--}-smartdate :: GenParser Char st SmartDate-smartdate = do-  -- XXX maybe obscures date errors ? see ledgerdate-  (y,m,d) <- choice' [yyyymmdd, 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 :: GenParser Char st SmartDate-smartdateonly = do-  d <- smartdate-  many spacenonewline-  eof-  return d--datesepchars = "/-."-datesepchar = oneOf datesepchars--validYear, validMonth, validDay :: String -> Bool-validYear s = length s >= 4 && isJust (readMay s :: Maybe Int)-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 :: GenParser Char st SmartDate-yyyymmdd = do-  y <- count 4 digit-  m <- count 2 digit-  failIfInvalidMonth m-  d <- count 2 digit-  failIfInvalidDay d-  return (y,m,d)--ymd :: GenParser Char st SmartDate-ymd = do-  y <- many1 digit-  failIfInvalidYear y-  datesepchar-  m <- many1 digit-  failIfInvalidMonth m-  datesepchar-  d <- many1 digit-  failIfInvalidDay d-  return $ (y,m,d)--ym :: GenParser Char st SmartDate-ym = do-  y <- many1 digit-  failIfInvalidYear y-  datesepchar-  m <- many1 digit-  failIfInvalidMonth m-  return (y,m,"")--y :: GenParser Char st SmartDate-y = do-  y <- many1 digit-  failIfInvalidYear y-  return (y,"","")--d :: GenParser Char st SmartDate-d = do-  d <- many1 digit-  failIfInvalidDay d-  return ("","",d)--md :: GenParser Char st SmartDate-md = do-  m <- many1 digit-  failIfInvalidMonth m-  datesepchar-  d <- many1 digit-  failIfInvalidDay d-  return ("",m,d)--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"]--monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months-monIndex s   = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs--month :: GenParser Char st SmartDate-month = do-  m <- choice $ map (try . string) months-  let i = monthIndex m-  return ("",show i,"")--mon :: GenParser Char st SmartDate-mon = do-  m <- choice $ map (try . string) monthabbrevs-  let i = monIndex m-  return ("",show i,"")--today,yesterday,tomorrow :: GenParser Char st SmartDate-today     = string "today"     >> return ("","","today")-yesterday = string "yesterday" >> return ("","","yesterday")-tomorrow  = string "tomorrow"  >> return ("","","tomorrow")--lastthisnextthing :: GenParser Char st SmartDate-lastthisnextthing = do-  r <- choice [-        string "last"-       ,string "this"-       ,string "next"-      ]-  many spacenonewline  -- make the space optional for easier scripting-  p <- choice [-        string "day"-       ,string "week"-       ,string "month"-       ,string "quarter"-       ,string "year"-      ]--- XXX support these in fixSmartDate---       ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)-            -  return ("",r,p)--periodexpr :: Day -> GenParser Char st (Interval, DateSpan)-periodexpr rdate = choice $ map try [-                    intervalanddateperiodexpr rdate,-                    intervalperiodexpr,-                    dateperiodexpr rdate,-                    (return (NoInterval,DateSpan Nothing Nothing))-                   ]--intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)-intervalanddateperiodexpr rdate = do-  many spacenonewline-  i <- reportinginterval-  many spacenonewline-  s <- periodexprdatespan rdate-  return (i,s)--intervalperiodexpr :: GenParser Char st (Interval, DateSpan)-intervalperiodexpr = do-  many spacenonewline-  i <- reportinginterval-  return (i, DateSpan Nothing Nothing)--dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)-dateperiodexpr rdate = do-  many spacenonewline-  s <- periodexprdatespan rdate-  return (NoInterval, s)---- Parse a reporting interval.-reportinginterval :: GenParser Char st Interval-reportinginterval = 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"-                          many spacenonewline-                          n <- fmap read $ many1 digit-                          thsuffix-                          many spacenonewline-                          string "day"-                          many spacenonewline-                          string "of"-                          many spacenonewline-                          string "week"-                          return $ DayOfWeek n,-                       do string "every"-                          many spacenonewline-                          n <- fmap read $ many1 digit-                          thsuffix-                          many spacenonewline-                          string "day"-                          optional $ do-                            many spacenonewline-                            string "of"-                            many spacenonewline-                            string "month"-                          return $ DayOfMonth n-                    ]-    where--      thsuffix = choice' $ map string ["st","nd","rd","th"]--      -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".-      tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval-      tryinterval singular compact intcons =-          choice' [-           do string compact-              return $ intcons 1,-           do string "every"-              many spacenonewline-              string singular-              return $ intcons 1,-           do string "every"-              many spacenonewline-              n <- fmap read $ many1 digit-              many spacenonewline-              string plural-              return $ intcons n-           ]-          where plural = singular ++ "s"--periodexprdatespan :: Day -> GenParser Char st DateSpan-periodexprdatespan rdate = choice $ map try [-                            doubledatespan rdate,-                            fromdatespan rdate,-                            todatespan rdate,-                            justdatespan rdate-                           ]--doubledatespan :: Day -> GenParser Char st DateSpan-doubledatespan rdate = do-  optional (string "from" >> many spacenonewline)-  b <- smartdate-  many spacenonewline-  optional (string "to" >> many spacenonewline)-  e <- smartdate-  return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)--fromdatespan :: Day -> GenParser Char st DateSpan-fromdatespan rdate = do-  string "from" >> many spacenonewline-  b <- smartdate-  return $ DateSpan (Just $ fixSmartDate rdate b) Nothing--todatespan :: Day -> GenParser Char st DateSpan-todatespan rdate = do-  string "to" >> many spacenonewline-  e <- smartdate-  return $ DateSpan Nothing (Just $ fixSmartDate rdate e)--justdatespan :: Day -> GenParser Char st DateSpan-justdatespan rdate = do-  optional (string "in" >> many spacenonewline)-  d <- smartdate-  return $ spanFromSmartDate rdate d---- | 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--nulldate :: Day-nulldate = parsedate "0000/00/00"--tests_Hledger_Data_Dates = TestList- [--   "parsedate" ~: do-    let date1 = parsedate "2008/11/26"-    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1-    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1--  ,"period expressions" ~: do-    let todaysdate = parsedate "2008/11/26"-    let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result)-    "from aug to oct"           `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"-    "aug to oct"                `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"-    "every 3 days in aug"       `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-09-01))"-    "daily from aug"            `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)"-    "every week to 2009"        `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))"--  ,"splitSpan" ~: do-    let gives (interval, span) = (splitSpan interval span `is`)-    (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2009/01/01"]-    (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/04/01"-     ,mkdatespan "2008/04/01" "2008/07/01"-     ,mkdatespan "2008/07/01" "2008/10/01"-     ,mkdatespan "2008/10/01" "2009/01/01"-     ]-    (Quarters 1,nulldatespan) `gives`-     [nulldatespan]-    (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-    (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-    (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/01" "2008/02/01"-     ,mkdatespan "2008/02/01" "2008/03/01"-     ,mkdatespan "2008/03/01" "2008/04/01"-     ]-    (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/01" "2008/03/01"-     ,mkdatespan "2008/03/01" "2008/05/01"-     ]-    (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives`-     [mkdatespan "2007/12/31" "2008/01/07"-     ,mkdatespan "2008/01/07" "2008/01/14"-     ,mkdatespan "2008/01/14" "2008/01/21"-     ]-    (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives`-     [mkdatespan "2007/12/31" "2008/01/14"-     ,mkdatespan "2008/01/14" "2008/01/28"-     ]-    (DayOfMonth 2,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/02" "2008/02/02"-     ,mkdatespan "2008/02/02" "2008/03/02"-     ,mkdatespan "2008/03/02" "2008/04/02"-     ]-    (DayOfWeek 2,mkdatespan "2011/01/01" "2011/01/15") `gives`-     [mkdatespan "2011/01/04" "2011/01/11"-     ,mkdatespan "2011/01/11" "2011/01/18"-     ]--  ,"fixSmartDateStr" ~: do-    let gives = is . fixSmartDateStr (parsedate "2008/11/26")-    "1999-12-02"   `gives` "1999/12/02"-    "1999.12.02"   `gives` "1999/12/02"-    "1999/3/2"     `gives` "1999/03/02"-    "19990302"     `gives` "1999/03/02"-    "2008/2"       `gives` "2008/02/01"-    "0020/2"       `gives` "0020/02/01"-    "1000"         `gives` "1000/01/01"-    "4/2"          `gives` "2008/04/02"-    "2"            `gives` "2008/11/02"-    "January"      `gives` "2008/01/01"-    "feb"          `gives` "2008/02/01"-    "today"        `gives` "2008/11/26"-    "yesterday"    `gives` "2008/11/25"-    "tomorrow"     `gives` "2008/11/27"-    "this day"     `gives` "2008/11/26"-    "last day"     `gives` "2008/11/25"-    "next day"     `gives` "2008/11/27"-    "this week"    `gives` "2008/11/24" -- last monday-    "last week"    `gives` "2008/11/17" -- previous monday-    "next week"    `gives` "2008/12/01" -- next monday-    "this month"   `gives` "2008/11/01"-    "last month"   `gives` "2008/10/01"-    "next month"   `gives` "2008/12/01"-    "this quarter" `gives` "2008/10/01"-    "last quarter" `gives` "2008/07/01"-    "next quarter" `gives` "2009/01/01"-    "this year"    `gives` "2008/01/01"-    "last year"    `gives` "2007/01/01"-    "next year"    `gives` "2009/01/01"---     "last wed"     `gives` "2008/11/19"---     "next friday"  `gives` "2008/11/28"---     "next january" `gives` "2009/01/01"-- ]+{-# 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,436 +1,1378 @@-{-|--A 'Journal' is a set of 'Transaction's and related data, usually parsed-from a hledger/ledger journal file or timelog. This is the primary hledger-data object.---}--module Hledger.Data.Journal-where-import Data.List-import Data.Map (findWithDefault, (!))-import Data.Ord-import Data.Time.Calendar-import Data.Time.LocalTime-import Data.Tree-import Safe (headDef)-import System.Time (ClockTime(TOD))-import Test.HUnit-import Text.Printf-import qualified Data.Map as Map--import Hledger.Utils-import Hledger.Data.Types-import Hledger.Data.AccountName-import Hledger.Data.Amount-import Hledger.Data.Commodity (canonicaliseCommodities)-import Hledger.Data.Dates (nulldatespan)-import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction)-import Hledger.Data.Posting-import Hledger.Data.TimeLog-import Hledger.Data.Matching---instance Show Journal where-    show j = printf "Journal %s with %d transactions, %d accounts: %s"-             (journalFilePath j)-             (length (jtxns j) +-              length (jmodifiertxns j) +-              length (jperiodictxns j))-             (length accounts)-             (show accounts)-             -- ++ (show $ journalTransactions l)-             where accounts = flatten $ journalAccountNameTree j--showJournalDebug j = unlines [-                      show j-                     ,show (jtxns j)-                     ,show (jmodifiertxns j)-                     ,show (jperiodictxns j)-                     ,show $ open_timelog_entries j-                     ,show $ historical_prices j-                     ,show $ final_comment_lines j-                     ,show $ jContext j-                     ,show $ map fst $ files j-                     ]--nulljournal :: Journal-nulljournal = Journal { jmodifiertxns = []-                      , jperiodictxns = []-                      , jtxns = []-                      , open_timelog_entries = []-                      , historical_prices = []-                      , final_comment_lines = []-                      , jContext = nullctx-                      , files = []-                      , filereadtime = TOD 0 0-                      }--nullctx :: JournalContext-nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [], ctxAliases = [] }--nullfilterspec :: FilterSpec-nullfilterspec = FilterSpec {-     datespan=nulldatespan-    ,cleared=Nothing-    ,real=False-    ,empty=False-    ,acctpats=[]-    ,descpats=[]-    ,depth=Nothing-    }--journalFilePath :: Journal -> FilePath-journalFilePath = fst . mainfile--journalFilePaths :: Journal -> [FilePath]-journalFilePaths = map fst . files--mainfile :: Journal -> (FilePath, String)-mainfile = headDef ("", "") . files--addTransaction :: Transaction -> Journal -> Journal-addTransaction t l0 = l0 { jtxns = t : jtxns l0 }--addModifierTransaction :: ModifierTransaction -> Journal -> Journal-addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 }--addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal-addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 }--addHistoricalPrice :: HistoricalPrice -> Journal -> Journal-addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }--addTimeLogEntry :: TimeLogEntry -> Journal -> Journal-addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }--journalPostings :: Journal -> [Posting]-journalPostings = concatMap tpostings . jtxns--journalAccountNamesUsed :: Journal -> [AccountName]-journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings--journalAccountNames :: Journal -> [AccountName]-journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed--journalAccountNameTree :: Journal -> Tree AccountName-journalAccountNameTree = accountNameTreeFrom . journalAccountNames---- Various kinds of filtering on journals. We do it differently depending--- on the command.------------------------------------------------------------------------------------ filtering V2---- | Keep only postings matching the query expression.--- This can leave unbalanced transactions.-filterJournalPostings2 :: Matcher -> Journal -> Journal-filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}-    where-      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}---- | Keep only transactions matching the query expression.-filterJournalTransactions2 :: Matcher -> Journal -> Journal-filterJournalTransactions2 m j@Journal{jtxns=ts} = j{jtxns=filter (m `matchesTransaction`) ts}------------------------------------------------------------------------------------ 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-                                    } =-    filterJournalTransactionsByClearedStatus cleared .-    filterJournalPostingsByDepth depth .-    filterJournalTransactionsByAccount apats .-    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-                                } =-    filterJournalPostingsByRealness real .-    filterJournalPostingsByClearedStatus cleared .-    filterJournalPostingsByEmpty empty .-    filterJournalPostingsByDepth depth .-    filterJournalPostingsByAccount apats .-    filterJournalTransactionsByDescription dpats .-    filterJournalTransactionsByDate datespan---- | 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.-filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal-filterJournalTransactionsByClearedStatus Nothing j = j-filterJournalTransactionsByClearedStatus (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.-filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal-filterJournalPostingsByClearedStatus Nothing j = j-filterJournalPostingsByClearedStatus (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 l = l-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 l = l-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 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---- | 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}---- | Convert this journal's transactions' primary date to either the--- actual or effective date.-journalSelectingDate :: WhichDate -> Journal -> Journal-journalSelectingDate ActualDate j = j-journalSelectingDate EffectiveDate j =-    j{jtxns=map (journalTransactionWithDate EffectiveDate) $ jtxns j}---- | Apply additional account aliases (eg from the command-line) to all postings in a journal.-journalApplyAliases :: [(AccountName,AccountName)] -> Journal -> Journal-journalApplyAliases aliases j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}-    where-      fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}-      fixposting p@Posting{paccount=a} = p{paccount=accountNameApplyAliases aliases a}---- | Do post-parse processing on a journal, to make it ready for use.-journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal-journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} =-    journalBalanceTransactions $-    journalCanonicaliseAmounts $-    journalApplyHistoricalPrices $-    journalCloseTimeLogEntries tlocal-    j{files=(path,txt):fs, filereadtime=tclock, jContext=ctx}---- | Fill in any missing amounts and check that all journal transactions--- balance, or return an error message. This is done after parsing all--- amounts and working out the canonical commodities, since balancing--- depends on display precision. Reports only the first error encountered.-journalBalanceTransactions :: Journal -> Either String Journal-journalBalanceTransactions j@Journal{jtxns=ts} =-  case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'}-                                    Left e    -> Left e-      where balance = balanceTransaction (Just $ journalCanonicalCommodities j)---- | Convert all the journal's amounts to their canonical display--- settings.  Ie, all amounts in a given commodity will use (a) the--- display settings of the first, and (b) the greatest precision, of the--- amounts in that commodity. Prices are canonicalised as well, so consider--- calling journalApplyHistoricalPrices before this.-journalCanonicaliseAmounts :: Journal -> Journal-journalCanonicaliseAmounts j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}-    where-      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 a@Amount{commodity=c} = a{commodity=fixcommodity c}-      fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap-      canonicalcommoditymap = journalCanonicalCommodities j---- | Apply this journal's historical price records to unpriced amounts where possible.-journalApplyHistoricalPrices :: Journal -> Journal-journalApplyHistoricalPrices 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) $ journalHistoricalPriceFor 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.-journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount-journalHistoricalPriceFor j d Commodity{symbol=s} = do-  let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j-  case ps of (HistoricalPrice{hamount=a}:_) -> Just a-             _ -> Nothing---- | Close any open timelog sessions in this journal using the provided current time.-journalCloseTimeLogEntries :: LocalTime -> Journal -> Journal-journalCloseTimeLogEntries now j@Journal{jtxns=ts, open_timelog_entries=es} =-  j{jtxns = ts ++ (timeLogEntriesToTransactions now es), open_timelog_entries = []}---- | 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 journalCanonicaliseAmounts-      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 = canonicaliseAmountCommodity (Just $ journalCanonicalCommodities j) . costOfAmount---- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.-journalCanonicalCommodities :: Journal -> Map.Map String Commodity-journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j---- | Get all this journal's amounts' commodities, in the order parsed.-journalAmountCommodities :: Journal -> [Commodity]-journalAmountCommodities = map commodity . concatMap amounts . journalAmounts---- | Get all this journal's amount and price commodities, in the order parsed.-journalAmountAndPriceCommodities :: Journal -> [Commodity]-journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts---- | Get this amount's commodity and any commodities referenced in its price.-amountCommodities :: Amount -> [Commodity]-amountCommodities Amount{commodity=c,price=p} =-    case p of Nothing -> [c]-              Just (UnitPrice ma)  -> c:(concatMap amountCommodities $ amounts ma)-              Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma)---- | Get all this journal's amounts, in the order parsed.-journalAmounts :: Journal -> [MixedAmount]-journalAmounts = map pamount . journalPostings---- | The (fully specified) date span containing this journal's transactions,--- or DateSpan Nothing Nothing if there are none.-journalDateSpan :: Journal -> DateSpan-journalDateSpan j-    | null ts = DateSpan Nothing Nothing-    | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts)-    where-      ts = sortBy (comparing tdate) $ jtxns j---- | 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---- | Calculate the account tree and all account balances from a journal's--- postings, returning the results for efficient lookup.-journalAccountInfo :: Journal -> (Tree AccountName, Map.Map AccountName Account)-journalAccountInfo j = (ant, amap)-    where-      (ant, psof, _, inclbalof) = (groupPostings . journalPostings) j-      amap = Map.fromList [(a, acctinfo a) | a <- flatten ant]-      acctinfo a = Account a (psof a) (inclbalof a)---- | Given a list of postings, return an account name tree and three query--- functions that fetch postings, subaccount-excluding-balance and--- subaccount-including-balance by account name.-groupPostings :: [Posting] -> (Tree AccountName,-                             (AccountName -> [Posting]),-                             (AccountName -> MixedAmount),-                             (AccountName -> MixedAmount))-groupPostings ps = (ant, psof, exclbalof, inclbalof)-    where-      anames = sort $ nub $ map paccount ps-      ant = accountNameTreeFrom $ expandAccountNames anames-      allanames = flatten ant-      pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames])-      psof = (pmap !)-      balmap = Map.fromList $ flatten $ calculateBalances ant psof-      exclbalof = fst . (balmap !)-      inclbalof = snd . (balmap !)---- | Add subaccount-excluding and subaccount-including balances to a tree--- of account names somewhat efficiently, given a function that looks up--- transactions by account name.-calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount))-calculateBalances ant psof = addbalances ant-    where-      addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs'-          where-            bal         = sumPostings $ psof a-            subsbal     = sum $ map (snd . snd . root) subs'-            subs'       = map addbalances subs---- | Convert a list of postings to a map from account name to that--- account's postings.-postingsByAccount :: [Posting] -> Map.Map AccountName [Posting]-postingsByAccount ps = m'-    where-      sortedps = sortBy (comparing paccount) ps-      groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps-      m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]---- debug helpers-traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a-tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps--tests_Hledger_Data_Journal = TestList [- ]-+{-# 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
@@ -7,141 +7,106 @@  -} -module Hledger.Data.Ledger+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.Ledger (+   nullledger+  ,ledgerFromJournal+  ,ledgerAccountNames+  ,ledgerAccount+  ,ledgerRootAccount+  ,ledgerTopAccounts+  ,ledgerLeafAccounts+  ,ledgerPostings+  ,ledgerDateSpan+  ,ledgerCommodities+  ,tests_Ledger+) where-import Data.Map (Map, findWithDefault, fromList)-import Data.Tree-import Test.HUnit++import Data.Map qualified as M+import Safe (headDef) import Text.Printf -import Hledger.Utils+import Test.Tasty (testGroup)+import Test.Tasty.HUnit ((@?=), testCase) import Hledger.Data.Types-import Hledger.Data.Account (nullacct)-import Hledger.Data.AccountName+import Hledger.Data.Account+import Hledger.Data.Dates (nulldate) import Hledger.Data.Journal-import Hledger.Data.Posting-import Hledger.Data.Matching+import Hledger.Query   instance Show Ledger where-    show l = printf "Ledger with %d transactions, %d accounts\n%s"-             (length (jtxns $ journal l) +-              length (jmodifiertxns $ journal l) +-              length (jperiodictxns $ journal l))-             (length $ accountnames l)-             (showtree $ accountnametree l)+    show l = printf "Ledger with %d transactions, %d accounts\n" --"%s"+             (length (jtxns $ ljournal l) ++              length (jtxnmodifiers $ ljournal l) ++              length (jperiodictxns $ ljournal l))+             (length $ ledgerAccountNames l)+             -- (showtree $ ledgerAccountNameTree l)  nullledger :: Ledger-nullledger = Ledger{-      journal = nulljournal,-      accountnametree = nullaccountnametree,-      accountmap = fromList []-    }---- | Filter a journal's transactions as specified, and then process them--- to derive a ledger containing all balances, the chart of accounts,--- canonicalised commodities etc.-journalToLedger :: FilterSpec -> Journal -> Ledger-journalToLedger fs j = nullledger{journal=j',accountnametree=t,accountmap=m}-    where j' = filterJournalPostings fs{depth=Nothing} j-          (t, m) = journalAccountInfo j'+nullledger = Ledger {+  ljournal = nulljournal,+  laccounts = []+  } --- | Filter a journal's transactions as specified, and then process them--- to derive a ledger containing all balances, the chart of accounts,--- canonicalised commodities etc.--- Like journalToLedger but uses the new matchers.-journalToLedger2 :: Matcher -> Journal -> Ledger-journalToLedger2 m j = nullledger{journal=j',accountnametree=t,accountmap=amap}-    where j' = filterJournalPostings2 m j-          (t, amap) = journalAccountInfo j'+-- | 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+    -- 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. ledgerAccountNames :: Ledger -> [AccountName]-ledgerAccountNames = drop 1 . flatten . accountnametree+ledgerAccountNames = drop 1 . map aname . laccounts  -- | Get the named account from a ledger.-ledgerAccount :: Ledger -> AccountName -> Account-ledgerAccount l a = findWithDefault nullacct a $ accountmap l---- | List a ledger's accounts, in tree order-ledgerAccounts :: Ledger -> [Account]-ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999---- | List a ledger's top-level accounts, in tree order-ledgerTopAccounts :: Ledger -> [Account]-ledgerTopAccounts = map root . branches . ledgerAccountTree 9999+ledgerAccount :: Ledger -> AccountName -> Maybe (Account BalanceData)+ledgerAccount l a = lookupAccount a $ laccounts l --- | List a ledger's bottom-level (subaccount-less) accounts, in tree order-ledgerLeafAccounts :: Ledger -> [Account]-ledgerLeafAccounts = leaves . ledgerAccountTree 9999+-- | 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 BalanceData+ledgerRootAccount = headDef nullacct . laccounts --- | Accounts in ledger whose name matches the pattern, in tree order.-ledgerAccountsMatching :: [String] -> Ledger -> [Account]-ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts+-- | List a ledger's top-level accounts (the ones below the root), in tree order.+ledgerTopAccounts :: Ledger -> [Account BalanceData]+ledgerTopAccounts = asubs . headDef nullacct . laccounts --- | List a ledger account's immediate subaccounts-ledgerSubAccounts :: Ledger -> Account -> [Account]-ledgerSubAccounts l Account{aname=a} = -    map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l+-- | List a ledger's bottom-level (subaccount-less) accounts, in tree order.+ledgerLeafAccounts :: Ledger -> [Account BalanceData]+ledgerLeafAccounts = filter (null.asubs) . laccounts  -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting]-ledgerPostings = journalPostings . journal---- | Get a ledger's tree of accounts to the specified depth.-ledgerAccountTree :: Int -> Ledger -> Tree Account-ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l---- | Get a ledger's tree of accounts rooted at the specified account.-ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account)-ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l+ledgerPostings = journalPostings . ljournal  -- | 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---- | Convenience aliases.-accountnames :: Ledger -> [AccountName]-accountnames = ledgerAccountNames--account :: Ledger -> AccountName -> Account-account = ledgerAccount--accounts :: Ledger -> [Account]-accounts = ledgerAccounts--topaccounts :: Ledger -> [Account]-topaccounts = ledgerTopAccounts--accountsmatching :: [String] -> Ledger -> [Account]-accountsmatching = ledgerAccountsMatching--subaccounts :: Ledger -> Account -> [Account]-subaccounts = ledgerSubAccounts--postings :: Ledger -> [Posting]-postings = ledgerPostings--commodities :: Ledger -> Map String Commodity-commodities = journalCanonicalCommodities . journal--accounttree :: Int -> Ledger -> Tree Account-accounttree = ledgerAccountTree--accounttreeat :: Ledger -> Account -> Maybe (Tree Account)-accounttreeat = ledgerAccountTreeAt---- datespan :: Ledger -> DateSpan--- datespan = ledgerDateSpan--rawdatespan :: Ledger -> DateSpan-rawdatespan = journalDateSpan . journal+ledgerDateSpan = journalDateSpanBothDates . ljournal -ledgeramounts :: Ledger -> [MixedAmount]-ledgeramounts = journalAmounts . journal+-- | All commodities used in this ledger.+ledgerCommodities :: Ledger -> [CommoditySymbol]+ledgerCommodities = M.keys . jinferredcommoditystyles . ljournal -tests_Hledger_Data_Ledger = TestList- [- ]+-- tests +tests_Ledger =+  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/Matching.hs 
@@ -1,324 +0,0 @@-{-|--More generic matching, done in one step, unlike FilterSpec and filterJournal*. -Currently used only by hledger-web.---}--module Hledger.Data.Matching-where-import Data.Either-import Data.List--- import Data.Map (findWithDefault, (!))-import Data.Maybe--- import Data.Ord-import Data.Time.Calendar--- import Data.Time.LocalTime--- import Data.Tree-import Safe (readDef, headDef)--- import System.Time (ClockTime(TOD))-import Test.HUnit-import Text.ParserCombinators.Parsec--- import Text.Printf--- import qualified Data.Map as Map--import Hledger.Utils-import Hledger.Data.Types-import Hledger.Data.AccountName-import Hledger.Data.Amount--- import Hledger.Data.Commodity (canonicaliseCommodities)-import Hledger.Data.Dates-import Hledger.Data.Posting-import Hledger.Data.Transaction--- import Hledger.Data.TimeLog---- | A matcher is a single, or boolean composition of, search criteria,--- which can be used to match postings, transactions, accounts and more.--- Currently used by hledger-web, will likely replace FilterSpec at some point.-data Matcher = MatchAny              -- ^ always match-             | MatchNone             -- ^ never match-             | MatchNot Matcher      -- ^ negate this match-             | MatchOr [Matcher]     -- ^ match if any of these match-             | MatchAnd [Matcher]    -- ^ match if all of these match-             | MatchDesc String      -- ^ match if description matches this regexp-             | MatchAcct String      -- ^ match postings whose account matches this regexp-             | MatchDate DateSpan    -- ^ match if actual date in this date span-             | MatchEDate DateSpan   -- ^ match if effective date in this date span-             | MatchStatus Bool      -- ^ match if cleared status has this value-             | MatchReal Bool        -- ^ match if "realness" (involves a real non-virtual account ?) has this value-             | MatchEmpty Bool       -- ^ match if "emptiness" (from the --empty command-line flag) has this value.-                                     --   Currently this means a posting with zero amount.-             | MatchDepth Int        -- ^ match if account depth is less than or equal to this value-    deriving (Show, Eq)---- | A query option changes a query's/report's behaviour and output in some way.---- XXX could use regular CliOpts ?-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-           -- | QueryOptEffectiveDate  -- ^ show effective dates instead of actual dates-    deriving (Show, Eq)---- | 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 matcher for the account(s) we are currently focussed on, if any.--- Just looks at the first query option.-inAccountMatcher :: [QueryOpt] -> Maybe Matcher-inAccountMatcher [] = Nothing-inAccountMatcher (QueryOptInAcctOnly a:_) = Just $ MatchAcct $ accountNameToAccountOnlyRegex a-inAccountMatcher (QueryOptInAcct a:_) = Just $ MatchAcct $ accountNameToAccountRegex a---- -- | A matcher restricting the account(s) to be shown in the sidebar, if any.--- -- Just looks at the first query option.--- showAccountMatcher :: [QueryOpt] -> Maybe Matcher--- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ MatchAcct True $ accountNameToAccountRegex a--- showAccountMatcher _ = Nothing---- | Convert a query expression containing zero or more space-separated--- terms to a matcher and zero or more query options. A query term is either:------ 1. a search criteria, used to match transactions. This is usually a prefixed pattern such as:---    acct:REGEXP---    date:PERIODEXP---    not:desc:REGEXP------ 2. a query option, which changes behaviour in some way. There is currently one of these:---    inacct:FULLACCTNAME - should appear only once------ Multiple search criteria are AND'ed together.--- When a pattern contains spaces, it or the whole term should be enclosed in single or double quotes.--- A reference date is required to interpret relative dates in period expressions.----parseQuery :: Day -> String -> (Matcher,[QueryOpt])-parseQuery d s = (m,qopts)-  where-    terms = words'' prefixes s-    (matchers, qopts) = partitionEithers $ map (parseMatcher d) terms-    m = case matchers of []      -> MatchAny-                         (m':[]) -> m'-                         ms      -> MatchAnd ms---- | 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'' :: [String] -> String -> [String]-words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX-    where-      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline-      prefixedQuotedPattern = do-        not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")-        let allowednexts | null not' = prefixes-                         | otherwise = prefixes ++ [""]-        next <- choice' $ map string allowednexts-        let prefix = not' ++ next-        p <- quotedPattern-        return $ prefix ++ stripquotes p-      quotedPattern = do-        p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""-        return $ stripquotes p-      pattern = many (noneOf " \n\r\"")---- -- | Parse the query string as a boolean tree of match patterns.--- parseMatcher :: String -> Matcher--- parseMatcher s = either (const (MatchAny)) id $ runParser matcher () "" $ lexmatcher s---- lexmatcher :: String -> [String]--- lexmatcher s = words' s---- matcher :: GenParser String () Matcher--- matcher = undefined---- keep synced with patterns below, excluding "not"-prefixes = map (++":") [-            "inacct","inacctonly",-            "desc","acct","date","edate","status","real","empty","depth"-           ]-defaultprefix = "acct"---- | Parse a single query term as either a matcher or a query option.-parseMatcher :: Day -> String -> Either Matcher QueryOpt-parseMatcher _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s-parseMatcher _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s-parseMatcher d ('n':'o':'t':':':s) = case parseMatcher d s of-                                       Left m  -> Left $ MatchNot m-                                       Right _ -> Left MatchAny -- not:somequeryoption will be ignored-parseMatcher _ ('d':'e':'s':'c':':':s) = Left $ MatchDesc s-parseMatcher _ ('a':'c':'c':'t':':':s) = Left $ MatchAcct s-parseMatcher d ('d':'a':'t':'e':':':s) =-        case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn-                                    Right (_,span) -> Left $ MatchDate span-parseMatcher d ('e':'d':'a':'t':'e':':':s) =-        case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn-                                    Right (_,span) -> Left $ MatchEDate span-parseMatcher _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ MatchStatus $ parseStatus s-parseMatcher _ ('r':'e':'a':'l':':':s) = Left $ MatchReal $ parseBool s-parseMatcher _ ('e':'m':'p':'t':'y':':':s) = Left $ MatchEmpty $ parseBool s-parseMatcher _ ('d':'e':'p':'t':'h':':':s) = Left $ MatchDepth $ readDef 0 s-parseMatcher _ "" = Left $ MatchAny-parseMatcher d s = parseMatcher d $ defaultprefix++":"++s---- | Parse the boolean value part of a "status:" matcher, allowing "*" as--- another way to spell True, similar to the journal file format.-parseStatus :: String -> Bool-parseStatus s = s `elem` (truestrings ++ ["*"])---- | Parse the boolean value part of a "status:" matcher. A true value can--- be spelled as "1", "t" or "true".-parseBool :: String -> Bool-parseBool s = s `elem` truestrings--truestrings :: [String]-truestrings = ["1","t","true"]---- | Convert a match expression to its inverse.-negateMatcher :: Matcher -> Matcher-negateMatcher =  MatchNot---- | Does the match expression match this posting ?-matchesPosting :: Matcher -> Posting -> Bool-matchesPosting (MatchNot m) p = not $ matchesPosting m p-matchesPosting (MatchAny) _ = True-matchesPosting (MatchNone) _ = False-matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms-matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms-matchesPosting (MatchDesc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p-matchesPosting (MatchAcct r) p = regexMatchesCI r $ paccount p-matchesPosting (MatchDate span) p =-    case d of Just d'  -> spanContainsDate span d'-              Nothing -> False-    where d = maybe Nothing (Just . tdate) $ ptransaction p-matchesPosting (MatchEDate span) p =-    case postingEffectiveDate p of Just d  -> spanContainsDate span d-                                   Nothing -> False-matchesPosting (MatchStatus v) p = v == postingCleared p-matchesPosting (MatchReal v) p = v == isReal p-matchesPosting (MatchEmpty v) Posting{pamount=a} = v == isZeroMixedAmount a-matchesPosting _ _ = False---- | Does the match expression match this transaction ?-matchesTransaction :: Matcher -> Transaction -> Bool-matchesTransaction (MatchNot m) t = not $ matchesTransaction m t-matchesTransaction (MatchAny) _ = True-matchesTransaction (MatchNone) _ = False-matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms-matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms-matchesTransaction (MatchDesc r) t = regexMatchesCI r $ tdescription t-matchesTransaction m@(MatchAcct _) t = any (m `matchesPosting`) $ tpostings t-matchesTransaction (MatchDate span) t = spanContainsDate span $ tdate t-matchesTransaction (MatchEDate span) t = spanContainsDate span $ transactionEffectiveDate t-matchesTransaction (MatchStatus v) t = v == tstatus t-matchesTransaction (MatchReal v) t = v == hasRealPostings t-matchesTransaction _ _ = False--postingEffectiveDate :: Posting -> Maybe Day-postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p---- | Does the match expression match this account ?--- A matching in: clause is also considered a match.-matchesAccount :: Matcher -> AccountName -> Bool-matchesAccount (MatchNot m) a = not $ matchesAccount m a-matchesAccount (MatchAny) _ = True-matchesAccount (MatchNone) _ = False-matchesAccount (MatchOr ms) a = any (`matchesAccount` a) ms-matchesAccount (MatchAnd ms) a = all (`matchesAccount` a) ms-matchesAccount (MatchAcct r) a = regexMatchesCI r a-matchesAccount _ _ = False---- | What start date does this matcher specify, if any ?--- If the matcher is an OR expression, returns the earliest of the alternatives.--- When the flag is true, look for a starting effective date instead.-matcherStartDate :: Bool -> Matcher -> Maybe Day-matcherStartDate effective (MatchOr ms) = earliestMaybeDate $ map (matcherStartDate effective) ms-matcherStartDate effective (MatchAnd ms) = latestMaybeDate $ map (matcherStartDate effective) ms-matcherStartDate False (MatchDate (DateSpan (Just d) _)) = Just d-matcherStartDate True (MatchEDate (DateSpan (Just d) _)) = Just d-matcherStartDate _ _ = Nothing---- | Does this matcher specify a start date and nothing else (that would--- filter postings prior to the date) ?--- When the flag is true, look for a starting effective date instead.-matcherIsStartDateOnly :: Bool -> Matcher -> Bool-matcherIsStartDateOnly _ MatchAny = False-matcherIsStartDateOnly _ MatchNone = False-matcherIsStartDateOnly effective (MatchOr ms) = and $ map (matcherIsStartDateOnly effective) ms-matcherIsStartDateOnly effective (MatchAnd ms) = and $ map (matcherIsStartDateOnly effective) ms-matcherIsStartDateOnly False (MatchDate (DateSpan (Just _) _)) = True-matcherIsStartDateOnly True (MatchEDate (DateSpan (Just _) _)) = True-matcherIsStartDateOnly _ _ = False---- | Does this matcher match everything ?-matcherIsNull MatchAny = True-matcherIsNull (MatchAnd []) = True-matcherIsNull (MatchNot (MatchOr [])) = True-matcherIsNull _ = False---- | What is the earliest of these dates, where Nothing is earliest ?-earliestMaybeDate :: [Maybe Day] -> Maybe Day-earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates---- | What is the latest of these dates, where Nothing is earliest ?-latestMaybeDate :: [Maybe Day] -> Maybe Day-latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)---- | 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--tests_Hledger_Data_Matching :: Test-tests_Hledger_Data_Matching = TestList- [--  "parseQuery" ~: do-    let d = parsedate "2011/1/1"-    parseQuery d "a" `is` (MatchAcct "a", [])-    parseQuery d "acct:a" `is` (MatchAcct "a", [])-    parseQuery d "acct:a desc:b" `is` (MatchAnd [MatchAcct "a", MatchDesc "b"], [])-    parseQuery d "\"acct:expenses:autres d\233penses\"" `is` (MatchAcct "expenses:autres d\233penses", [])-    parseQuery d "not:desc:'a b'" `is` (MatchNot $ MatchDesc "a b", [])--    parseQuery d "inacct:a desc:b" `is` (MatchDesc "b", [QueryOptInAcct "a"])-    parseQuery d "inacct:a inacct:b" `is` (MatchAny, [QueryOptInAcct "a", QueryOptInAcct "b"])--    parseQuery d "status:1" `is` (MatchStatus True, [])-    parseQuery d "status:0" `is` (MatchStatus False, [])-    parseQuery d "status:" `is` (MatchStatus False, [])-    parseQuery d "real:1" `is` (MatchReal True, [])--  ,"matchesAccount" ~: do-    assertBool "positive acct match" $ matchesAccount (MatchAcct "b:c") "a:bb:c:d"-    -- assertBool "acct should match at beginning" $ not $ matchesAccount (MatchAcct True "a:b") "c:a:b"--  ,"matchesPosting" ~: do-    -- matching posting status..-    assertBool "positive match on true posting status"  $-                   (MatchStatus True)  `matchesPosting` nullposting{pstatus=True}-    assertBool "negative match on true posting status"  $-               not $ (MatchNot $ MatchStatus True)  `matchesPosting` nullposting{pstatus=True}-    assertBool "positive match on false posting status" $-                   (MatchStatus False) `matchesPosting` nullposting{pstatus=False}-    assertBool "negative match on false posting status" $-               not $ (MatchNot $ MatchStatus False) `matchesPosting` nullposting{pstatus=False}-    assertBool "positive match on true posting status acquired from transaction" $-                   (MatchStatus True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}}-    assertBool "real:1 on real posting" $ (MatchReal True) `matchesPosting` nullposting{ptype=RegularPosting}-    assertBool "real:1 on virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=VirtualPosting}-    assertBool "real:1 on balanced virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}--  ,"words''" ~: do-    assertEqual "1" ["a","b"]        (words'' [] "a b")-    assertEqual "2" ["a b"]          (words'' [] "'a b'")-    assertEqual "3" ["not:a","b"]    (words'' [] "not:a b")-    assertEqual "4" ["not:a b"]    (words'' [] "not:'a b'")-    assertEqual "5" ["not:a b"]    (words'' [] "'not:a b'")-    assertEqual "6" ["not:desc:a b"]    (words'' ["desc:"] "not:desc:'a b'")-- ]
+ Hledger/Data/Period.hs view
@@ -0,0 +1,355 @@+{-|++Manipulate the time periods typically used for reports with Period,+a richer abstraction than DateSpan. See also Types and Dates.++-}++{-# 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+import Data.Time.Calendar.WeekDate+import Data.Time.Format+import Text.Printf++import Hledger.Data.Types++-- | Convert Periods to exact DateSpans.+--+-- >>> 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 $ 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 $ Flex $ fromGregorian y m 1) (Just $ Flex $ fromGregorian y' m' 1)+  where+    (y', q') | q==4      = (y+1,1)+             | otherwise = (y,q+1)+    quarterAsMonth q2 = (q2-1) * 3 + 1+    m  = quarterAsMonth q+    m' = quarterAsMonth q'+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 $ 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 (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.+--+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 1 1 1) (fromGregorian 2 1 1)+-- YearPeriod 1+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 10 1) (fromGregorian 2001 1 1)+-- QuarterPeriod 2000 4+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 1) (fromGregorian 2000 3 1)+-- MonthPeriod 2000 2+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2016 7 25) (fromGregorian 2016 8 1)+-- WeekPeriod 2016-07-25+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 1 1) (fromGregorian 2000 1 2)+-- DayPeriod 2000-01-01+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 28) (fromGregorian 2000 3 1)+-- PeriodBetween 2000-02-28 2000-03-01+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 29) (fromGregorian 2000 3 1)+-- DayPeriod 2000-02-29+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 12 31) (fromGregorian 2001 1 1)+-- DayPeriod 2000-12-31+--+simplifyPeriod :: Period -> Period+simplifyPeriod (PeriodBetween b e) =+  case (toGregorian b, toGregorian e) of+    -- a year+    ((by,1,1), (ey,1,1))   | by+1==ey           -> YearPeriod by+    -- a half-year+    -- ((by,1,1), (ey,7,1))   | by==ey             ->+    -- ((by,7,1), (ey,1,1))   | by+1==ey           ->+    -- a quarter+    ((by,1,1), (ey,4,1))   | by==ey             -> QuarterPeriod by 1+    ((by,4,1), (ey,7,1))   | by==ey             -> QuarterPeriod by 2+    ((by,7,1), (ey,10,1))  | by==ey             -> QuarterPeriod by 3+    ((by,10,1), (ey,1,1))  | by+1==ey           -> QuarterPeriod by 4+    -- a month+    ((by,bm,1), (ey,em,1)) | by==ey && bm+1==em -> MonthPeriod by bm+    ((by,12,1), (ey,1,1))  | by+1==ey           -> MonthPeriod by 12+    -- a week (two successive mondays),+    -- YYYYwN ("week N of year YYYY")+    -- _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate from, toWeekDate to) in by==ey && fw+1==tw && bd==1 && ed==1 ->+    -- a week starting on a monday+    _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate b, toWeekDate (addDays (-1) e))+        in by==ey && bw==ew && bd==1 && ed==7   -> WeekPeriod b+    -- a day+    ((by,bm,bd), (ey,em,ed)) |+        (by==ey && bm==em && bd+1==ed) ||+        (by+1==ey && bm==12 && em==1 && bd==31 && ed==1) || -- crossing a year boundary+        (by==ey && bm+1==em && isLastDayOfMonth by bm bd && ed==1) -- crossing a month boundary+         -> DayPeriod b+    _ -> PeriodBetween b e+simplifyPeriod p = p++isLastDayOfMonth y m d =+  case m of+    1 -> d==31+    2 | isLeapYear y -> d==29+      | otherwise    -> d==28+    3 -> d==31+    4 -> d==30+    5 -> d==31+    6 -> d==30+    7 -> d==31+    8 -> d==31+    9 -> d==30+    10 -> d==31+    11 -> d==30+    12 -> d==31+    _ -> False++-- | Is this period a "standard" period, referencing a particular day, week, month, quarter, or year ?+-- Periods of other durations, or infinite duration, or not starting on a standard period boundary, are not.+isStandardPeriod = isStandardPeriod' . simplifyPeriod+  where+    isStandardPeriod' (DayPeriod _) = True+    isStandardPeriod' (WeekPeriod _) = True+    isStandardPeriod' (MonthPeriod _ _) = True+    isStandardPeriod' (QuarterPeriod _ _) = True+    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-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 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+showPeriodAbbrev (WeekPeriod b) = T.pack $ formatTime defaultTimeLocale "W%V" b -- Www+showPeriodAbbrev p = showPeriod p++periodStart :: Period -> Maybe Day+periodStart p = fromEFDay <$> mb+  where+    DateSpan mb _ = periodAsDateSpan p++periodEnd :: Period -> Maybe Day+periodEnd p = fromEFDay <$> me+  where+    DateSpan _ me = periodAsDateSpan p++-- | Move a standard period to the following period of same duration.+-- Non-standard periods are unaffected.+periodNext :: Period -> Period+periodNext (DayPeriod b) = DayPeriod (addDays 1 b)+periodNext (WeekPeriod b) = WeekPeriod (addDays 7 b)+periodNext (MonthPeriod y 12) = MonthPeriod (y+1) 1+periodNext (MonthPeriod y m) = MonthPeriod y (m+1)+periodNext (QuarterPeriod y 4) = QuarterPeriod (y+1) 1+periodNext (QuarterPeriod y q) = QuarterPeriod y (q+1)+periodNext (YearPeriod y) = YearPeriod (y+1)+periodNext p = p++-- | Move a standard period to the preceding period of same duration.+-- Non-standard periods are unaffected.+periodPrevious :: Period -> Period+periodPrevious (DayPeriod b) = DayPeriod (addDays (-1) b)+periodPrevious (WeekPeriod b) = WeekPeriod (addDays (-7) b)+periodPrevious (MonthPeriod y 1) = MonthPeriod (y-1) 12+periodPrevious (MonthPeriod y m) = MonthPeriod y (m-1)+periodPrevious (QuarterPeriod y 1) = QuarterPeriod (y-1) 4+periodPrevious (QuarterPeriod y q) = QuarterPeriod y (q-1)+periodPrevious (YearPeriod y) = YearPeriod (y-1)+periodPrevious p = p++-- | 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 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++-- | 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 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++-- | Move a standard period stepwise so that it encloses the given date.+-- Non-standard periods are unaffected.+periodMoveTo :: Day -> Period -> Period+periodMoveTo d (DayPeriod _) = DayPeriod d+periodMoveTo d (WeekPeriod _) = WeekPeriod $ mondayBefore d+periodMoveTo d (MonthPeriod _ _) = MonthPeriod y m where (y,m,_) = toGregorian d+periodMoveTo d (QuarterPeriod _ _) = QuarterPeriod y q+  where+    (y,m,_) = toGregorian d+    q = quarterContainingMonth m+periodMoveTo d (YearPeriod _) = YearPeriod y where (y,_,_) = toGregorian d+periodMoveTo _ p = p++-- | Enlarge a standard period to the next larger enclosing standard period, if there is one.+-- Eg, a day becomes the enclosing week.+-- A week becomes whichever month the week's thursday falls into.+-- A year becomes all (unlimited).+-- Non-standard periods (arbitrary dates, or open-ended) are unaffected.+periodGrow :: Period -> Period+periodGrow (DayPeriod b) = WeekPeriod $ mondayBefore b+periodGrow (WeekPeriod b) = MonthPeriod y m+  where (y,m) = yearMonthContainingWeekStarting b+periodGrow (MonthPeriod y m) = QuarterPeriod y (quarterContainingMonth m)+periodGrow (QuarterPeriod y _) = YearPeriod y+periodGrow (YearPeriod _) = PeriodAll+periodGrow p = p++-- | Shrink a period to the next smaller standard period inside it,+-- choosing the subperiod which contains today's date if possible,+-- otherwise the first subperiod. It goes like this:+-- unbounded periods and nonstandard periods (between two arbitrary dates) ->+-- current year ->+-- current quarter if it's in selected year, otherwise first quarter of selected year ->+-- current month if it's in selected quarter, otherwise first month of selected quarter ->+-- current week if it's in selected month, otherwise first week of selected month ->+-- today if it's in selected week, otherwise first day of selected week,+--  unless that's in previous month, in which case first day of month containing selected week.+-- Shrinking a day has no effect.+periodShrink :: Day -> Period -> Period+periodShrink _     p@(DayPeriod _) = p+periodShrink today (WeekPeriod b)+  | today >= b && diffDays today b < 7 = DayPeriod today+  | m /= weekmonth                     = DayPeriod $ fromGregorian weekyear weekmonth 1+  | otherwise                          = DayPeriod b+  where+    (_,m,_) = toGregorian b+    (weekyear,weekmonth) = yearMonthContainingWeekStarting b+periodShrink today (MonthPeriod y m)+  | (y',m') == (y,m) = WeekPeriod $ mondayBefore today+  | otherwise        = WeekPeriod $ startOfFirstWeekInMonth y m+  where (y',m',_) = toGregorian today+periodShrink today (QuarterPeriod y q)+  | quarterContainingMonth thismonth == q = MonthPeriod y thismonth+  | otherwise                             = MonthPeriod y (firstMonthOfQuarter q)+  where (_,thismonth,_) = toGregorian today+periodShrink today (YearPeriod y)+  | y == thisyear = QuarterPeriod y thisquarter+  | otherwise     = QuarterPeriod y 1+  where+    (thisyear,thismonth,_) = toGregorian today+    thisquarter = quarterContainingMonth thismonth+periodShrink today _ = YearPeriod y+  where (y,_,_) = toGregorian today++mondayBefore d = addDays (1 - toInteger wd) d+  where+    (_,_,wd) = toWeekDate d++thursdayOfWeekContaining = (addDays 3).mondayBefore++yearMonthContainingWeekStarting weekstart = (y,m)+  where+    thu = addDays 3 weekstart+    (y,yd) = toOrdinalDate thu+    (m,_) = dayOfYearToMonthAndDay (isLeapYear y) yd++quarterContainingMonth m = (m-1) `div` 3 + 1++firstMonthOfQuarter q = (q-1)*3 + 1++startOfFirstWeekInMonth y m+  | monthstartday <= 4 = mon+  | otherwise          = addDays 7 mon  -- month starts with a fri/sat/sun+  where+    monthstart = fromGregorian y m 1+    mon = mondayBefore monthstart+    (_,_,monthstartday) = toWeekDate monthstart+
+ 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
@@ -0,0 +1,253 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-|++A 'PeriodicTransaction' is a rule describing recurring transactions.++-}+module Hledger.Data.PeriodicTransaction (+    runPeriodicTransaction+  , checkPeriodicTransactionStartDate+)+where++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, generatedTransactionTagName)+import Hledger.Data.Transaction++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Hledger.Data.Posting+-- >>> import Hledger.Data.Journal++-- doctest helper, too much hassle to define in the comment+-- XXX duplicates some logic in periodictransactionp+_ptgen str = 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] }+      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, %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)+      ("ptcomment=" ++ show ptcomment)+      ("pttags=" ++ show pttags)+      ("ptpostings=" ++ show ptpostings)++-- A basic human-readable rendering.+--showPeriodicTransaction t = "~ " ++ T.unpack (ptperiodexpr t) ++ "\n" ++ unlines (map show (ptpostings t))++--nullperiodictransaction is defined in Types.hs++-- | 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+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017-02-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 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+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017-02-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017-03-01+--     ; generated-transaction: ~ monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 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-02-02+--     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04+--     a           $1.00+-- <BLANKLINE>+-- 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"+-- 2017-01-30+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017-02-28+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017-03-30+--     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 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"+-- 2017-01-12+--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017-02-09+--     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 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"+-- 2017-11-29+--     ; generated-transaction: ~ every nov 29th from 2017 to 2019+--     a           $1.00+-- <BLANKLINE>+-- 2018-11-29+--     ; generated-transaction: ~ every nov 29th from 2017 to 2019+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "2017/1"+-- 2017-01-01+--     ; generated-transaction: ~ 2017/1+--     a           $1.00+-- <BLANKLINE>+--+-- >>> 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))+-- []+--+-- >>> _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+    t = nulltransaction{+           tsourcepos   = ptsourcepos+          ,tstatus      = ptstatus+          ,tcode        = ptcode+          ,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,+-- 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 =+  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+    where+      checkStart d x =+        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 "++show x++---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?+--periodTransactionInterval :: PeriodicTransaction -> Maybe Interval+--periodTransactionInterval pt =+--  let+--    expr = ptperiodexpr pt+--    err  = error' $ "Current date cannot be referenced in " ++ show (T.unpack expr)+--  in+--    case parsePeriodExpr err expr of+--      Left _      -> Nothing+--      Right (i,_) -> Just i
Hledger/Data/Posting.hs view
@@ -1,61 +1,363 @@ {-| -A 'Posting' represents a 'MixedAmount' being added to or subtracted from a-single 'Account'.  Each 'Transaction' contains two or more postings which-should add up to 0. Postings also reference their parent transaction, so-we can get a date or description for a posting (from the transaction).-Strictly speaking, \"entry\" is probably a better name for these.+A 'Posting' represents a change (by some 'MixedAmount') of the balance in+some 'Account'.  Each 'Transaction' contains two or more postings which+should add up to 0. Postings reference their parent transaction, so we can+look up the date or description there.  -} -module Hledger.Data.Posting+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.Posting (+  -- * Posting+  nullposting,+  posting,+  post,+  vpost,+  post',+  vpost',+  nullassertion,+  balassert,+  balassertTot,+  balassertParInc,+  balassertTotInc,+  -- * operations+  originalPosting,+  postingStatus,+  isReal,+  isVirtual,+  isBalancedVirtual,+  isEmptyPosting,+  hasBalanceAssignment,+  hasAmount,+  postingAllTags,+  transactionAllTags,+  relatedPostings,+  postingStripCosts,+  postingApplyAliases,+  postingApplyCommodityStyles,+  postingStyleAmounts,+  postingAddTags,+  postingAddHiddenAndMaybeVisibleTag,+  -- * date operations+  postingDate,+  postingDate2,+  postingDateOrDate2,+  -- * account name operations+  accountNamesFromPostings,+  -- * 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.+  postingTransformAmount,+  postingApplyValuation,+  postingToCost,+  postingAddInferredEquityPostings,+  postingPriceDirectivesFromCost,+  postingCommodities,+  tests_Posting+) where-import Data.List-import Data.Ord-import Data.Time.Calendar-import Safe-import Test.HUnit-import Text.Printf +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 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.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  -instance Show Posting where show = showPosting+-- | 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 -nullposting :: Posting-nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing+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+                ,pdate2=Nothing+                ,pstatus=Unmarked+                ,paccount=""+                ,pamount=nullmixedamt+                ,pcomment=""+                ,ptype=RegularPosting+                ,ptags=[]+                ,pbalanceassertion=Nothing+                ,ptransaction=Nothing+                ,poriginal=Nothing+                }+posting = nullposting++-- constructors++-- | Make a posting to an account.+post :: AccountName -> Amount -> Posting+post acc amt = posting {paccount=acc, pamount=mixedAmount amt}++-- | Make a virtual (unbalanced) posting to an account.+vpost :: AccountName -> Amount -> Posting+vpost acc amt = (post acc amt){ptype=VirtualPosting}++-- | 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=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}++nullassertion :: BalanceAssertion+nullassertion = BalanceAssertion+                  {baamount=nullamt+                  ,batotal=False+                  ,bainclusive=False+                  ,baposition=initialPos ""+                  }++-- | Make a partial, exclusive balance assertion.+balassert :: Amount -> Maybe BalanceAssertion+balassert amt = Just $ nullassertion{baamount=amt}++-- | Make a total, exclusive balance assertion.+balassertTot :: Amount -> Maybe BalanceAssertion+balassertTot amt = Just $ nullassertion{baamount=amt, batotal=True}++-- | Make a partial, inclusive balance assertion.+balassertParInc :: Amount -> Maybe BalanceAssertion+balassertParInc amt = Just $ nullassertion{baamount=amt, bainclusive=True}++-- | Make a total, inclusive balance assertion.+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+ showPosting :: Posting -> String-showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =-    concatTopPadded [showaccountname a ++ " ", showamount amt, comment]-    where-      ledger3ishlayout = False-      acctnamewidth = if ledger3ishlayout then 25 else 22-      showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width-      (bracket,width) = case t of-                          BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)-                          VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)-                          _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmount-      comment = if null com then "" else "  ; " ++ com--- XXX refactor-showPostingForRegister :: Posting -> String-showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) =-    concatTopPadded [showaccountname a ++ " ", showamount amt]-    where-      ledger3ishlayout = False-      acctnamewidth = if ledger3ishlayout then 25 else 22-      showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width-      (bracket,width) = case t of-                          BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)-                          VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)-                          _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmountWithoutPrice+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++-- | 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 @@ -66,103 +368,244 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting  hasAmount :: Posting -> Bool-hasAmount = (/= missingamt) . 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 . map paccount+accountNamesFromPostings = S.toList . S.fromList . map paccount +-- | Sum all amounts from a list of postings. sumPostings :: [Posting] -> MixedAmount-sumPostings = sum . map pamount+sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt +-- | 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 = maybe nulldate tdate $ ptransaction p+postingDate p = fromMaybe nulldate $ asum dates+    where dates = [ pdate p, tdate <$> ptransaction p ] --- |Is this posting cleared? If this posting was individually marked--- as cleared, returns True. Otherwise, return the parent--- transaction's cleared status or, if there is no parent--- transaction, return False.-postingCleared :: Posting -> Bool-postingCleared p = if pstatus p-                    then True-                    else maybe False tstatus $ 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 = fromMaybe nulldate $ asum dates+  where dates = [ pdate2 p+                , tdate2 =<< ptransaction p+                , pdate p+                , tdate <$> ptransaction p+                ] --- | Does this posting fall within the given date span ?-isPostingInDateSpan :: DateSpan -> Posting -> Bool-isPostingInDateSpan s = spanContainsDate s . postingDate+-- | 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+-- unmarked" or "posting is unmarked and don't know about the transaction".+postingStatus :: Posting -> Status+postingStatus Posting{pstatus=s, ptransaction=mt} = case s of+    Unmarked -> maybe Unmarked tstatus mt+    _ -> s++-- | 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 (which includes any from the postings' accounts).+transactionAllTags :: Transaction -> [Tag]+transactionAllTags t = ttags t ++ concatMap ptags (tpostings t)++-- Get the other postings from this posting's transaction.+relatedPostings :: Posting -> [Posting]+relatedPostings p@Posting{ptransaction=Just t} = filter (/= p) $ tpostings t+relatedPostings _ = []+ isEmptyPosting :: Posting -> Bool-isEmptyPosting = isZeroMixedAmount . pamount+isEmptyPosting = mixedAmountLooksZero . pamount --- | Get the minimal date span which contains all the postings, or--- DateSpan Nothing Nothing 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' = sortBy (comparing postingDate) ps+-- | 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 --- AccountName stuff that depends on PostingType+-- | 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} -accountNamePostingType :: AccountName -> PostingType-accountNamePostingType a-    | null a = RegularPosting-    | head a == '[' && last a == ']' = BalancedVirtualPosting-    | head a == '(' && last a == ')' = VirtualPosting-    | otherwise = RegularPosting+-- | 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 -accountNameWithoutPostingType :: AccountName -> AccountName-accountNameWithoutPostingType a = case accountNamePostingType a of-                                    BalancedVirtualPosting -> init $ tail a-                                    VirtualPosting -> init $ tail a-                                    RegularPosting -> a+-- | 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 -accountNameWithPostingType :: PostingType -> AccountName -> AccountName-accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]"-accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")"-accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a+-- | 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 --- | Prefix one account name to another, preserving posting type--- indicators like concatAccountNames.-joinAccountNames :: AccountName -> AccountName -> AccountName-joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b]+-- | 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 --- | 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 $ intercalate ":" $ map accountNameWithoutPostingType as-    where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as+-- | 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 --- | Rewrite an account name using the first applicable alias from the given list, if any.-accountNameApplyAliases :: [(AccountName,AccountName)] -> AccountName -> AccountName-accountNameApplyAliases aliases a = withorigtype-    where-      (a',t) = (accountNameWithoutPostingType a, accountNamePostingType a)-      firstmatchingalias = headDef Nothing $ map Just $ filter (\(orig,_) -> orig == a' || orig `isAccountNamePrefixOf` a') aliases-      rewritten = maybe a' (\(orig,alias) -> alias++drop (length orig) a') firstmatchingalias-      withorigtype = accountNameWithPostingType t rewritten+-- | 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} -tests_Hledger_Data_Posting = TestList [+-- | 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 -  "accountNamePostingType" ~: do-    accountNamePostingType "a" `is` RegularPosting-    accountNamePostingType "(a)" `is` VirtualPosting-    accountNamePostingType "[a]" `is` BalancedVirtualPosting+-- | 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 - ,"accountNameWithoutPostingType" ~: do-    accountNameWithoutPostingType "(a)" `is` "a"+-- | 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+    c'  = T.stripEnd c+    tag = t <> ":" <> v - ,"accountNameWithPostingType" ~: do-    accountNameWithPostingType VirtualPosting "[a]" `is` "(a)"+-- | 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 - ,"joinAccountNames" ~: do-    "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" - ,"concatAccountNames" ~: do-    concatAccountNames [] `is` ""-    concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"+-- tests++tests_Posting = testGroup "Posting" [++  testCase "accountNamePostingType" $ do+    accountNamePostingType "a" @?= RegularPosting+    accountNamePostingType "(a)" @?= VirtualPosting+    accountNamePostingType "[a]" @?= BalancedVirtualPosting++ ,testCase "accountNameWithoutPostingType" $ do+    accountNameWithoutPostingType "(a)" @?= "a"++ ,testCase "accountNameWithPostingType" $ do+    accountNameWithPostingType VirtualPosting "[a]" @?= "(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"++ ,testCase "concatAccountNames" $ do+    concatAccountNames [] @?= ""+    concatAccountNames ["a","(b)","[c:d]"] @?= "(a:b:c:d)"++ ,testCase "commentAddTag" $ do+    commentAddTag "" ("a","") @?= "a: "+    commentAddTag "[1/2]" ("a","") @?= "[1/2], a: "++ ,testCase "commentAddTagNextLine" $ do+    commentAddTagNextLine "" ("a","") @?= "\na: "+    commentAddTagNextLine "[1/2]" ("a","") @?= "[1/2]\na: "   ]
+ Hledger/Data/RawOptions.hs view
@@ -0,0 +1,166 @@+{-|++hledger's cmdargs modes parse command-line arguments to an+intermediate format, RawOpts (an association list), rather than a+fixed ADT like CliOpts. This allows the modes and flags to be reused+more easily by hledger commands/scripts in this and other packages.++-}++module Hledger.Data.RawOptions (+  RawOpts,+  mkRawOpts,+  overRawOpts,+  dropRawOpt,+  setopt,+  setboolopt,+  unsetboolopt,+  appendopts,+  boolopt,+  toggleopt,+  choiceopt,+  collectopts,+  stringopt,+  maybestringopt,+  listofstringopt,+  intopt,+  posintopt,+  maybeintopt,+  maybeposintopt,+  maybecharopt,+  maybeynopt,+  maybeynaopt,+)+where++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.+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 = overRawOpts (++ [(name, val)])++setboolopt :: String -> RawOpts -> RawOpts+setboolopt name = overRawOpts (++ [(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 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 = lookup name . reverse . unRawOpts++stringopt :: String -> RawOpts -> String+stringopt name = fromMaybe "" . maybestringopt name++maybecharopt :: String -> RawOpts -> Maybe Char+maybecharopt name (RawOpts rawopts) = lookup name rawopts >>= headMay++listofstringopt :: String -> RawOpts -> [String]+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 = 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
@@ -0,0 +1,192 @@+-- | Parse format strings provided by --format, with awareness of+-- hledger's report item fields. The formats are used by+-- report-specific renderers like renderBalanceReportItem.++{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++module Hledger.Data.StringFormat (+          parseStringFormat+        , defaultStringFormatStyle+        , StringFormat(..)+        , StringFormatComponent(..)+        , ReportItemField(..)+        , defaultBalanceLineFormat+        , tests_StringFormat+        ) where++import Numeric (readDec)+import Data.Char (isPrint)+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 (char, digitChar, string)++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.+--+-- A format is a sequence of components; each is either a literal+-- string, or a hledger report item field with specified width and+-- justification whose value will be interpolated at render time.+--+-- A component's value may be a multi-line string (or a+-- multi-commodity amount), in which case the final string will be+-- either single-line or a top or bottom-aligned multi-line string+-- depending on the StringFormat variant used.+--+-- Currently this is only used in the balance command's single-column+-- 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)+  | BottomAligned [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded)+  deriving (Show, Eq)++data StringFormatComponent =+    FormatLiteral Text          -- ^ Literal text to be rendered as-is+  | FormatField Bool+                (Maybe Int)+                (Maybe Int)+                ReportItemField -- ^ A data field to be formatted and interpolated. Parameters:+                                --+                                -- - Left justify ? Right justified if false+                                -- - Minimum width ? Will be space-padded if narrower than this+                                -- - Maximum width ? Will be clipped if wider than this+                                -- - Which of the standard hledger report item fields to interpolate+  deriving (Show, Eq)++-- | An id identifying which report item field to interpolate.  These+-- are drawn from several hledger report types, so are not all+-- applicable for a given report.+data ReportItemField =+    AccountField      -- ^ A posting or balance report item's account name+  | DefaultDateField  -- ^ A posting or register or entry report item's date+  | DescriptionField  -- ^ A posting or register or entry report item's description+  | TotalField        -- ^ A balance or posting report item's balance or running total.+                      --   Always rendered right-justified.+  | DepthSpacerField  -- ^ A balance report item's indent level (which may be different from the account name depth).+                      --   Rendered as this number of spaces, multiplied by the minimum width spec if any.+  | 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+-- renderStringFormat fmt params =++----------------------------------------------------------------------++-- | Parse a string format specification, or return a parse error.+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 :: SimpleTextParser StringFormat+stringformatp = do+  alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String))+  let constructor =+        case alignspec of+          Just '^' -> TopAligned+          Just '_' -> BottomAligned+          Just ',' -> OneLine+          _        -> defaultStringFormatStyle+  constructor <$> many componentp++componentp :: SimpleTextParser StringFormatComponent+componentp = formatliteralp <|> formatfieldp++formatliteralp :: SimpleTextParser StringFormatComponent+formatliteralp = do+    s <- T.pack <$> some c+    return $ FormatLiteral s+    where+      isPrintableButNotPercentage x = isPrint x && x /= '%'+      c =     (satisfy isPrintableButNotPercentage <?> "printable character")+          <|> try (string "%%" >> return '%')++formatfieldp :: SimpleTextParser StringFormatComponent+formatfieldp = do+    char '%'+    leftJustified <- optional (char '-')+    minWidth <- optional (some $ digitChar)+    maxWidth <- optional (do char '.'; some $ digitChar) -- TODO: Can this be (char '1') *> (some digitChar)+    char '('+    f <- fieldp+    char ')'+    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 :: SimpleTextParser ReportItemField+fieldp = do+        try (string "account" >> return AccountField)+    <|> try (string "depth_spacer" >> return DepthSpacerField)+    <|> try (string "date" >> return DescriptionField)+    <|> try (string "description" >> return DescriptionField)+    <|> try (string "total" >> return TotalField)+    <|> try ((FieldNo . read) <$> some digitChar)++----------------------------------------------------------------------++formatStringTester fs value expected = actual @?= expected+  where+    actual = case fs of+      FormatLiteral l                 -> formatText False Nothing Nothing l+      FormatField leftJustify mn mx _ -> formatText leftJustify mn mx value++tests_StringFormat = testGroup "StringFormat" [++   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"++  ,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 (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 (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 (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 (Just 0) (Just 10) TotalField+                                                                     ])+    , testCase "newline not parsed" $ assertLeft $ parseStringFormat "\n"+    ]+ ]
− Hledger/Data/TimeLog.hs 
@@ -1,129 +0,0 @@-{-|--A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog-file (see timeclock.el or the command-line version). These can be-converted to 'Transactions' and queried like a ledger.---}--module Hledger.Data.TimeLog-where-import Data.Maybe-import Data.Time.Calendar-import Data.Time.Clock-import Data.Time.Format-import Data.Time.LocalTime-import System.Locale (defaultTimeLocale)-import Test.HUnit-import Text.Printf--import Hledger.Utils-import Hledger.Data.Types-import Hledger.Data.Dates-import Hledger.Data.Commodity-import Hledger.Data.Transaction--instance Show TimeLogEntry where -    show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t)--instance Show TimeLogCode where -    show SetBalance = "b"-    show SetRequiredHours = "h"-    show In = "i"-    show Out = "o"-    show FinalOut = "O"--instance Read TimeLogCode 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 _ _ = []---- | 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.-timeLogEntriesToTransactions :: LocalTime -> [TimeLogEntry] -> [Transaction]-timeLogEntriesToTransactions _ [] = []-timeLogEntriesToTransactions now [i]-    | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now [i',o]-    | otherwise = [entryFromTimeLogInOut i o]-    where-      o = TimeLogEntry 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}}-timeLogEntriesToTransactions now (i:o:rest)-    | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now (i':o:rest)-    | otherwise = entryFromTimeLogInOut i o : timeLogEntriesToTransactions 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}}---- | Convert a timelog 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.-entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction-entryFromTimeLogInOut i o-    | otime >= itime = t-    | otherwise = -        error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t-    where-      t = Transaction {-            tdate         = idate,-            teffectivedate = Nothing,-            tstatus       = True,-            tcode         = "",-            tdescription  = showtime itod ++ "-" ++ showtime otod,-            tcomment      = "",-            tmetadata     = [],-            tpostings = ps,-            tpreceding_comment_lines=""-          }-      showtime = take 5 . show-      acctname = tlcomment i-      itime    = tldatetime i-      otime    = tldatetime o-      itod     = localTimeOfDay itime-      otod     = localTimeOfDay otime-      idate    = localDay itime-      hrs      = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc-      amount   = Mixed [hours hrs]-      ps       = [Posting{pstatus=False,paccount=acctname,pamount=amount,-                          pcomment="",ptype=VirtualPosting,pmetadata=[],ptransaction=Just t}]--tests_Hledger_Data_TimeLog = TestList [--   "timeLogEntriesToTransactions" ~: do-     today <- getCurrentDay-     now' <- getCurrentTime-     tz <- getCurrentTimeZone-     let now = utcToLocalTime tz now'-         nowstr = showtime now-         yesterday = prevday today-         clockin = TimeLogEntry In-         mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S"-         showtime = formatTime defaultTimeLocale "%H:%M"-         assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions now es)--     assertEntriesGiveStrings "started yesterday, split session at midnight"-                                  [clockin (mktime yesterday "23:00:00") ""]-                                  ["23:00-23:59","00:00-"++nowstr]-     assertEntriesGiveStrings "split multi-day sessions at each midnight"-                                  [clockin (mktime (addDays (-2) today) "23:00:00") ""]-                                  ["23:00-23:59","00:00-23:59","00:00-"++nowstr]-     assertEntriesGiveStrings "auto-clock-out if needed" -                                  [clockin (mktime today "00:00:00") ""] -                                  ["00:00-"++nowstr]-     let future = utcToLocalTime tz $ addUTCTime 100 now'-         futurestr = showtime future-     assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future"-                                  [clockin future ""]-                                  [printf "%s-%s" futurestr futurestr]-- ]
+ Hledger/Data/Timeclock.hs view
@@ -0,0 +1,305 @@+{-|++A 'TimeclockEntry' is a clock-in, clock-out, or other directive in a timeclock+file (see timeclock.el or the command-line version). These can be+converted to 'Transactions' and queried like a ledger.++-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Hledger.Data.Timeclock (+   timeclockToTransactions+  ,timeclockToTransactionsOld+  ,tests_Timeclock+)+where++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.Data.Types+import Hledger.Data.Dates+import Hledger.Data.Amount+import Hledger.Data.Posting++-- 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)++instance Show TimeclockCode where+  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 _ _ = []++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 :: Bool -> TimeclockEntry -> TimeclockEntry -> Transaction+entryFromTimeclockInOut requiretimeordered i o+    | not requiretimeordered || otime >= itime = t+    | otherwise =+      -- 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, tlsourcepos i),+            tdate        = idate,+            tdate2       = Nothing,+            tstatus      = Cleared,+            tcode        = "",+            tdescription = desc,+            tcomment     = tlcomment i <> tlcomment o,+            ttags        = tltags i ++ tltags o,+            tpostings    = ps,+            tprecedingcomment=""+          }+      itime    = tldatetime i+      otime    = tldatetime o+      itod     = localTimeOfDay itime+      otod     = localTimeOfDay otime+      idate    = localDay itime+      desc     | T.null (tldescription i) = T.pack $ showtime itod ++ "-" ++ showtime otod+               | otherwise                = tldescription i+      showtime = take 5 . show+      hours    = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc+      acctname = tlaccount i+      -- 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 = 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
@@ -1,54 +1,159 @@ {-| -A 'Transaction' consists of two or more related 'Posting's which balance-to zero, representing a movement of some commodity(ies) between accounts,-plus a date and optional metadata like description and cleared status.+A 'Transaction' represents a movement of some commodity(ies) between two+or more accounts. It consists of multiple account 'Posting's which balance+to zero, a date, and optional extras like description, cleared status, and+tags.  -} +{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+ module Hledger.Data.Transaction-where-import Data.List-import Data.Maybe-import Data.Time.Calendar-import Test.HUnit-import Text.Printf-import qualified Data.Map as Map+( -- * 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.Commodity+import Hledger.Data.Valuation+import Data.Decimal (normalizeDecimal, decimalPlaces)+import Data.Functor ((<&>))+import Data.Function ((&))+import Data.List (union) -instance Show Transaction where show = showTransactionUnelided -instance Show ModifierTransaction where -    show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))+-- | 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. -instance Show PeriodicTransaction where -    show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))+  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,-                    teffectivedate=Nothing, -                    tstatus=False, -                    tcode="", -                    tdescription="", +                    tdate2=Nothing,+                    tstatus=Unmarked,+                    tcode="",+                    tdescription="",                     tcomment="",-                    tmetadata=[],+                    ttags=[],                     tpostings=[],-                    tpreceding_comment_lines=""+                    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)++ {-|-Show a journal transaction, formatted for the print command. ledger 2.x's-standard format looks like this:+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...............]+yyyy-mm-dd[ *][ CODE] description.........          [  ; comment...............]     account name 1.....................  ...$amount1[  ; comment...............]     account name 2.....................  ..$-amount1[  ; comment...............] @@ -58,54 +163,44 @@ 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 -> String-showTransaction = showTransaction' True+showTransaction :: Transaction -> Text+showTransaction = TL.toStrict . TB.toLazyText . showTransactionHelper False -showTransactionUnelided :: Transaction -> String-showTransactionUnelided = showTransaction' 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 -showTransaction' :: Bool -> Transaction -> String-showTransaction' elide t =-    unlines $ [description] ++ showpostings (tpostings t) ++ [""]-    where-      description = concat [date, status, code, desc, comment]-      date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)-      showdate = printf "%-10s" . showDate-      showedate = printf "=%s" . showdate-      status = if tstatus t then " *" else ""-      code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""-      desc = if null d then "" else " " ++ d where d = tdescription t-      comment = if null c then "" else "  ; " ++ c where c = tcomment t-      showpostings ps-          | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check-              = map showposting (init ps) ++ [showpostingnoamt (last ps)]-          | otherwise = map showposting ps-          where-            showpostingnoamt p = rstrip $ showacct p ++ "              " ++ showcomment (pcomment p)-            showposting p = concatTopPadded [showacct p-                                            ,"  "-                                            ,showamt (pamount p)-                                            ,showcomment (pcomment p)-                                            ]-            showacct p = "    " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))-                where w = maximum $ map (length . paccount) ps-                      showstatus p = if pstatus p then "* " else ""-            showamt =-                padleft 12 . showMixedAmount-            showcomment s = if null s then "" else "  ; "++s+-- | 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' --- | 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'-      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse-      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse-      w' = fromMaybe 999999 w-      parenthesise s = "("++s++")"-      bracket s = "["++s++"]"+-- 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@@ -113,6 +208,9 @@ realPostings :: Transaction -> [Posting] realPostings = filter isReal . tpostings +assignmentPostings :: Transaction -> [Posting]+assignmentPostings = filter hasBalanceAssignment . tpostings+ virtualPostings :: Transaction -> [Posting] virtualPostings = filter isVirtual . tpostings @@ -120,298 +218,498 @@ balancedVirtualPostings = filter isBalancedVirtual . tpostings  transactionsPostings :: [Transaction] -> [Posting]-transactionsPostings = concat . map tpostings+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)+-- Get a transaction's secondary date, or the primary date if there is none.+transactionDate2 :: Transaction -> Day+transactionDate2 t = fromMaybe (tdate t) $ tdate2 t --- | Is this transaction balanced ? A balanced transaction's real--- (non-virtual) postings sum to 0, and any balanced virtual postings--- also sum to 0.-isTransactionBalanced :: Maybe (Map.Map String Commodity) -> Transaction -> Bool-isTransactionBalanced canonicalcommoditymap t =-    -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum-    isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'-    where-      (rsum, _, bvsum) = transactionPostingBalances t-      rsum'  = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum-      bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum+-- Get a transaction's primary or secondary date, as specified.+transactionDateOrDate2 :: WhichDate -> Transaction -> Day+transactionDateOrDate2 PrimaryDate   = tdate+transactionDateOrDate2 SecondaryDate = transactionDate2 --- | Ensure this transaction is balanced, possibly inferring a missing--- amount or a conversion price first, or return an error message.+-- | 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. ----- Balancing is affected by the provided commodities' display precisions.+-- 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. ----- We can infer an amount when there are multiple real postings and--- exactly one of them is amountless; likewise for balanced virtual--- postings. Inferred amounts are converted to cost basis when possible.+-- The name reflects the complexity of this and its helpers; clarification is ongoing. ----- We can infer a price when all amounts were specified and the sum of--- real postings' amounts is exactly two non-explicitly-priced amounts in--- different commodities; likewise for balanced virtual postings.-balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction-balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps}-    | length rwithoutamounts > 1 || length bvwithoutamounts > 1-        = Left $ printerr "could not balance this transaction (too many missing amounts)"-    | not $ isTransactionBalanced canonicalcommoditymap t''' = Left $ printerr $ nonzerobalanceerror t'''-    | otherwise = Right t'''-    where-      -- maybe infer missing amounts-      (rwithamounts, rwithoutamounts)   = partition hasAmount $ realPostings t-      (bvwithamounts, bvwithoutamounts) = partition hasAmount $ balancedVirtualPostings t-      ramounts  = map pamount rwithamounts-      bvamounts = map pamount bvwithamounts-      t' = t{tpostings=map inferamount ps}-          where -            inferamount p | not (hasAmount p) && isReal p            = p{pamount = (- sum ramounts)}-                          | not (hasAmount p) && isBalancedVirtual p = p{pamount = (- sum bvamounts)}-                          | otherwise                             = p+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 -      -- maybe infer conversion prices, for real postings-      rmixedamountsinorder = map pamount $ realPostings t'-      ramountsinorder = concatMap amounts rmixedamountsinorder-      rcommoditiesinorder  = map commodity ramountsinorder-      rsumamounts  = amounts $ sum rmixedamountsinorder-      -- assumption: the sum of mixed amounts is normalised (one simple amount per commodity)-      t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t-             then t'{tpostings=map inferprice ps}-             else t'-          where-            -- assumption: a posting's mixed amount contains one simple amount-            inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=RegularPosting}-                = p{pamount=Mixed [a{price=conversionprice c}]}-                where-                  conversionprice c | c == unpricedcommodity-                                        -- assign a balancing price. Use @@ for more exact output when possible.-                                        -- invariant: prices should always be positive. Enforced with "abs"-                                        = if length ramountsinunpricedcommodity == 1-                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]-                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]-                                    | otherwise = Nothing-                      where-                        unpricedcommodity     = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder-                        unpricedamount        = head $ filter ((==unpricedcommodity).commodity) rsumamounts-                        targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) rsumamounts-                        ramountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) ramountsinorder-            inferprice p = p+  -- Identify all pairs of conversion postings and all other postings (with and without costs) in the transaction.+  (conversionPairs, otherps) <- partitionAndCheckConversionPostings False conversionaccts npostings -      -- maybe infer prices for balanced virtual postings. Just duplicates the above for now.-      bvmixedamountsinorder = map pamount $ balancedVirtualPostings t''-      bvamountsinorder = concatMap amounts bvmixedamountsinorder-      bvcommoditiesinorder  = map commodity bvamountsinorder-      bvsumamounts  = amounts $ sum bvmixedamountsinorder-      t''' = if length bvsumamounts == 2 && all (isNothing.price) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring-             then t''{tpostings=map inferprice ps}-             else t''-          where-            inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=BalancedVirtualPosting}-                = p{pamount=Mixed [a{price=conversionprice c}]}-                where-                  conversionprice c | c == unpricedcommodity-                                        = if length bvamountsinunpricedcommodity == 1-                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]-                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]-                                    | otherwise = Nothing-                      where-                        unpricedcommodity     = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder-                        unpricedamount        = head $ filter ((==unpricedcommodity).commodity) bvsumamounts-                        targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) bvsumamounts-                        bvamountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) bvamountsinorder-            inferprice p = p+  -- 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 -      printerr s = intercalate "\n" [s, showTransactionUnelided t]+  -- And if there was no error, use it to modify the transaction's postings.+  return t{tpostings = map (snd . processposting) npostings} -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 " ++ show (costOfMixedAmount rsum)-      bvmsg | isReallyZeroMixedAmountCost bvsum = ""-            | otherwise = "balanced virtual postings are off by " ++ show (costOfMixedAmount bvsum)-      sep = if not (null rmsg) && not (null bvmsg) then "; " else ""+  where -transactionActualDate :: Transaction -> Day-transactionActualDate = tdate+    -- 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) --- Get a transaction's effective date, defaulting to the actual date.-transactionEffectiveDate :: Transaction -> Day-transactionEffectiveDate t = fromMaybe (tdate t) $ teffectivedate t+    -- 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 --- | Once we no longer need both, set the main transaction date to either--- the actual or effective date. A bit hacky.-journalTransactionWithDate :: WhichDate -> Transaction -> Transaction-journalTransactionWithDate ActualDate t = t-journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=transactionEffectiveDate t}+        -- 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] --- | Ensure a transaction's postings refer back to it.-txnTieKnot :: Transaction -> Transaction-txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}+        -- 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) --- | Set a posting's parent transaction.-settxn :: Transaction -> Posting -> Posting-settxn t p = p{ptransaction=Just t}+      -- 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)) -tests_Hledger_Data_Transaction = TestList [-  "showTransaction" ~: do-     assertEqual "show a balanced transaction, eliding last amount"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking"-        ,""-        ])-       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-                [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t)-                ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t)-                ] ""-        in showTransaction t)+          -- 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)) -  ,"showTransaction" ~: do-     assertEqual "show a balanced transaction, no eliding"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking               $-47.18"-        ,""-        ])-       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-                [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] (Just t)-                ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] (Just t)-                ] ""-        in showTransactionUnelided t)+          -- 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)) -     -- document some cases that arise in debug/testing:-  ,"showTransaction" ~: do-     assertEqual "show an unbalanced transaction, should not elide"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking               $-47.19"-        ,""-        ])-       (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing-         ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting [] Nothing-         ] ""))+    -- 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<>" ?")  -  ,"showTransaction" ~: do-     assertEqual "show an unbalanced transaction with one posting, should not elide"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,""-        ])-       (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing-         ] ""))+    -- 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 -  ,"showTransaction" ~: do-     assertEqual "show a transaction with one posting and a missing amount"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries              "-        ,""-        ])-       (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-         [Posting False "expenses:food:groceries" missingamt "" RegularPosting [] 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:" -  ,"showTransaction" ~: do-     assertEqual "show a transaction with a priced commodityless amount"-       (unlines-        ["2010/01/01 x"-        ,"    a        1 @ $2"-        ,"    b              "-        ,""-        ])-       (showTransaction-        (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []-         [Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing-         ,Posting False "b" missingamt "" RegularPosting [] Nothing-         ] ""))+    -- Do these amounts look the same when compared at the first's display precision ?+    amountsMatch a b = amountLooksZero $ amountSetPrecision (asprecision $ astyle a) $ a - b -  ,"balanceTransaction" ~: do-     assertBool "detect unbalanced entry, sign error"-                    (isLeft $ balanceTransaction Nothing-                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []-                            [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,-                             Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing-                            ] ""))-     assertBool "detect unbalanced entry, multiple missing amounts"-                    (isLeft $ balanceTransaction Nothing-                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []-                            [Posting False "a" missingamt "" RegularPosting [] Nothing,-                             Posting False "b" missingamt "" RegularPosting [] Nothing-                            ] ""))-     let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []-                           [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,-                            Posting False "b" missingamt "" RegularPosting [] Nothing-                           ] "")-     assertBool "balanceTransaction allows one missing amount" (isRight e)-     assertEqual "balancing amount is inferred"-                     (Mixed [dollars (-1)])-                     (case e of-                        Right e' -> (pamount $ last $ tpostings e')-                        Left _ -> error' "should not happen")-     let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []-                           [Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing,-                            Posting False "b" (Mixed [euros   (-1)]) "" RegularPosting [] Nothing-                           ] "")-     assertBool "balanceTransaction can infer conversion price" (isRight e)-     assertEqual "balancing conversion price is inferred"-                     (Mixed [Amount{commodity=dollar{precision=2},-                                    quantity=1.35,-                                    price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=maxprecision},-                                                                             quantity=1,-                                                                             price=Nothing}])}])-                     (case e of-                        Right e' -> (pamount $ head $ tpostings e')-                        Left _ -> error' "should not happen")+    -- 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 -  ,"isTransactionBalanced" ~: do-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)-             ] ""-     assertBool "detect balanced" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting [] (Just t)-             ] ""-     assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ] ""-     assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 0]) "" RegularPosting [] (Just t)-             ] ""-     assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)-             ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting [] (Just t)-             ] ""-     assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)-             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t)-             ] ""-     assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []-             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)-             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)-             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t)-             ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting [] (Just t)-             ] ""-     assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)+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
@@ -0,0 +1,158 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-|++A 'TransactionModifier' is a rule that modifies certain 'Transaction's,+typically adding automated postings to them.++-}+module Hledger.Data.TransactionModifier (+   modifyTransactions+)+where++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.Amount+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+-- >>> import Hledger.Data.Posting+-- >>> import Hledger.Data.Transaction+-- >>> import Hledger.Data.Journal++-- | Apply all the given transaction modifiers, in turn, to each transaction.+-- 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++  Right $ map modifytxn ts++-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function+-- which applies the modification(s) specified by the TransactionModifier.+-- 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).+--+-- 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  ; generated-posting: =+-- <BLANKLINE>+-- >>> test $ TransactionModifier "miss" ["pong" `tmpost` usd 2]+-- 0000-01-01+--     ping           $1.00+-- <BLANKLINE>+-- >>> test $ TransactionModifier "ping" [("pong" `tmpost` nullamt{aquantity=3}){tmprIsMultiplier=True}]+-- 0000-01-01+--     ping           $1.00+--     pong           $3.00  ; generated-posting: = ping+-- <BLANKLINE>+--+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.+-- 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+    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" . 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` 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+              "" -> 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  -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, acost = acost pramount}) as++postingRuleMultiplier :: TMPostingRule -> Maybe Quantity+postingRuleMultiplier tmpr = case amountsRaw . pamount $ tmprPosting tmpr of+    [a] | tmprIsMultiplier tmpr -> Just $ aquantity a+    _                           -> Nothing++renderPostingCommentDates :: Posting -> Posting+renderPostingCommentDates p = p { pcomment = comment' }+    where+        dates = T.concat $ catMaybes [showDate <$> pdate p, ("=" <>) . showDate <$> pdate2 p]+        comment'+            | T.null dates = pcomment p+            | otherwise    = (wrap "[" "]" dates) `commentJoin` pcomment p
Hledger/Data/Types.hs view
@@ -1,205 +1,855 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-|+  {-|  Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model:  > Journal                  -- a journal is read from one or more data files. It contains..->  [Transaction]           -- journal transactions (aka entries), which have date, status, code, description and..+>  [Transaction]           -- journal transactions (aka entries), which have date, cleared status, code, description and.. >   [Posting]              -- multiple account postings, which have account name and amount->  [HistoricalPrice]       -- historical commodity prices+>  [MarketPrice]           -- historical market prices for commodities > > Ledger                   -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. >  Journal                 -- a filtered copy of the original journal, containing only the transactions and postings we are interested in->  Tree AccountName        -- all accounts named by the journal's transactions, as a hierarchy->  Map AccountName Account -- the postings, and resulting balances, in each account+>  [Account]               -- all accounts, in tree order beginning with a "root" account", with their balances and sub/parent accounts  For more detailed documentation on each type, see the corresponding modules. -Evolution of transaction\/entry\/posting terminology:+-} -  - ledger 2:    entries contain transactions+-- {-# 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           #-} -  - hledger 0.4: Entrys contain RawTransactions (which are flattened to Transactions)+module Hledger.Data.Types (+  module Hledger.Data.Types,+#if MIN_VERSION_time(1,11,0)+  Year+#endif+)+where -  - ledger 3:    transactions contain postings+import GHC.Generics (Generic)+import Control.DeepSeq (NFData(..))+import Data.Bifunctor (first)+import Data.Decimal (Decimal, DecimalRaw(..))+import Data.Default (Default(..))+import Data.Functor (($>))+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 Data.Map qualified as M+import Data.Ord (comparing)+import Data.Semigroup (Min(..))+import Data.Text (Text)+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) -  - hledger 0.5: LedgerTransactions contain Postings (which are flattened to Transactions)+import Hledger.Utils.Regex -  - hledger 0.8: Transactions contain Postings (referencing Transactions..) --}+-- 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+type MonthWeek = Int -- 1-5+type YearDay = Int   -- 1-366+type MonthDay = Int  -- 1-31+type WeekDay = Int   -- 1-7 -module Hledger.Data.Types-where-import Control.Monad.Error (ErrorT)-import Data.Time.Calendar-import Data.Time.LocalTime-import Data.Tree-import Data.Typeable-import qualified Data.Map as Map-import System.Time (ClockTime)+-- | 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) -type SmartDate = (String,String,String)+data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data WhichDate = ActualDate | EffectiveDate 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) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)+-- EFDay's Ord instance treats them like ordinary dates, ignoring exact/flexible.+instance Ord EFDay where compare d1 d2 = compare (fromEFDay d1) (fromEFDay d2) -data Interval = NoInterval-              | Days Int | Weeks Int | Months Int | Quarters Int | Years Int-              | DayOfMonth Int | DayOfWeek Int-              -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int-                deriving (Eq,Show,Ord)+-- instance Ord EFDay where compare = maCompare -type AccountName = String+fromEFDay :: EFDay -> Day+fromEFDay (Exact d) = d+fromEFDay (Flex  d) = d -data Side = L | R deriving (Eq,Show,Read,Ord)+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+  | MonthPeriod Year Month+  | QuarterPeriod Year Quarter+  | YearPeriod Year+  | PeriodBetween Day Day+  | PeriodFrom Day+  | PeriodTo Day+  | PeriodAll+  deriving (Eq,Ord,Show,Generic)++instance Default Period where def = PeriodAll++-- All the kinds of report interval allowed in a period expression+-- (to generate periodic reports or periodic transactions).+data Interval =+    NoInterval+  | Days Int+  | Weeks Int+  | Months Int+  | Quarters Int+  | Years Int+  | 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++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+  | 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 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+--    readsPrec _ ('A' : xs) = [(Asset,     xs)]+--    readsPrec _ ('L' : xs) = [(Liability, xs)]+--    readsPrec _ ('E' : xs) = [(Equity,    xs)]+--    readsPrec _ ('R' : xs) = [(Revenue,   xs)]+--    readsPrec _ ('X' : xs) = [(Expense,   xs)]+--    readsPrec _ _ = []++data AccountAlias = BasicAlias AccountName AccountName+                  | RegexAlias Regexp Replacement+  deriving (Eq, Read, Show, Ord, Generic)++data Side = L | R deriving (Eq,Show,Read,Ord,Generic)++-- | One of the decimal marks we support: either period or comma.+type DecimalMark = Char++isDecimalMark :: Char -> Bool+isDecimalMark c = c == '.' || c == ','++-- | The basic numeric type used in amounts.+type Quantity = Decimal+-- 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+deriving instance Generic (DecimalRaw a)++-- | 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 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,                     -- ^ 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{..} = 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 ![Word8]+  deriving (Eq,Ord,Read,Show,Generic)++type CommoditySymbol = Text+ data Commodity = Commodity {-      symbol :: String,            -- ^ the commodity's symbol-      -- display preferences for amounts of this commodity-      side :: Side,                -- ^ should the symbol appear on the left or the right-      spaced :: Bool,              -- ^ should there be a space between symbol and quantity-      precision :: Int,            -- ^ number of decimal places to display-      -- XXX these three might be better belonging to Journal-      decimalpoint :: Char,        -- ^ character to use as decimal point-      separator :: Char,           -- ^ character to use for separating digit groups (eg thousands)-      separatorpositions :: [Int]  -- ^ positions of separators, counting leftward from decimal point-    } deriving (Eq,Ord,Show,Read)+  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) --- | An amount's price in another commodity may be written as \@ unit--- price or \@\@ total price.  Note although a MixedAmount is used, it--- should be in a single commodity, also the amount should be positive;--- these are not enforced currently.-data Price = UnitPrice MixedAmount | TotalPrice MixedAmount-             deriving (Eq,Ord)+-- | 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 {-      commodity :: Commodity,-      quantity :: Double,-      price :: Maybe Price  -- ^ the price for this amount at posting time-    } deriving (Eq,Ord)+  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) -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord)+-- | 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 +instance HasAmounts a =>+  HasAmounts [a]+  where styleAmounts styles = map (styleAmounts styles)++instance (HasAmounts a, HasAmounts b) =>+  HasAmounts (a,b)+  where styleAmounts styles (aa,bb) = (styleAmounts styles aa, styleAmounts styles bb)++instance HasAmounts a =>+  HasAmounts (Maybe a)+  where styleAmounts styles = fmap (styleAmounts styles)+++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)+                   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,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.+--+-- A balance assignments is an instruction to hledger to adjust an+-- account's balance to a certain amount at a certain point.+--+-- The 'BalanceAssertion' type is used for representing both of these.+--+-- 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  :: SourcePos  -- ^ the assertion's file position, for error reporting+    } deriving (Eq,Generic,Show)+ data Posting = Posting {-      pstatus :: Bool,-      paccount :: AccountName,-      pamount :: MixedAmount,-      pcomment :: String,-      ptype :: PostingType,-      pmetadata :: [(String,String)],-      ptransaction :: Maybe Transaction  -- ^ this posting's parent transaction (co-recursive types).-                                        -- Tying this knot gets tedious, Maybe makes it easier/optional.-    }+      pdate             :: Maybe Day,         -- ^ this posting's date, if different from the transaction's+      pdate2            :: Maybe Day,         -- ^ this posting's secondary date, if different from the transaction's+      pstatus           :: Status,+      paccount          :: AccountName,+      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 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 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 (Generic)  -- The equality test for postings ignores the parent transaction's--- identity, to avoid infinite loops.+-- identity, to avoid recurring ad infinitum.+-- XXX could check that it's Just or Nothing. instance Eq Posting where-    (==) (Posting a1 b1 c1 d1 e1 f1 _) (Posting a2 b2 c2 d2 e2 f2 _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2+    (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _ _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _ _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2 +-- | Posting's show instance elides the parent transaction so as not to recurse forever.+instance Show Posting where+  show Posting{..} = "PostingPP {" ++ intercalate ", " [+     "pdate="             ++ show (show pdate)+    ,"pdate2="            ++ show (show pdate2)+    ,"pstatus="           ++ show (show pstatus)+    ,"paccount="          ++ show paccount+    ,"pamount="           ++ show pamount+    ,"pcomment="          ++ show pcomment+    ,"ptype="             ++ show ptype+    ,"ptags="             ++ show ptags+    ,"pbalanceassertion=" ++ show pbalanceassertion+    ,"ptransaction="      ++ show (ptransaction $> "txn")+    ,"poriginal="         ++ show poriginal+    ] ++ "}"+ data Transaction = Transaction {-      tdate :: Day,-      teffectivedate :: Maybe Day,-      tstatus :: Bool,  -- XXX tcleared ?-      tcode :: String,-      tdescription :: String,-      tcomment :: String,-      tmetadata :: [(String,String)],-      tpostings :: [Posting],            -- ^ this transaction's postings (co-recursive types).-      tpreceding_comment_lines :: String-    } deriving (Eq)+      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               :: (SourcePos, SourcePos),  -- ^ the file position where the date starts, and where the last posting ends+      tdate                    :: Day,+      tdate2                   :: Maybe Day,+      tstatus                  :: Status,+      tcode                    :: Text,+      tdescription             :: Text,+      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,Generic,Show) -data ModifierTransaction = ModifierTransaction {-      mtvalueexpr :: String,-      mtpostings :: [Posting]-    } deriving (Eq)+-- | A transaction modifier rule. This has a query which matches postings+-- 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.+data TransactionModifier = TransactionModifier {+      tmquerytxt :: Text,+      tmpostingrules :: [TMPostingRule]+    } deriving (Eq,Generic,Show) +nulltransactionmodifier = TransactionModifier{+  tmquerytxt = ""+ ,tmpostingrules = []+}++-- | A transaction modifier transformation, which adds an extra posting+-- to the matched posting's transaction.+-- 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.+data TMPostingRule = TMPostingRule+  { tmprPosting :: Posting+  , tmprIsMultiplier :: Bool+  } deriving (Eq,Generic,Show)++-- | A periodic transaction rule, describing a transaction that recurs. data PeriodicTransaction = PeriodicTransaction {-      ptperiodicexpr :: String,-      ptpostings :: [Posting]-    } deriving (Eq)+      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.+      --+      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,Generic) -- , Show in PeriodicTransaction.hs -data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) +nullperiodictransaction = PeriodicTransaction{+      ptperiodexpr   = ""+     ,ptinterval     = def+     ,ptspan         = def+     ,ptsourcepos    = (SourcePos "" (mkPos 1) (mkPos 1), SourcePos "" (mkPos 1) (mkPos 1))+     ,ptstatus       = Unmarked+     ,ptcode         = ""+     ,ptdescription  = ""+     ,ptcomment      = ""+     ,pttags         = []+     ,ptpostings     = []+} -data TimeLogEntry = TimeLogEntry {-      tlcode :: TimeLogCode,-      tldatetime :: LocalTime,-      tlcomment :: String-    } deriving (Eq,Ord)+data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic) -data HistoricalPrice = HistoricalPrice {-      hdate :: Day,-      hsymbol :: String,-      hamount :: MixedAmount-    } deriving (Eq) -- & Show (in Amount.hs)+data TimeclockEntry = TimeclockEntry {+      tlsourcepos   :: SourcePos,+      tlcode        :: TimeclockCode,+      tldatetime    :: LocalTime,+      tlaccount     :: AccountName,+      tldescription :: Text,+      tlcomment     :: Text,+      tltags        :: [Tag]+    } deriving (Eq,Ord,Generic) -type Year = Integer+-- | 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 journal "context" is some data which can change in the course of--- parsing a journal. An example is the default year, which changes when a--- Y directive is encountered.  At the end of parsing, the final context--- is saved for later use by eg the add command.-data JournalContext = Ctx {-      ctxYear      :: !(Maybe Year)      -- ^ the default year most recently specified with Y-    , ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D-    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts/account name components-                                        --   specified with "account" directive(s). Concatenated, these-                                        --   are the account prefix prepended to parsed account names.-    , ctxAliases   :: ![(AccountName,AccountName)] -- ^ the current list of account name aliases in effect-    } deriving (Read, Show, Eq)+-- | 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                -- ^ 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) +showMarketPrice MarketPrice{..} = unwords [show mpdate, T.unpack mpfrom <> ">" <> T.unpack mpto, show mprate]+showMarketPrices = intercalate "\n" . map ((' ':).showMarketPrice) . sortBy (comparing mpdate)++-- 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.+--+-- 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 {-      jmodifiertxns :: [ModifierTransaction],-      jperiodictxns :: [PeriodicTransaction],-      jtxns :: [Transaction],-      open_timelog_entries :: [TimeLogEntry],-      historical_prices :: [HistoricalPrice],-      final_comment_lines :: String,        -- ^ any trailing comments from the journal file-      jContext :: JournalContext,           -- ^ the context (parse state) at the end of parsing-      files :: [(FilePath, String)],        -- ^ 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.-      filereadtime :: ClockTime             -- ^ when this journal was last read from its file(s)-    } deriving (Eq, Typeable)+  -- 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, 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 JournalUpdate is some transformation of a Journal. It can do I/O or--- raise an error.-type JournalUpdate = ErrorT String IO (Journal -> Journal)+-- | 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 --- | A hledger journal reader is a triple of format name, format-detecting--- predicate, and a parser to Journal.-data Reader = Reader {rFormat   :: String-                     ,rDetector :: FilePath -> String -> Bool-                     ,rParser   :: FilePath -> String -> ErrorT String IO 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) -data Ledger = Ledger {-      journal :: Journal,-      accountnametree :: Tree AccountName,-      accountmap :: Map.Map AccountName Account-    }+-- 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.+data StorageFormat +  = Rules +  | Journal' +  | Ledger' +  | Timeclock +  | Timedot +  | Sep SepFormat +  deriving (Eq, Ord) -data Account = Account {-      aname :: AccountName,-      apostings :: [Posting],    -- ^ postings in this account-      abalance :: MixedAmount    -- ^ sum of postings in this account and subaccounts-    }+instance Show SepFormat where+  show Csv = "csv"+  show Ssv = "ssv"+  show Tsv = "tsv" --- | A generic, pure specification of how to filter (or search) transactions and postings.-data FilterSpec = FilterSpec {-     datespan  :: DateSpan   -- ^ only include if in this date span-    ,cleared   :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care-    ,real      :: Bool       -- ^ only include if real\/don't care-    ,empty     :: Bool       -- ^ include if empty (ie amount is zero)-    ,acctpats  :: [String]   -- ^ only include if matching these account patterns-    ,descpats  :: [String]   -- ^ only include if matching these description patterns-    ,depth     :: Maybe Int-    } deriving (Show)+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 {+   adicomment          :: Text   -- ^ any comment lines following an account directive for this account+  ,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..)+  ,adisourcepos        :: SourcePos  -- ^ source file and position+} deriving (Eq,Show,Generic)++nullaccountdeclarationinfo = AccountDeclarationInfo {+   adicomment          = ""+  ,aditags             = []+  ,adideclarationorder = 0+  ,adisourcepos        = SourcePos "" (mkPos 1) (mkPos 1)+}++-- | 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 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)++-- | 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, 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 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
@@ -0,0 +1,1220 @@+{-|++A general query system for matching things (accounts, postings,+transactions..)  by various criteria, and a SimpleTextParser for query expressions.++-}++{-# 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,157 +1,544 @@-{-| +--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.+{-| -Read hledger data from various data formats, and related utilities.+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+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++--- ** exports module Hledger.Read (-       tests_Hledger_Read,-       readJournalFile,-       readJournal,-       journalFromPathAndString,-       ledgeraccountname,-       myJournalPath,-       myJournal,-       someamount,-       journalenvvar,-       journaldefaultfilename,-       requireJournalFile,-       ensureJournalFile,-)-where-import Control.Monad.Error-import Data.Either (partitionEithers)-import Data.List++  -- * Journal files+  defaultJournal,+  defaultJournalSafely,+  defaultJournalWith,+  defaultJournalWithSafely,+  defaultJournalPath,+  defaultJournalPathSafely,+  defaultExistingJournalPath,+  defaultExistingJournalPathSafely,+  requireJournalFileExists,+  ensureJournalFileExists,+  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.tmpostingrulep,+  findReader,+  splitReaderPrefix,+  runJournalParser,+  module Hledger.Read.Common,+  module Hledger.Read.InputOptions,++  -- * Tests+  tests_Read,++) where++--- ** 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 Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Time (Day) import Safe (headDef)-import System.Directory (doesFileExist, getHomeDirectory)+import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Environment (getEnv)-import System.Exit (exitFailure)-import System.FilePath ((</>))-import System.IO (IOMode(..), withFile, stderr)-import Test.HUnit-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)-import Hledger.Data.Types (Journal(..), Reader(..))-import Hledger.Data.Journal (nullctx)+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.InputOptions import Hledger.Read.JournalReader as JournalReader-import Hledger.Read.TimelogReader as TimelogReader+import Hledger.Read.CsvReader (tests_CsvReader)+import Hledger.Read.RulesReader (tests_RulesReader) import Hledger.Utils-import Prelude hiding (getContents, writeFile)-import Hledger.Utils.UTF8 (getContents, hGetContents, writeFile) +--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings -journalenvvar           = "LEDGER_FILE"-journalenvvar2          = "LEDGER"-journaldefaultfilename  = ".hledger.journal"+--- ** journal reading --- Here are the available readers. The first is the default, used for unknown data formats.-readers :: [Reader]-readers = [-  JournalReader.reader- ,TimelogReader.reader- ]+journalEnvVar           = "LEDGER_FILE"+journalDefaultFilename  = ".hledger.journal" -formats   = map rFormat readers+-- | 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: -readerForFormat :: String -> Maybe Reader-readerForFormat s | null rs = Nothing-                  | otherwise = Just $ head rs-    where -      rs = filter ((s==).rFormat) readers :: [Reader]+-- | Like defaultJournal, but return an error message instead of raising an error.+defaultJournalSafely :: IO (Either String Journal)+defaultJournalSafely = defaultJournalWithSafely definputopts --- | Read a Journal from this string (and file path), auto-detecting the--- data format, or give a useful error string. Tries to parse each known--- data format in turn. If none succeed, gives the error message specific--- to the intended data format, which if not specified is guessed from the--- file suffix and possibly the data.-journalFromPathAndString :: Maybe String -> FilePath -> String -> IO (Either String Journal)-journalFromPathAndString format fp s = do-  let readers' = case format of Just f -> case readerForFormat f of Just r -> [r]-                                                                    Nothing -> []-                                Nothing -> readers-  (errors, journals) <- partitionEithers `fmap` mapM tryReader readers'-  case journals of j:_ -> return $ Right j-                   _   -> return $ Left $ errMsg errors-    where-      tryReader r = (runErrorT . (rParser r) fp) s-      errMsg [] = unknownFormatMsg-      errMsg es = printf "could not parse %s data in %s\n%s" (rFormat r) fp e-          where (r,e) = headDef (head readers, head es) $ filter detects $ zip readers es-                detects (r,_) = (rDetector r) fp s-      unknownFormatMsg = printf "could not parse %sdata in %s" (fmt formats) fp-          where fmt [] = ""-                fmt [f] = f ++ " "-                fmt fs = intercalate ", " (init fs) ++ " or " ++ last fs ++ " "+-- | Like defaultJournal, but use the given input options.+defaultJournalWith :: InputOpts -> IO Journal+defaultJournalWith iopts = defaultJournalWithSafely iopts >>= either error' return -- PARTIAL: --- | Read a journal from this file, using the specified data format or--- trying all known formats, or give an error string; also create the file--- if it doesn't exist.-readJournalFile :: Maybe String -> FilePath -> IO (Either String Journal)-readJournalFile format "-" = getContents >>= journalFromPathAndString format "(stdin)"-readJournalFile format f = do-  requireJournalFile f-  withFile f ReadMode $ \h -> hGetContents h >>= journalFromPathAndString format f+-- | 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)+    ] --- | If the specified journal file does not exist, give a helpful error and quit.-requireJournalFile :: FilePath -> IO ()-requireJournalFile f = do+-- | 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+  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++-- | 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)+    ]++-- | 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++-- | 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)+    ]++-- | @readJournal iopts mfile txt@+--+-- Read a Journal from some handle, with strict checks if enabled,+-- or return an error message.+--+-- 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 -,+-- 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, 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.+--+-- 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_=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+      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-  when (not exists) $ do-    hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f-    hPrintf stderr "Please create it first, eg with hledger add, hledger web, or a text editor.\n"-    hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"-    exitFailure+  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.-ensureJournalFile :: FilePath -> IO ()-ensureJournalFile f = do+-- 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-  when (not exists) $ do-    hPrintf stderr "Creating hledger journal file \"%s\".\n" 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 >>= writeFile f+    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 String+newJournalContent :: IO Text newJournalContent = do   d <- getCurrentDay-  return $ printf "; journal created %s by hledger\n" (show d)+  return $ "; journal created " <> T.pack (show d) <> " by hledger\n" --- | Read a Journal from this string, using the specified data format or--- trying all known formats, or give an error string.-readJournal :: Maybe String -> String -> IO (Either String Journal)-readJournal format s = journalFromPathAndString format "(string)" s+-- 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] --- | Get the user's journal file path. 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 default journal file path, which is--- ".hledger.journal" in the users's home directory, or if we cannot--- determine that, in the current directory.-myJournalPath :: IO String-myJournalPath = do-  s <- envJournalPath-  if null s then defaultJournalPath else return s-    where-      envJournalPath = getEnv journalenvvar `catch` (\_ -> getEnv journalenvvar2 `catch` (\_ -> return ""))-      defaultJournalPath = do-                  home <- getHomeDirectory `catch` (\_ -> return "")-                  return $ home </> journaldefaultfilename+-- The path of an input file, and its current "LatestDates".+data LatestDatesForFile = LatestDatesForFile FilePath LatestDates+  deriving Show --- | Read the user's default journal file, or give an error.-myJournal :: IO Journal-myJournal = myJournalPath >>= readJournalFile Nothing >>= either error' return+-- | 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 = {-# HLINT ignore "Avoid reverse" #-}+  headDef [] . take 1 . group . reverse . sort -tests_Hledger_Read = TestList-  [-   tests_Hledger_Read_JournalReader,-   tests_Hledger_Read_TimelogReader,+-- | 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 -   "journalFile" ~: do-    assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journalFile "")-    jE <- readJournal Nothing "" -- don't know how to get it from journalFile-    either error' (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE+-- | 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+-- available for this file.+previousLatestDates :: FilePath -> IO LatestDates+previousLatestDates f = do+  let latestfile = latestDatesFileFor f+  exists <- doesFileExist latestfile+  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)+latestDatesFileFor :: FilePath -> FilePath+latestDatesFileFor f = dir </> ".latest" <.> fname+  where+    (dir, fname) = splitFileName f++-- | 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+-- from the journal, and the same number of transactions on the+-- latest date, if any, leaving only transactions that we can assume+-- are newer. Also returns the new latest dates of the new journal.+journalFilterSinceLatestDates :: LatestDates -> Journal -> (Journal, LatestDates)+journalFilterSinceLatestDates [] j       = (j,  latestDates $ map tdate $ jtxns j)+journalFilterSinceLatestDates ds@(d:_) j = (j', ds')+  where+    samedateorlaterts     = filter ((>= d).tdate) $ jtxns j+    (samedatets, laterts) = span ((== d).tdate) $ sortBy (comparing tdate) samedateorlaterts+    newsamedatets         = drop (length ds) samedatets+    j'                    = j{jtxns=newsamedatets++laterts}+    ds'                   = latestDates $ map tdate $ samedatets++laterts++--- ** tests++tests_Read = testGroup "Read" [+   tests_Common+  ,tests_CsvReader+  ,tests_JournalReader+  ,tests_RulesReader   ]
+ Hledger/Read/Common.hs view
@@ -0,0 +1,1759 @@+--- * -*- 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
@@ -0,0 +1,80 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.+{-|++A reader for CSV (character-separated) data.+This also reads a rules file to help interpret the CSV data.++-}++--- ** language+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}++--- ** exports+module Hledger.Read.CsvReader (+  -- * Reader+  reader,+  -- * Tests+  tests_CsvReader,+)+where++--- ** 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 (aliasesFromOpts, Reader(..), InputOpts(..), journalFinalise)+import Hledger.Read.RulesReader (readJournalFromCsv, getRulesFile, rulesEncoding, readRules)+import Control.Monad.Trans (lift)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++--- ** reader++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 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 ""++--- ** 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,851 +1,1308 @@-{-|--A reader for hledger's (and c++ ledger's) journal file format.--From the ledger 2.5 manual:--@-The ledger file format is quite simple, but also very flexible. It supports-many options, though typically the user can ignore most of them. They are-summarized below.  The initial character of each line determines what the-line means, and how it should be interpreted. Allowable initial characters-are:--NUMBER      A line beginning with a number denotes an entry. It may be followed by any-            number of lines, each beginning with whitespace, to denote the entry’s account-            transactions. The format of the first line is:--                    DATE[=EDATE] [*|!] [(CODE)] DESC--            If ‘*’ appears after the date (with optional effective date), it indicates the entry-            is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears-            after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from-            the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in-            parentheses, it may be used to indicate a check number, or the type of the-            transaction. Following these is the payee, or a description of the transaction.-            The format of each following transaction is:--                      ACCOUNT     AMOUNT    [; NOTE]--            The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual-            transactions, or square brackets if it is a virtual transactions that must-            balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost,-            by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’.-            Lastly, the ‘NOTE’ may specify an actual and/or effective date for the-            transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or-            ‘[ACTUAL_DATE=EFFECtIVE_DATE]’.--=           An automated entry. A value expression must appear after the equal sign.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry. If the amounts of the transactions have no commodity,-            they will be applied as modifiers to whichever real transaction is matched by-            the value expression.- -~           A period entry. A period expression must appear after the tilde.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry.--!           A line beginning with an exclamation mark denotes a command directive. It-            must be immediately followed by the command word. The supported commands-            are:--           ‘!include’-                        Include the stated ledger file.-           ‘!account’-                        The account name is given is taken to be the parent of all transac--                        tions that follow, until ‘!end’ is seen.-           ‘!end’       Ends an account block.- -;          A line beginning with a colon indicates a comment, and is ignored.- -Y          If a line begins with a capital Y, it denotes the year used for all subsequent-           entries that give a date without a year. The year should appear immediately-           after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to-           specify the year for that file. If all entries specify a year, however, this command-           has no effect.-           - -P          Specifies a historical price for a commodity. These are usually found in a pricing-           history file (see the ‘-Q’ option). The syntax is:--                  P DATE SYMBOL PRICE--N SYMBOL   Indicates that pricing information is to be ignored for a given symbol, nor will-           quotes ever be downloaded for that symbol. Useful with a home currency, such-           as the dollar ($). It is recommended that these pricing options be set in the price-           database file, which defaults to ‘~/.pricedb’. The syntax for this command is:--                  N SYMBOL--        -D AMOUNT   Specifies the default commodity to use, by specifying an amount in the expected-           format. The entry command will use this commodity as the default when none-           other can be determined. This command may be used multiple times, to set-           the default flags for different commodities; whichever is seen last is used as the-           default commodity. For example, to set US dollars as the default commodity,-           while also setting the thousands flag and decimal flag for that commodity, use:--                  D $1,000.00--C AMOUNT1 = AMOUNT2-           Specifies a commodity conversion, where the first amount is given to be equiv--           alent to the second amount. The first amount should use the decimal precision-           desired during reporting:--                  C 1.00 Kb = 1024 bytes--i, o, b, h-           These four relate to timeclock support, which permits ledger to read timelog-           files. See the timeclock’s documentation for more info on the syntax of its-           timelog files.-@---}--module Hledger.Read.JournalReader (-       emptyLine,-       journalAddFile,-       journalFile,-       ledgeraccountname,-       ledgerdatetime,-       ledgerDefaultYear,-       ledgerDirective,-       ledgerHistoricalPrice,-       reader,-       someamount,-       tests_Hledger_Read_JournalReader-)-where-import Control.Monad-import Control.Monad.Error-import Data.Char (isNumber)-import Data.List-import Data.List.Split (wordsBy)-import Data.Maybe-import Data.Time.Calendar--- import Data.Time.Clock--- import Data.Time.Format-import Data.Time.LocalTime-import Safe (headDef)--- import System.Locale (defaultTimeLocale)-import Test.HUnit-import Text.ParserCombinators.Parsec hiding (parse)-import Text.Printf--import Hledger.Data-import Hledger.Read.Utils-import Hledger.Utils-import Prelude hiding (readFile)-import Hledger.Utils.UTF8 (readFile)----- let's get to it--reader :: Reader-reader = Reader format detect parse--format :: String-format = "journal"---- | Does the given file path and data provide hledger's journal file format ?-detect :: FilePath -> String -> Bool-detect f _ = fileSuffix f == format---- | Parse and post-process a "Journal" from hledger's journal file--- format, or give an error.-parse :: FilePath -> String -> ErrorT String IO Journal-parse = parseJournalWith journalFile---- | Top-level journal parser. Returns a single composite, I/O performing,--- error-raising "JournalUpdate" (and final "JournalContext") which can be--- applied to an empty journal to get the final result.-journalFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)-journalFile = do-  journalupdates <- many journalItem-  eof-  finalctx <- getState-  return $ (juSequence journalupdates, finalctx)-    where -      -- As all journal line types can be distinguished by the first-      -- character, excepting transactions versus empty (blank or-      -- comment-only) lines, can use choice w/o try-      journalItem = choice [ ledgerDirective-                           , liftM (return . addTransaction) ledgerTransaction-                           , liftM (return . addModifierTransaction) ledgerModifierTransaction-                           , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction-                           , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                           , emptyLine >> return (return id)-                           ] <?> "journal transaction or directive"--emptyLine :: GenParser Char JournalContext ()-emptyLine = do many spacenonewline-               optional $ (char ';' <?> "comment") >> many (noneOf "\n")-               newline-               return ()--ledgercomment :: GenParser Char JournalContext String-ledgercomment = do-  many1 $ char ';'-  many spacenonewline-  many (noneOf "\n")-  <?> "comment"--ledgercommentline :: GenParser Char JournalContext String-ledgercommentline = do-  many spacenonewline-  s <- ledgercomment-  optional newline-  eof-  return s-  <?> "comment"--ledgerDirective :: GenParser Char JournalContext JournalUpdate-ledgerDirective = do-  optional $ char '!'-  choice' [-    ledgerInclude-   ,ledgerAlias-   ,ledgerEndAliases-   ,ledgerAccountBegin-   ,ledgerAccountEnd-   ,ledgerTagDirective-   ,ledgerEndTagDirective-   ,ledgerDefaultYear-   ,ledgerDefaultCommodity-   ,ledgerCommodityConversion-   ,ledgerIgnoredPriceCommodity-   ]-  <?> "directive"--ledgerInclude :: GenParser Char JournalContext JournalUpdate-ledgerInclude = do-  string "include"-  many1 spacenonewline-  filename <- restofline-  outerState <- getState-  outerPos <- getPosition-  return $ do filepath <- expandPath outerPos filename-              txt <- readFileOrError outerPos filepath-              let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-              case runParser journalFile outerState filepath txt of-                Right (ju,_) -> juSequence [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))-                Left err     -> throwError $ inIncluded ++ show err-      where readFileOrError pos fp =-                ErrorT $ liftM Right (readFile fp) `catch`-                  \err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err)--journalAddFile :: (FilePath,String) -> Journal -> Journal-journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}--ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate-ledgerAccountBegin = do-  string "account"-  many1 spacenonewline-  parent <- ledgeraccountname-  newline-  pushParentAccount parent-  return $ return id--ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate-ledgerAccountEnd = do-  string "end"-  popParentAccount-  return (return id)--ledgerAlias :: GenParser Char JournalContext JournalUpdate-ledgerAlias = do-  string "alias"-  many1 spacenonewline-  orig <- many1 $ noneOf "="-  char '='-  alias <- restofline-  addAccountAlias (accountNameWithoutPostingType $ strip orig-                  ,accountNameWithoutPostingType $ strip alias)-  return $ return id--ledgerEndAliases :: GenParser Char JournalContext JournalUpdate-ledgerEndAliases = do-  string "end aliases"-  clearAccountAliases-  return (return id)--ledgerTagDirective :: GenParser Char JournalContext JournalUpdate-ledgerTagDirective = do-  string "tag" <?> "tag directive"-  many1 spacenonewline-  _ <- many1 nonspace-  restofline-  return $ return id--ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate-ledgerEndTagDirective = do-  (string "end tag" <|> string "pop") <?> "end tag or pop directive"-  restofline-  return $ return id--ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate-ledgerDefaultYear = do-  char 'Y' <?> "default year"-  many spacenonewline-  y <- many1 digit-  let y' = read y-  failIfInvalidYear y-  setYear y'-  return $ return id--ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate-ledgerDefaultCommodity = do-  char 'D' <?> "default commodity"-  many1 spacenonewline-  a <- someamount-  -- someamount always returns a MixedAmount containing one Amount, but let's be safe-  let as = amounts a-  when (not $ null as) $ setCommodity $ commodity $ head as-  restofline-  return $ return id--ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice-ledgerHistoricalPrice = do-  char 'P' <?> "historical price"-  many spacenonewline-  date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored-  many1 spacenonewline-  symbol <- commoditysymbol-  many spacenonewline-  price <- someamount-  restofline-  return $ HistoricalPrice date symbol price--ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate-ledgerIgnoredPriceCommodity = do-  char 'N' <?> "ignored-price commodity"-  many1 spacenonewline-  commoditysymbol-  restofline-  return $ return id--ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate-ledgerCommodityConversion = do-  char 'C' <?> "commodity conversion"-  many1 spacenonewline-  someamount-  many spacenonewline-  char '='-  many spacenonewline-  someamount-  restofline-  return $ return id--ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction-ledgerModifierTransaction = do-  char '=' <?> "modifier transaction"-  many spacenonewline-  valueexpr <- restofline-  postings <- ledgerpostings-  return $ ModifierTransaction valueexpr postings--ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction-ledgerPeriodicTransaction = do-  char '~' <?> "periodic transaction"-  many spacenonewline-  periodexpr <- restofline-  postings <- ledgerpostings-  return $ PeriodicTransaction periodexpr postings---- | Parse a (possibly unbalanced) ledger transaction.-ledgerTransaction :: GenParser Char JournalContext Transaction-ledgerTransaction = do-  date <- ledgerdate <?> "transaction"-  edate <- optionMaybe (ledgereffectivedate date) <?> "effective date"-  status <- ledgerstatus <?> "cleared flag"-  code <- ledgercode <?> "transaction code"-  (description, comment) <--      (do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|>-       do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)}-      ) <?> "description and/or comment"-  md <- try ledgermetadata <|> return []-  postings <- ledgerpostings-  return $ txnTieKnot $ Transaction date edate status code description comment md postings ""---- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year--- may be omitted if a default year has already been set.-ledgerdate :: GenParser Char JournalContext Day-ledgerdate = do-  -- hacky: try to ensure precise errors for invalid dates-  -- XXX reported error position is not too good-  -- pos <- getPosition-  datestr <- many1 $ choice' [digit, datesepchar]-  let dateparts = wordsBy (`elem` datesepchars) datestr-  currentyear <- getYear-  [y,m,d] <- case (dateparts,currentyear) of-              ([m,d],Just y)  -> return [show y,m,d]-              ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"-              ([y,m,d],_)     -> return [y,m,d]-              _               -> fail $ "bad date: " ++ datestr-  let maybedate = fromGregorianValid (read y) (read m) (read d)-  case maybedate of-    Nothing   -> fail $ "bad date: " ++ datestr-    Just date -> return date-  <?> "full or partial date"---- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.  Any--- timezone will be ignored; the time is treated as local time.  Fewer--- digits are allowed, except in the timezone. The year may be omitted if--- a default year has already been set.-ledgerdatetime :: GenParser Char JournalContext LocalTime-ledgerdatetime = do -  day <- ledgerdate-  many1 spacenonewline-  h <- many1 digit-  let h' = read h-  guard $ h' >= 0 && h' <= 23-  char ':'-  m <- many1 digit-  let m' = read m-  guard $ m' >= 0 && m' <= 59-  s <- optionMaybe $ char ':' >> many1 digit-  let s' = case s of Just sstr -> read sstr-                     Nothing   -> 0-  guard $ s' >= 0 && s' <= 59-  {- tz <- -}-  optionMaybe $ do-                   plusminus <- oneOf "-+"-                   d1 <- digit-                   d2 <- digit-                   d3 <- digit-                   d4 <- digit-                   return $ plusminus:d1:d2:d3:d4:""-  -- ltz <- liftIO $ getCurrentTimeZone-  -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz-  -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')-  return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')--ledgereffectivedate :: Day -> GenParser Char JournalContext Day-ledgereffectivedate actualdate = do-  char '='-  -- kludgy way to use actual date for default year-  let withDefaultYear d p = do-        y <- getYear-        let (y',_,_) = toGregorian d in setYear y'-        r <- p-        when (isJust y) $ setYear $ fromJust y-        return r-  edate <- withDefaultYear actualdate ledgerdate-  return edate--ledgerstatus :: GenParser Char JournalContext Bool-ledgerstatus = try (do { many spacenonewline; char '*' <?> "status"; return True } ) <|> return False--ledgercode :: GenParser Char JournalContext String-ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""--ledgermetadata :: GenParser Char JournalContext [(String,String)]-ledgermetadata = many ledgermetadataline---- a comment line containing a metadata declaration, eg:--- ; name: value-ledgermetadataline :: GenParser Char JournalContext (String,String)-ledgermetadataline = do-  many1 spacenonewline-  many1 $ char ';'-  many spacenonewline-  name <- many1 $ noneOf ": \t"-  char ':'-  many spacenonewline-  value <- many (noneOf "\n")-  optional newline---  eof-  return (name,value)-  <?> "metadata line"---- Parse the following whitespace-beginning lines as postings, posting metadata, and/or comments.--- complicated to handle intermixed comment and metadata lines.. make me better ?-ledgerpostings :: GenParser Char JournalContext [Posting]-ledgerpostings = do-  ctx <- getState-  -- we'll set the correct position for sub-parses for more useful errors-  pos <- getPosition-  ls <- many1 $ try linebeginningwithspaces-  let lsnumbered = zip ls [0..]-      parses p = isRight . parseWithCtx ctx p-      postinglines = filter (not . (ledgercommentline `parses`) . fst) lsnumbered-      -- group any metadata lines with the posting line above-      postinglinegroups :: [(String,Line)] -> [(String,Line)]-      postinglinegroups [] = []-      postinglinegroups ((pline,num):ls) = (unlines (pline:(map fst mdlines)), num):postinglinegroups rest-          where (mdlines,rest) = span ((ledgermetadataline `parses`) . fst) ls-      pstrs = postinglinegroups postinglines-      parseNumberedPostingLine (str,num) = fromparse $ parseWithCtx ctx (setPosition (incSourceLine pos num) >> ledgerposting) str-  when (null pstrs) $ fail "no postings"-  return $ map parseNumberedPostingLine pstrs-  <?> "postings"-            -linebeginningwithspaces :: GenParser Char JournalContext String-linebeginningwithspaces = do-  sp <- many1 spacenonewline-  c <- nonspace-  cs <- restofline-  return $ sp ++ (c:cs) ++ "\n"--ledgerposting :: GenParser Char JournalContext Posting-ledgerposting = do-  many1 spacenonewline-  status <- ledgerstatus-  many spacenonewline-  account <- modifiedaccountname-  let (ptype, account') = (accountNamePostingType account, unbracket account)-  amount <- postingamount-  many spacenonewline-  comment <- ledgercomment <|> return ""-  newline-  md <- ledgermetadata-  return (Posting status account' amount comment ptype md Nothing)---- Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.-modifiedaccountname :: GenParser Char JournalContext AccountName-modifiedaccountname = do-  a <- ledgeraccountname-  prefix <- getParentAccount-  let prefixed = prefix `joinAccountNames` a-  aliases <- getAccountAliases-  return $ accountNameApplyAliases aliases prefixed---- | Parse an account name. Account names may have single spaces inside--- them, and are terminated by two or more spaces. They should have one or--- more components of at least one character, separated by the account--- separator char.-ledgeraccountname :: GenParser Char st AccountName-ledgeraccountname = do-    a <- many1 (nonspace <|> singlespace)-    let a' = striptrailingspace a-    when (accountNameFromComponents (accountNameComponents a') /= a')-         (fail $ "accountname seems ill-formed: "++a')-    return a'-    where -      singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})-      -- couldn't avoid consuming a final space sometimes, harmless-      striptrailingspace s = if last s == ' ' then init s else s---- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace---     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"---- | Parse an amount, with an optional left or right currency symbol and--- optional price.-postingamount :: GenParser Char JournalContext MixedAmount-postingamount =-  try (do-        many1 spacenonewline-        someamount <|> return missingamt-      ) <|> return missingamt--someamount :: GenParser Char JournalContext MixedAmount-someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount --leftsymbolamount :: GenParser Char JournalContext MixedAmount-leftsymbolamount = do-  sign <- optionMaybe $ string "-"-  let applysign = if isJust sign then negate else id-  sym <- commoditysymbol -  sp <- many spacenonewline-  (q,p,d,s,spos) <- number-  pri <- priceamount-  let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}-  return $ applysign $ Mixed [Amount c q pri]-  <?> "left-symbol amount"--rightsymbolamount :: GenParser Char JournalContext MixedAmount-rightsymbolamount = do-  (q,p,d,s,spos) <- number-  sp <- many spacenonewline-  sym <- commoditysymbol-  pri <- priceamount-  let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}-  return $ Mixed [Amount c q pri]-  <?> "right-symbol amount"--nosymbolamount :: GenParser Char JournalContext MixedAmount-nosymbolamount = do-  (q,p,d,s,spos) <- number-  pri <- priceamount-  defc <- getCommodity-  let c = fromMaybe Commodity{symbol="",side=L,spaced=False,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} defc-  return $ Mixed [Amount c q pri]-  <?> "no-symbol amount"--commoditysymbol :: GenParser Char JournalContext String-commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"--quotedcommoditysymbol :: GenParser Char JournalContext String-quotedcommoditysymbol = do-  char '"'-  s <- many1 $ noneOf ";\n\""-  char '"'-  return s--simplecommoditysymbol :: GenParser Char JournalContext String-simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)--priceamount :: GenParser Char JournalContext (Maybe Price)-priceamount =-    try (do-          many spacenonewline-          char '@'-          try (do-                char '@'-                many spacenonewline-                a <- someamount -- XXX can parse more prices ad infinitum, shouldn't-                return $ Just $ TotalPrice a)-           <|> (do-            many spacenonewline-            a <- someamount -- XXX can parse more prices ad infinitum, shouldn't-            return $ Just $ UnitPrice a))-         <|> return Nothing---- gawd.. trying to parse a ledger number without error:--type Quantity = Double---- -- | Parse a ledger-style numeric quantity and also return the number of--- -- digits to the right of the decimal point and whether thousands are--- -- separated by comma.--- amountquantity :: GenParser Char JournalContext (Quantity, Int, Bool)--- amountquantity = do---   sign <- optionMaybe $ string "-"---   (intwithcommas,frac) <- numberparts---   let comma = ',' `elem` intwithcommas---   let precision = length frac---   -- read the actual value. We expect this read to never fail.---   let int = filter (/= ',') intwithcommas---   let int' = if null int then "0" else int---   let frac' = if null frac then "0" else frac---   let sign' = fromMaybe "" sign---   let quantity = read $ sign'++int'++"."++frac'---   return (quantity, precision, comma)---   <?> "commodity quantity"---- -- | parse the two strings of digits before and after a possible decimal--- -- point.  The integer part may contain commas, or either part may be--- -- empty, or there may be no point.--- numberparts :: GenParser Char JournalContext (String,String)--- numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint---- numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String)--- numberpartsstartingwithdigit = do---   let digitorcomma = digit <|> char ','---   first <- digit---   rest <- many digitorcomma---   frac <- try (do {char '.'; many digit}) <|> return ""---   return (first:rest,frac)-                     --- numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String)--- numberpartsstartingwithpoint = do---   char '.'---   frac <- many1 digit---   return ("",frac)---- | Parse a numeric quantity for its value and display attributes.  Some--- international number formats (cf--- http://en.wikipedia.org/wiki/Decimal_separator) are accepted: 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 (eg a--- thousands separator).  This returns the numeric value, the precision--- (number of digits to the right of the decimal point), the decimal point--- and separator characters (defaulting to . and ,), and the positions of--- separators (counting leftward from the decimal point, the last is--- assumed to repeat).-number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])-number = do-  sign <- optionMaybe $ string "-"-  parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']-  let numeric = isNumber . headDef '_'-      (_, puncparts) = partition numeric parts-      (ok,decimalpoint',separator') =-          case puncparts of-            []     -> (True, Nothing, Nothing)  -- no punctuation chars-            [d:""] -> (True, Just d, Nothing)   -- just one punctuation char, assume it's a decimal point-            [_]    -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok-            _:_:_  -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars-                     in if (any ((/=1).length) puncparts  -- adjacent punctuation chars, not ok-                            || any (s/=) ss                -- separator chars differ, not ok-                            || head parts == s)            -- number begins with a separator char, not ok-                         then (False, Nothing, Nothing)-                         else if s == d-                               then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars-                               else (True, Just $ head d, Just $ head s) -- separators and a decimal point-  when (not ok) (fail $ "number seems ill-formed: "++concat parts)-  let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts-      (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')-      separatorpositions = reverse $ map length $ drop 1 intparts-      int = concat $ "":intparts-      frac = concat $ "":fracpart-      precision = length frac-      int' = if null int then "0" else int-      frac' = if null frac then "0" else frac-      sign' = fromMaybe "" sign-      quantity = read $ sign'++int'++"."++frac' -- this read should never fail-      (decimalpoint, separator) = case (decimalpoint', separator') of (Just d,  Just s)   -> (d,s)-                                                                      (Just '.',Nothing)  -> ('.',',')-                                                                      (Just ',',Nothing)  -> (',','.')-                                                                      (Nothing, Just '.') -> (',','.')-                                                                      (Nothing, Just ',') -> ('.',',')-                                                                      _                   -> ('.',',')-  return (quantity,precision,decimalpoint,separator,separatorpositions)-  <?> "number"--tests_Hledger_Read_JournalReader = TestList [--    "number" ~: do-      let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n-          assertFails = assertBool "" . isLeft . parseWithCtx nullctx number -      assertFails ""-      "0"          `is` (0, 0, '.', ',', [])-      "1"          `is` (1, 0, '.', ',', [])-      "1.1"        `is` (1.1, 1, '.', ',', [])-      "1,000.1"    `is` (1000.1, 1, '.', ',', [3])-      "1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])-      "1,000,000"  `is` (1000000, 0, '.', ',', [3,3])-      "1."         `is` (1,   0, '.', ',', [])-      "1,"         `is` (1,   0, ',', '.', [])-      ".1"         `is` (0.1, 1, '.', ',', [])-      ",1"         `is` (0.1, 1, ',', '.', [])-      assertFails "1,000.000,1"-      assertFails "1.000,000.1"-      assertFails "1,000.000.1"-      assertFails "1,,1"-      assertFails "1..1"-      assertFails ".1,"-      assertFails ",1."--   ,"ledgerTransaction" ~: do-    assertParseEqual (parseWithCtx nullctx ledgerTransaction entry1_str) entry1-    assertBool "ledgerTransaction should not parse just a date"-                   $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1\n"-    assertBool "ledgerTransaction should require some postings"-                   $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1 a\n"-    let t = parseWithCtx nullctx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"-    assertBool "ledgerTransaction should not include a comment in the description"-                   $ either (const False) ((== "a") . tdescription) t--  ,"ledgerModifierTransaction" ~: do-     assertParse (parseWithCtx nullctx ledgerModifierTransaction "= (some value expr)\n some:postings  1\n")--  ,"ledgerPeriodicTransaction" ~: do-     assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings  1\n")--  ,"ledgerDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerDirective "!include /some/file.x\n")-     assertParse (parseWithCtx nullctx ledgerDirective "account some:account\n")-     assertParse (parseWithCtx nullctx (ledgerDirective >> ledgerDirective) "!account a\nend\n")--  ,"ledgercommentline" ~: do-     assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")-     assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")-     assertParse (parseWithCtx nullctx ledgercommentline ";x")--  ,"ledgerdate" ~: do-     assertParse (parseWithCtx nullctx ledgerdate "2011/1/1")-     assertParseFailure (parseWithCtx nullctx ledgerdate "1/1")-     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} ledgerdate "1/1")--  ,"ledgerdatetime" ~: do-      let p = do {t <- ledgerdatetime; eof; return t}-          bad = assertParseFailure . parseWithCtx nullctx p-          good = assertParse . parseWithCtx nullctx p-      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"-      good "2011/1/1 00:00"-      good "2011/1/1 23:59:59"-      good "2011/1/1 3:5:7"-      -- timezone is parsed but ignored-      let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))-      assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday-      assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday--  ,"ledgerDefaultYear" ~: do-     assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n")-     assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n")--  ,"ledgerHistoricalPrice" ~:-    assertParseEqual (parseWithCtx nullctx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])--  ,"ledgerIgnoredPriceCommodity" ~: do-     assertParse (parseWithCtx nullctx ledgerIgnoredPriceCommodity "N $\n")--  ,"ledgerDefaultCommodity" ~: do-     assertParse (parseWithCtx nullctx ledgerDefaultCommodity "D $1,000.0\n")--  ,"ledgerCommodityConversion" ~: do-     assertParse (parseWithCtx nullctx ledgerCommodityConversion "C 1h = $50.00\n")--  ,"ledgerTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerTagDirective "tag foo \n")--  ,"ledgerEndTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n")-  ,"ledgerEndTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerEndTagDirective "pop \n")--  ,"ledgeraccountname" ~: do-    assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")-    assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")-    assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")-    assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")-- ,"ledgerposting" ~: do-    assertParseEqual (parseWithCtx nullctx ledgerposting "  expenses:food:dining  $10.00\n")-                     (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [] Nothing)-    assertBool "ledgerposting parses a quoted commodity with numbers"-                   (isRight $ parseWithCtx nullctx ledgerposting "  a  1 \"DE123\"\n")--  ,"someamount" ~: do-     let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity-         assertMixedAmountParse parseresult mixedamount =-             (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)-     assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2")-                            (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])])--  ,"postingamount" ~: do-    assertParseEqual (parseWithCtx nullctx postingamount " $47.18") (Mixed [dollars 47.18])-    assertParseEqual (parseWithCtx nullctx postingamount " $1.")-                (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])-  ,"postingamount with unit price" ~: do-    assertParseEqual-     (parseWithCtx nullctx postingamount " $10 @ €0.5")-     (Mixed [Amount{commodity=dollar{precision=0},-                    quantity=10,-                    price=(Just $ UnitPrice $ Mixed [Amount{commodity=euro{precision=1},-                                                            quantity=0.5,-                                                            price=Nothing}])}])-  ,"postingamount with total price" ~: do-    assertParseEqual-     (parseWithCtx nullctx postingamount " $10 @@ €5")-     (Mixed [Amount{commodity=dollar{precision=0},-                    quantity=10,-                    price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=0},-                                                             quantity=5,-                                                             price=Nothing}])}])--  ,"leftsymbolamount" ~: do-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])-- ]--entry1_str = unlines- ["2007/01/28 coopportunity"- ,"    expenses:food:groceries                   $47.18"- ,"    assets:checking                          $-47.18"- ,""- ]--entry1 =-    txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-     [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing, -      Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting [] Nothing] ""-+--- * -*- 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
@@ -0,0 +1,250 @@+--- * -*- outline-regexp:"--- \\*"; -*-+--- ** doc+-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.++-- Keep relevant parts synced with manual:+{-|++A reader for the timeclock file format.++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.+Each entry has the form:++  CODE YYYY/MM/DD HH:MM:SS [COMMENT]++CODE is one of: b, h, i, o or O.  COMMENT is optional when the code is+i, o or O.  The meanings of the codes are:++  b  Set the current time balance, or \"time debt\".  Useful when+     archiving old log data, when a debt must be carried forward.+     The COMMENT here is the number of seconds of debt.++  h  Set the required working time for the given day.  This must+     be the first entry for that day.  The COMMENT in this case is+     the number of hours in this workday.  Floating point amounts+     are allowed.++  i  Clock in.  The COMMENT in this case should be the name of the+     project worked on.++  o  Clock out.  COMMENT is unnecessary, but can be used to provide+     a description of how the period went, for example.++  O  Final clock out.  Whatever project was being worked on, it is+     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+{-# LANGUAGE OverloadedStrings #-}++--- ** exports+module Hledger.Read.TimeclockReader (+  -- * Reader+  reader,+  -- * Misc other exports+  timeclockfilep,+)+where++--- ** imports+import           Control.Monad+import           Control.Monad.Except (ExceptT, liftEither)+import           Control.Monad.State.Strict+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+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 :: MonadIO m => Reader m+reader = Reader+  {rFormat     = Timeclock+  ,rExtensions = ["timeclock"]+  ,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 iopts fp t = initialiseAndParseJournal (timeclockfilep iopts) iopts fp t+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+                   >>= journalFinalise iopts fp t++--- ** parsers++-- 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 skipNonNewlineSpaces1+  datetime <- datetimep+  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
@@ -0,0 +1,276 @@+--- * -*- 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++; on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc.+2/1+fos.haskell   .... ..+biz.research  .+inc.client1   .... .... .... .... .... ....++2/2+biz.research  .+inc.client1   .... .... ..++@++-}++--- ** language+{-# LANGUAGE OverloadedStrings #-}++--- ** exports+module Hledger.Read.TimedotReader (+  -- * Reader+  reader,+  -- * Misc other exports+  timedotfilep,+)+where++--- ** imports+import Control.Monad+import Control.Monad.Except (ExceptT, liftEither)+import Control.Monad.State.Strict+import Data.Char (isSpace)+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+import Data.Decimal (roundTo)+import Data.Functor ((<&>))+import Data.List (sort)+import Data.List (group)+-- import Text.Megaparsec.Debug (dbg)++--- ** doctest setup+-- $setup+-- >>> :set -XOverloadedStrings++--- ** reader++reader :: MonadIO m => Reader m+reader = Reader+  {rFormat     = Timedot+  ,rExtensions = ["timedot"]+  ,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 iopts fp t = initialiseAndParseJournal (timedotp iopts) iopts fp t+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)+                   >>= journalFinalise iopts fp t++--- ** utilities++-- 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 ()++--- ** 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.+-- @+-- 2020/2/1 optional day description+-- fos.haskell  .... ..+-- biz.research .+-- inc.client1  .... .... .... .... .... ....+-- @+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 [Posting]+timedotentryp = do+  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++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+-- 1m = 60s, 1h = 60m, 1d = 24h, 1w = 7d, 1mo = 30d, 1y=365d.+-- @+-- 1.5+-- 1.5h+-- 90m+-- @+numericquantityp :: TextParser m Hours+numericquantityp = do+  -- dp "numericquantityp"+  (q, _, _, _) <- numberp Nothing+  msymbol <- optional $ choice $ map (string . fst) timeUnits+  skipNonNewlineSpaces+  let q' =+        case msymbol of+          Nothing  -> q+          Just sym -> roundTo 2 $+            case lookup sym timeUnits of+              Just mult -> q * mult+              Nothing   -> q  -- shouldn't happen.. ignore+  return q'++-- (symbol, equivalent in hours).+timeUnits =+  [("s",2.777777777777778e-4)+  ,("mo",5040) -- before "m"+  ,("m",1.6666666666666666e-2)+  ,("h",1)+  ,("d",24)+  ,("w",168)+  ,("y",61320)+  ]++-- | Parse a quantity written as a line of one or more dots,+-- each representing 0.25, ignoring any interspersed spaces+-- after the first dot.+-- @+-- .... ..+-- @+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/Read/TimelogReader.hs 
@@ -1,104 +0,0 @@-{-|--A reader for the timelog file format generated by timeclock.el.--From timeclock.el 2.6:--@-A timelog contains data in the form of a single entry per line.-Each entry has the form:--  CODE YYYY/MM/DD HH:MM:SS [COMMENT]--CODE is one of: b, h, i, o or O.  COMMENT is optional when the code is-i, o or O.  The meanings of the codes are:--  b  Set the current time balance, or \"time debt\".  Useful when-     archiving old log data, when a debt must be carried forward.-     The COMMENT here is the number of seconds of debt.--  h  Set the required working time for the given day.  This must-     be the first entry for that day.  The COMMENT in this case is-     the number of hours in this workday.  Floating point amounts-     are allowed.--  i  Clock in.  The COMMENT in this case should be the name of the-     project worked on.--  o  Clock out.  COMMENT is unnecessary, but can be used to provide-     a description of how the period went, for example.--  O  Final clock out.  Whatever project was being worked on, it is-     now finished.  Useful for creating summary reports.-@--Example:--@-i 2007/03/10 12:26:00 hledger-o 2007/03/10 17:26:02-@---}--module Hledger.Read.TimelogReader (-       reader,-       tests_Hledger_Read_TimelogReader-)-where-import Control.Monad-import Control.Monad.Error-import Test.HUnit-import Text.ParserCombinators.Parsec hiding (parse)--import Hledger.Data-import Hledger.Read.Utils-import Hledger.Read.JournalReader (ledgerDirective, ledgerHistoricalPrice,-                                   ledgerDefaultYear, emptyLine, ledgerdatetime)-import Hledger.Utils---reader :: Reader-reader = Reader format detect parse--format :: String-format = "timelog"---- | Does the given file path and data provide timeclock.el's timelog format ?-detect :: FilePath -> String -> Bool-detect f _ = fileSuffix f == format---- | Parse and post-process a "Journal" from timeclock.el's timelog--- format, saving the provided file path and the current time, or give an--- error.-parse :: FilePath -> String -> ErrorT String IO Journal-parse = parseJournalWith timelogFile--timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)-timelogFile = do items <- many timelogItem-                 eof-                 ctx <- getState-                 return (liftM (foldr (.) id) $ sequence items, ctx)-    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-      timelogItem = choice [ ledgerDirective-                          , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                          , ledgerDefaultYear-                          , emptyLine >> return (return id)-                          , liftM (return . addTimeLogEntry)  timelogentry-                          ] <?> "timelog entry, or default year or historical price directive"---- | Parse a timelog entry.-timelogentry :: GenParser Char JournalContext TimeLogEntry-timelogentry = do-  code <- oneOf "bhioO"-  many1 spacenonewline-  datetime <- ledgerdatetime-  comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)-  return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment)--tests_Hledger_Read_TimelogReader = TestList [- ]-
− Hledger/Read/Utils.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-|-Utilities common to hledger journal readers.--}--module Hledger.Read.Utils-where--import Control.Monad.Error-import Data.List-import System.Directory (getHomeDirectory)-import System.FilePath(takeDirectory,combine)-import System.Time (getClockTime)-import Text.ParserCombinators.Parsec--import Hledger.Data.Types-import Hledger.Utils-import Hledger.Data.Posting-import Hledger.Data.Dates (getCurrentYear)-import Hledger.Data.Journal---juSequence :: [JournalUpdate] -> JournalUpdate-juSequence us = liftM (foldr (.) id) $ sequence us---- | Given a JournalUpdate-generating parsec parser, file path and data string,--- parse and post-process a Journal so that it's ready to use, or give an error.-parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal-parseJournalWith p f s = do-  tc <- liftIO getClockTime-  tl <- liftIO getCurrentLocalTime-  y <- liftIO getCurrentYear-  case runParser p nullctx{ctxYear=Just y} f s of-    Right (updates,ctx) -> do-                           j <- updates `ap` return nulljournal-                           case journalFinalise tc tl f s ctx j of-                             Right j'  -> return j'-                             Left estr -> throwError estr-    Left e -> throwError $ show e--setYear :: Integer -> GenParser tok JournalContext ()-setYear y = updateState (\ctx -> ctx{ctxYear=Just y})--getYear :: GenParser tok JournalContext (Maybe Integer)-getYear = liftM ctxYear getState--setCommodity :: Commodity -> GenParser tok JournalContext ()-setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c})--getCommodity :: GenParser tok JournalContext (Maybe Commodity)-getCommodity = liftM ctxCommodity getState--pushParentAccount :: String -> GenParser tok JournalContext ()-pushParentAccount parent = updateState addParentAccount-    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }--popParentAccount :: GenParser tok JournalContext ()-popParentAccount = do ctx0 <- getState-                      case ctxAccount ctx0 of-                        [] -> unexpected "End of account block with no beginning"-                        (_:rest) -> setState $ ctx0 { ctxAccount = rest }--getParentAccount :: GenParser tok JournalContext String-getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState--addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()-addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})--getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]-getAccountAliases = liftM ctxAliases getState--clearAccountAliases :: GenParser tok JournalContext ()-clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})---- | Convert a possibly relative, possibly tilde-containing file path to an absolute one.--- using the current directory from a parsec source position. ~username is not supported.-expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath-expandPath pos fp = liftM mkAbsolute (expandHome fp)-  where-    mkAbsolute = combine (takeDirectory (sourceName pos))-    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory-                                                      return $ homedir ++ drop 1 inname-                      | otherwise                = return inname--fileSuffix :: FilePath -> String-fileSuffix = reverse . takeWhile (/='.') . reverse . dropWhile (/='.')
Hledger/Reports.hs view
@@ -1,612 +1,44 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+ {-|  Generate several common kinds of report from a journal, as \"*Report\" - simple intermediate data structures intended to be easily rendered as text, html, json, csv etc. by hledger commands, hamlet templates,-javascript, or whatever. This is under Hledger.Cli since it depends-on the command-line options, should move to hledger-lib later.+javascript, or whatever.  -}  module Hledger.Reports (-  ReportOpts(..),-  DisplayExp,-  FormatStr,-  defreportopts,-  dateSpanFromOpts,-  intervalFromOpts,-  clearedValueFromOpts,-  whichDateFromOpts,-  journalSelectingDateFromOpts,-  journalSelectingAmountFromOpts,-  optsToFilterSpec,-  -- * Entries report-  EntriesReport,-  EntriesReportItem,-  entriesReport,-  -- * Postings report-  PostingsReport,-  PostingsReportItem,-  postingsReport,-  mkpostingsReportItem, -- XXX for showPostingWithBalanceForVty in Hledger.Cli.Register-  -- * Transactions report-  TransactionsReport,-  TransactionsReportItem,-  triDate,-  triBalance,-  journalTransactionsReport,-  accountTransactionsReport,-  -- * Accounts report-  AccountsReport,-  AccountsReportItem,-  accountsReport,-  accountsReport2,-  isInteresting,+  module Hledger.Reports.ReportOptions,+  module Hledger.Reports.ReportTypes,+  module Hledger.Reports.EntriesReport,+  module Hledger.Reports.PostingsReport,+  module Hledger.Reports.AccountTransactionsReport,+  module Hledger.Reports.BalanceReport,+  module Hledger.Reports.MultiBalanceReport,+  module Hledger.Reports.BudgetReport,   -- * Tests-  tests_Hledger_Reports+  tests_Reports ) where -import Control.Monad-import Data.List-import Data.Maybe-import Data.Ord-import Data.Time.Calendar-import Data.Tree-import Safe (headMay, lastMay)-import System.Console.CmdArgs  -- for defaults support-import Test.HUnit-import Text.ParserCombinators.Parsec-import Text.Printf--import Hledger.Data-import Hledger.Utils---- report options, used in hledger-lib and above-data ReportOpts = ReportOpts {-     begin_          :: Maybe Day-    ,end_            :: Maybe Day-    ,period_         :: Maybe (Interval,DateSpan)-    ,cleared_        :: Bool-    ,uncleared_      :: Bool-    ,cost_           :: Bool-    ,depth_          :: Maybe Int-    ,display_        :: Maybe DisplayExp-    ,effective_      :: Bool-    ,empty_          :: Bool-    ,no_elide_       :: Bool-    ,real_           :: Bool-    ,flat_           :: Bool -- balance-    ,drop_           :: Int  -- balance-    ,no_total_       :: Bool -- balance-    ,daily_          :: Bool-    ,weekly_         :: Bool-    ,monthly_        :: Bool-    ,quarterly_      :: Bool-    ,yearly_         :: Bool-    ,format_         :: Maybe FormatStr-    ,patterns_       :: [String]- } deriving (Show)--type DisplayExp = String-type FormatStr = String--defreportopts = ReportOpts-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def-    def--instance Default ReportOpts where def = defreportopts---- | Figure out the date span we should report on, based on any--- begin/end/period options provided. A period option will cause begin and--- end options to be ignored.-dateSpanFromOpts :: Day -> ReportOpts -> DateSpan-dateSpanFromOpts _ ReportOpts{..} =-    case period_ of Just (_,span) -> span-                    Nothing -> DateSpan begin_ end_---- | Figure out the reporting interval, if any, specified by the options.--- --period overrides --daily overrides --weekly overrides --monthly etc.-intervalFromOpts :: ReportOpts -> Interval-intervalFromOpts ReportOpts{..} =-    case period_ of-      Just (interval,_) -> interval-      Nothing -> i-          where i | daily_ = Days 1-                  | weekly_ = Weeks 1-                  | monthly_ = Months 1-                  | quarterly_ = Quarters 1-                  | yearly_ = Years 1-                  | otherwise =  NoInterval---- | Get a maybe boolean representing the last cleared/uncleared option if any.-clearedValueFromOpts :: ReportOpts -> Maybe Bool-clearedValueFromOpts ReportOpts{..} | cleared_   = Just True-                                    | uncleared_ = Just False-                                    | otherwise  = Nothing---- | Report which date we will report on based on --effective.-whichDateFromOpts :: ReportOpts -> WhichDate-whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate---- | Select a Transaction date accessor based on --effective.-transactionDateFn :: ReportOpts -> (Transaction -> Day)-transactionDateFn ReportOpts{..} = if effective_ then transactionEffectiveDate else transactionActualDate---- | Convert this journal's transactions' primary date to either the--- actual or effective date, as per options.-journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal-journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts 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 application options to the library's generic filter specification.-optsToFilterSpec :: ReportOpts -> Day -> FilterSpec-optsToFilterSpec opts@ReportOpts{..} d = FilterSpec {-                                datespan=dateSpanFromOpts d opts-                               ,cleared= clearedValueFromOpts opts-                               ,real=real_-                               ,empty=empty_-                               ,acctpats=apats-                               ,descpats=dpats-                               ,depth = depth_-                               }-    where (apats,dpats) = parsePatternArgs patterns_---- | Gather filter pattern arguments into a list of account patterns and a--- list of description patterns. We interpret pattern arguments as--- follows: those prefixed with "desc:" are description patterns, all--- others are account patterns; also patterns prefixed with "not:" are--- negated. not: should come after desc: if both are used.-parsePatternArgs :: [String] -> ([String],[String])-parsePatternArgs args = (as, ds')-    where-      descprefix = "desc:"-      (ds, as) = partition (descprefix `isPrefixOf`) args-      ds' = map (drop (length descprefix)) ds------------------------------------------------------------------------------------- | A journal entries report is a list of whole transactions as--- originally entered in the journal (mostly). Used by eg hledger's print--- command and hledger-web's journal entries view.-type EntriesReport = [EntriesReportItem]-type EntriesReportItem = Transaction---- | Select transactions for an entries report.-entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport-entriesReport opts fspec j = sortBy (comparing f) $ jtxns $ filterJournalTransactions fspec j'-    where-      f = transactionDateFn opts-      j' = journalSelectingAmountFromOpts opts j------------------------------------------------------------------------------------- | 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.-type PostingsReport = (String               -- label for the running balance column XXX remove-                      ,[PostingsReportItem] -- line items, one per posting-                      )-type PostingsReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting-                                 ,Posting      -- the posting-                                 ,MixedAmount  -- the running total after this posting-                                 )---- | 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 -> FilterSpec -> Journal -> PostingsReport-postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+))-    where-      ps | interval == NoInterval = displayableps-         | otherwise              = summarisePostingsByInterval interval depth empty reportspan displayableps-      j' =                                journalSelectingDateFromOpts opts-                                        $ journalSelectingAmountFromOpts opts-                                        j-      (precedingps, displayableps, _) =   postingsMatchingDisplayExpr (display_ opts)-                                        $ depthClipPostings depth-                                        $ journalPostings-                                        $ filterJournalPostings fspec{depth=Nothing}-                                        j'-      (interval, depth, empty, displayexpr) = (intervalFromOpts opts, depth_ opts, empty_ opts, display_ opts)-      journalspan = journalDateSpan j'-      -- requestedspan should be the intersection of any span specified-      -- with period options and any span specified with display option.-      -- The latter is not easily available, fake it for now.-      requestedspan = periodspan `spanIntersect` displayspan-      periodspan = datespan fspec-      displayspan = postingsDateSpan ps-          where (_,ps,_) = postingsMatchingDisplayExpr displayexpr $ journalPostings j'-      matchedspan = postingsDateSpan displayableps-      reportspan | empty     = requestedspan `orDatesFrom` journalspan-                 | otherwise = requestedspan `spanIntersect` matchedspan-      startbal = sumPostings precedingps--totallabel = "Total"-balancelabel = "Balance"---- | Generate postings report line items.-postingsReportItems :: [Posting] -> Posting -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]-postingsReportItems [] _ _ _ = []-postingsReportItems (p:ps) pprev b sumfn = i:(postingsReportItems ps p b' sumfn)-    where-      i = mkpostingsReportItem isfirst p b'-      isfirst = ptransaction p /= ptransaction pprev-      b' = b `sumfn` pamount p---- | Generate one postings report line item, from a flag indicating--- whether to include transaction info, a posting, and the current running--- balance.-mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem-mkpostingsReportItem False p b = (Nothing, p, b)-mkpostingsReportItem True p b = (ds, p, b)-    where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de)-                                      Nothing -> Just (nulldate,"")---- | Date-sort and split a list of postings into three spans - postings matched--- by the given display expression, and the preceding and following postings.-postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])-postingsMatchingDisplayExpr d ps = (before, matched, after)-    where-      sorted = sortBy (comparing postingDate) ps-      (before, rest) = break (displayExprMatches d) sorted-      (matched, after) = span (displayExprMatches d) rest---- | Does this display expression allow this posting to be displayed ?--- Raises an error if the display expression can't be parsed.-displayExprMatches :: Maybe String -> Posting -> Bool-displayExprMatches Nothing  _ = True-displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p---- | Parse a hledger display expression, which is a simple date test like--- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate.-datedisplayexpr :: GenParser Char st (Posting -> Bool)-datedisplayexpr = do-  char 'd'-  op <- compareop-  char '['-  (y,m,d) <- smartdate-  char ']'-  let date    = parsedate $ printf "%04s/%02s/%02s" y m d-      test op = return $ (`op` date) . postingDate-  case op of-    "<"  -> test (<)-    "<=" -> test (<=)-    "="  -> test (==)-    "==" -> test (==)-    ">=" -> test (>=)-    ">"  -> test (>)-    _    -> mzero- where-  compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]---- | Clip the account names to the specified depth in a list of postings.-depthClipPostings :: Maybe Int -> [Posting] -> [Posting]-depthClipPostings depth = map (depthClipPosting depth)---- | Clip a posting's account name to the specified depth.-depthClipPosting :: Maybe Int -> Posting -> Posting-depthClipPosting Nothing p = p-depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a}---- XXX confusing, refactor---- | Convert a list of postings into summary postings. Summary postings--- are one per account per interval and aggregated to the specified depth--- if any.-summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]-summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan-    where-      summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)-      postingsinspan s = filter (isPostingInDateSpan s) ps---- | Given a date span (representing a reporting interval) and a list of--- postings within it: aggregate the postings so there is only one per--- account, and adjust their date/description so that they will render--- as a summary for this interval.------ As usual with date spans the end date is exclusive, but for display--- purposes we show the previous day as end date, like ledger.------ When a depth argument is present, postings to accounts of greater--- depth are aggregated where possible.------ The showempty flag includes spans with no postings and also postings--- with 0 amount.-summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]-summarisePostingsInDateSpan (DateSpan b e) depth showempty ps-    | null ps && (isNothing b || isNothing e) = []-    | null ps && showempty = [summaryp]-    | otherwise = summaryps'-    where-      summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))-      b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b-      e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e-      summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}--      summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps-      summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]-      anames = sort $ nub $ map paccount ps-      -- aggregate balances by account, like journalToLedger, then do depth-clipping-      (_,_,exclbalof,inclbalof) = groupPostings ps-      clippedanames = nub $ map (clipAccountName d) anames-      isclipped a = accountNameLevel a >= d-      d = fromMaybe 99999 $ depth-      balancetoshowfor a =-          (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)------------------------------------------------------------------------------------- | 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).-type TransactionsReport = (String                   -- label for the balance column, eg "balance" or "total"-                          ,[TransactionsReportItem] -- line items, one per transaction-                          )-type TransactionsReportItem = (Transaction -- the corresponding transaction-                              ,Transaction -- the transaction with postings to the current account(s) removed-                              ,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) (or total amount posted)-                              ,MixedAmount -- the running balance for the current account(s) after this transaction-                              )--triDate (t,_,_,_,_,_) = tdate t-triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"-                                           (Amount{quantity=q}):_ -> show q---- | Select transactions from the whole journal for a transactions report,--- with no \"current\" account. The end result is similar to--- "postingsReport" except it uses matchers and transaction-based report--- items and the items are most recent first. Used by eg hledger-web's--- journal view.-journalTransactionsReport :: ReportOpts -> Journal -> Matcher -> TransactionsReport-journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)-   where-     ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts-     items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts'-     -- XXX items' first element should be the full transaction with all postings------------------------------------------------------------------------------------- | Select transactions within one or more \"current\" accounts, and make a--- transactions report relative to those account(s). This means:------ 1. it shows transactions from the point of view of the current account(s).---    The transaction amount is the amount posted to the current account(s).---    The other accounts' names are provided. ------ 2. With no transaction filtering in effect other than a start date, it---    shows the accurate historical running balance for the current account(s).---    Otherwise it shows a running total starting at 0.------ Currently, reporting intervals are not supported, and report items are--- most recent first. Used by eg hledger-web's account register view.----accountTransactionsReport :: ReportOpts -> Journal -> Matcher -> Matcher -> TransactionsReport-accountTransactionsReport opts j m thisacctmatcher = (label, items)- where-     -- transactions affecting this account, in date order-     ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns $-          journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j-     -- starting balance: if we are filtering by a start date and nothing else,-     -- the sum of postings to this account before that date; otherwise zero.-     (startbal,label) | matcherIsNull m                           = (nullmixedamt,        balancelabel)-                      | matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)-                      | otherwise                                 = (nullmixedamt,        totallabel)-                      where-                        priorps = -- ltrace "priorps" $-                                  filter (matchesPosting-                                          (-- ltrace "priormatcher" $-                                           MatchAnd [thisacctmatcher, tostartdatematcher]))-                                         $ transactionsPostings ts-                        tostartdatematcher = MatchDate (DateSpan Nothing startdate)-                        startdate = matcherStartDate (effective_ opts) m-     items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts---- | Generate transactions report items from a list of transactions,--- using the provided query and current account matchers, starting balance,--- sign-setting function and balance-summing function.-accountTransactionsReportItems :: Matcher -> Maybe Matcher -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]-accountTransactionsReportItems _ _ _ _ [] = []-accountTransactionsReportItems matcher thisacctmatcher bal signfn (t:ts) =-    -- This is used for both accountTransactionsReport and journalTransactionsReport,-    -- which makes it a bit overcomplicated-    case i of Just i' -> i':is-              Nothing -> is-    where-      tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings matcher t-      (psthisacct,psotheracct) = case thisacctmatcher of Just m  -> partition (matchesPosting m) psmatched-                                                         Nothing -> ([],psmatched)-      numotheraccts = length $ nub $ map paccount psotheracct-      amt = negate $ sum $ map pamount psthisacct-      acct | isNothing thisacctmatcher = summarisePostings psmatched -- journal register-           | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct-           | otherwise          = prefix              ++ summarisePostingAccounts psotheracct-           where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt-      (i,bal') = case psmatched of-           [] -> (Nothing,bal)-           _  -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b)-                 where-                  a = signfn amt-                  b = bal + a-      is = accountTransactionsReportItems matcher thisacctmatcher bal' signfn ts---- | 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.-summarisePostingAccounts :: [Posting] -> String-summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount--filterTransactionPostings :: Matcher -> Transaction -> Transaction-filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}------------------------------------------------------------------------------------- | An accounts report is a list of account names (full and short--- variants) with their balances, appropriate indentation for rendering as--- a hierarchy, and grand total.-type AccountsReport = ([AccountsReportItem] -- line items, one per account-                      ,MixedAmount          -- total balance of all accounts-                      )-type AccountsReportItem = (AccountName  -- full account name-                          ,AccountName  -- short account name for display (the leaf name, prefixed by any boring parents immediately above)-                          ,Int          -- how many steps to indent this account (0-based account depth excluding boring parents)-                          ,MixedAmount) -- account balance, includes subs unless --flat is present---- | Select accounts, and get their balances at the end of the selected--- period, and misc. display information, for an accounts report. Used by--- eg hledger's balance command.-accountsReport :: ReportOpts -> FilterSpec -> Journal -> AccountsReport-accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec)---- | Select accounts, and get their balances at the end of the selected--- period, and misc. display information, for an accounts report. Like--- "accountsReport" but uses the new matchers. Used by eg hledger-web's--- accounts sidebar.-accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport-accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher)---- Accounts report helper.-accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport-accountsReport' opts j jtol = (items, total)-    where-      items = map mkitem interestingaccts-      interestingaccts | no_elide_ opts = acctnames-                       | otherwise = filter (isInteresting opts l) acctnames-      acctnames = sort $ tail $ flatten $ treemap aname accttree-      accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l-      total = sum $ map abalance $ ledgerTopAccounts l-      l =  jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j--      -- | Get data for one balance report line item.-      mkitem :: AccountName -> AccountsReportItem-      mkitem a = (a, adisplay, indent, abal)-          where-            adisplay | flat_ opts = a-                     | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]-                where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)-            indent | flat_ opts = 0-                   | otherwise = length interestingparents-            interestingparents = filter (`elem` interestingaccts) parents-            parents = parentAccountNames a-            abal | flat_ opts = exclusiveBalance acct-                 | otherwise = abalance acct-                 where acct = ledgerAccount l a--exclusiveBalance :: Account -> MixedAmount-exclusiveBalance = sumPostings . apostings---- | Is the named account considered interesting for this ledger's accounts report,--- following the eliding style of ledger's balance command ?-isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool-isInteresting opts l a | flat_ opts = isInterestingFlat opts l a-                       | otherwise = isInterestingIndented opts l a---- | Determine whether an account should get its own line in the --flat balance report.-isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool-isInterestingFlat opts l a = notempty || emptyflag-    where-      acct = ledgerAccount l a-      notempty = not $ isZeroMixedAmount $ exclusiveBalance acct-      emptyflag = empty_ opts---- | Determine whether an account should get its own line in the indented--- balance report.  Cf Balance module doc.-isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool-isInterestingIndented opts l a-    | numinterestingsubs == 1 && samebalanceassub && not atmaxdepth = False-    | numinterestingsubs < 2 && zerobalance && not emptyflag = False-    | otherwise = True-    where-      atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts-      emptyflag = empty_ opts-      acct = ledgerAccount l a-      zerobalance = isZeroMixedAmount inclbalance where inclbalance = abalance acct-      samebalanceassub = isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct-      numinterestingsubs = length $ filter isInterestingTree subtrees-          where-            isInterestingTree = treeany (isInteresting opts l . aname)-            subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a-----------------------------------------------------------------------------------tests_Hledger_Reports :: Test-tests_Hledger_Reports = TestList- [--  "summarisePostingsByInterval" ~: do-    summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= []--  -- ,"summarisePostingsInDateSpan" ~: do-  --   let gives (b,e,depth,showempty,ps) =-  --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)-  --   let ps =-  --           [-  --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 2]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [dollars 4]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 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"}-  --    ]-  --   ("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 [dollars 4]}-  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 10]}-  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 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 [dollars 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 [dollars 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 [dollars 15]}-  --    ]+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.BalanceReport+import Hledger.Reports.MultiBalanceReport+import Hledger.Reports.BudgetReport - ]+tests_Reports = testGroup "Reports" [+   tests_BalanceReport+  ,tests_BudgetReport+  ,tests_AccountTransactionsReport+  ,tests_EntriesReport+  ,tests_MultiBalanceReport+  ,tests_PostingsReport+  ]
+ 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/BalanceReport.hs view
@@ -0,0 +1,330 @@+{-|++Balance report, used by the balance command.++-}++{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hledger.Reports.BalanceReport (+  BalanceReport,+  BalanceReportItem,+  balanceReport,+  flatShowsExclusiveBalance,++  -- * Tests+  tests_BalanceReport+)+where++import Data.Time.Calendar++import Hledger.Data+import Hledger.Query+import Hledger.Utils+import Hledger.Reports.MultiBalanceReport (multiBalanceReport)+import Hledger.Reports.ReportOptions+import Hledger.Reports.ReportTypes+++-- | A simple balance report. It has:+--+-- 1. a list of items, one per account, each containing:+--+--   * the full account name+--+--   * the Ledger-style elided short account name+--     (the leaf account name, prefixed by any boring parents immediately above);+--     or with --flat, the full account name again+--+--   * the number of indentation steps for rendering a Ledger-style account tree,+--     taking into account elided boring parents, --no-elide and --flat+--+--   * an amount+--+-- 2. the total of all amounts+--+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++-- | Enabling this makes balance --flat --empty also show parent accounts without postings,+-- in addition to those with postings and a zero balance. Disabling it shows only the latter.+-- No longer supported, but leave this here for a bit.+-- flatShowsPostinglessAccounts = True++-- | Generate a simple balance report, containing the matched accounts and+-- their balances (change of balance) during the specified period.+-- 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+    report = multiBalanceReport rspec j+    rows = [( prrFullName row+            , prrDisplayName row+            , prrIndent row+            , prrTotal row+            ) | row <- prRows report]+    total = prrTotal $ prTotals report+++-- tests++Right samplejournal2 =+  journalBalanceTransactions defbalancingopts+    nulljournal{+      jtxns = [+        txnTieKnot Transaction{+          tindex=0,+          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=mixedAmount (usd 1)}+            ,posting {paccount="income:salary", pamount=missingmixedamt}+            ],+          tprecedingcomment=""+        }+      ]+    }++tests_BalanceReport = testGroup "BalanceReport" [++  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: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)))+       ],+       mixedAmount (usd 0))++    ,testCase "with --tree" $+     (defreportspec{_rsReportOpts=defreportopts{accountlistmode_=ALTree}}, samplejournal) `gives`+      ([+        ("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)))+       ],+       mixedAmount (usd 0))++    ,testCase "with --depth=N" $+     (defreportspec{_rsReportOpts=defreportopts{depth_=DepthSpec (Just 1) []}}, samplejournal) `gives`+      ([+       ("expenses",    "expenses",     0, mixedAmount (usd 2))+       ,("income",      "income",      0, mixedAmount (usd (-2)))+       ],+       mixedAmount (usd 0))++    ,testCase "with depth:N" $+     (defreportspec{_rsQuery=Depth 1}, samplejournal) `gives`+      ([+       ("expenses",    "expenses",     0, mixedAmount (usd 2))+       ,("income",      "income",      0, mixedAmount (usd (-2)))+       ],+       mixedAmount (usd 0))++    ,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,mixedAmount (usd 1))+       ,("income:salary","income:salary",0,mixedAmount (usd (-1)))+       ],+       mixedAmount (usd 0))++    ,testCase "with desc:" $+     (defreportspec{_rsQuery=Desc $ toRegexCI' "income"}, samplejournal) `gives`+      ([+        ("assets:bank:checking","assets:bank:checking",0,mixedAmount (usd 1))+       ,("income:salary","income:salary",0, mixedAmount (usd (-1)))+       ],+       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, mixedAmount (usd 1))+        ,("income:salary","income:salary",0, mixedAmount (usd (-1)))+        ],+        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)++++  {-+      ,testCase "accounts report with account pattern o" ~:+       defreportopts{patterns_=["o"]} `gives`+       ["                  $1  expenses:food"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"--------------------"+       ,"                 $-1"+       ]++      ,testCase "accounts report with account pattern o and --depth 1" ~:+       defreportopts{patterns_=["o"],depth_=(Just 1, [])} `gives`+       ["                  $1  expenses"+       ,"                 $-2  income"+       ,"--------------------"+       ,"                 $-1"+       ]++      ,testCase "accounts report with account pattern a" ~:+       defreportopts{patterns_=["a"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"                 $-1  income:salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                 $-1"+       ]++      ,testCase "accounts report with account pattern e" ~:+       defreportopts{patterns_=["e"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"                  $2  expenses"+       ,"                  $1    food"+       ,"                  $1    supplies"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                   0"+       ]++      ,testCase "accounts report with unmatched parent of two matched subaccounts" ~:+       defreportopts{patterns_=["cash","saving"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"--------------------"+       ,"                 $-1"+       ]++      ,testCase "accounts report with multi-part account name" ~:+       defreportopts{patterns_=["expenses:food"]} `gives`+       ["                  $1  expenses:food"+       ,"--------------------"+       ,"                  $1"+       ]++      ,testCase "accounts report with negative account pattern" ~:+       defreportopts{patterns_=["not:assets"]} `gives`+       ["                  $2  expenses"+       ,"                  $1    food"+       ,"                  $1    supplies"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                  $1"+       ]++      ,testCase "accounts report negative account pattern always matches full name" ~:+       defreportopts{patterns_=["not:e"]} `gives`+       ["--------------------"+       ,"                   0"+       ]++      ,testCase "accounts report negative patterns affect totals" ~:+       defreportopts{patterns_=["expenses","not:food"]} `gives`+       ["                  $1  expenses:supplies"+       ,"--------------------"+       ,"                  $1"+       ]++      ,testCase "accounts report with -E shows zero-balance accounts" ~:+       defreportopts{patterns_=["assets"],empty_=True} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank"+       ,"                   0      checking"+       ,"                  $1      saving"+       ,"                 $-2    cash"+       ,"--------------------"+       ,"                 $-1"+       ]++      ,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 $ journalToCost ToCost j -- enable cost basis adjustment+         balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is`+           ["                $500  a:b"+           ,"               $-500  c:d"+           ,"--------------------"+           ,"                   0"+           ]+  -}+     ]++ ]+
+ Hledger/Reports/BudgetReport.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hledger.Reports.BudgetReport (+  BudgetGoal,+  BudgetTotal,+  BudgetAverage,+  BudgetCell,+  BudgetReportRow,+  BudgetReport,+  budgetReport,+  -- * Tests+  tests_BudgetReport+)+where++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.Utils+import Hledger.Reports.ReportOptions+import Hledger.Reports.ReportTypes+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)+-- | 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++_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 = (_rsReportOpts rspec){ accountlistmode_ = ALTree }+    -- ropts = _rsReportOpts rspec+    showunbudgeted = empty_ ropts++    budgetedaccts =+      dbg3 "budgetedacctsinperiod" $+      S.fromList $+      expandAccountNames $+      accountNamesFromPostings $+      concatMap tpostings $+      concatMap (\pt -> runPeriodicTransaction False pt reportspan) $+      jperiodictxns j++    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+    treeActualBalance = these bdincludingsubs (const nullmixedamt) (const . bdincludingsubs)+    flatActualBalance = fromMaybe nullmixedamt . fst++-- | 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+        (actuals, budgets) = unzip $ toList xs+        (actualtotal, actualavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes actuals+        (budgettotal, budgetavg) = bimap Just Just . sumAndAverageMixedAmounts $ catMaybes budgets++    theseToMaybe (This a) = (Just a, Nothing)+    theseToMaybe (That b) = (Just nullmixedamt, Just b)+    theseToMaybe (These a b) = (Just a, Just b)++-- | 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+        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++    -- 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 =+      dbg5 "budget goal txns" $+      [makeBudgetTxn t+      | 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+--    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 -E/--empty.+--+journalWithBudgetAccountNames :: S.Set AccountName -> Bool -> Journal -> Journal+journalWithBudgetAccountNames budgetedaccts showunbudgeted j =+  dbg5With (("budget account names: "++).pshow.journalAccountNamesUsed) $+  j { jtxns = remapTxn <$> jtxns j }+  where+    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+        budgetedparent = find (`S.member` budgetedaccts) $ parentAccountNames a+        u = unbudgetedAccountName+++-- tests++tests_BudgetReport = testGroup "BudgetReport" [+ ]
+ Hledger/Reports/EntriesReport.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-|++Journal entries report, used by the print command.++-}++module Hledger.Reports.EntriesReport (+  EntriesReport,+  EntriesReportItem,+  entriesReport,+  -- * Tests+  tests_EntriesReport+)+where++import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Time (fromGregorian)++import Hledger.Data+import Hledger.Query (Query(..), filterQuery, queryIsDepth)+import Hledger.Reports.ReportOptions+import Hledger.Utils+++-- | A journal entries report is a list of whole transactions as+-- originally entered in the journal (mostly). This is used by eg+-- hledger's print command and hledger-web's journal entries view.+type EntriesReport = [EntriesReportItem]+type EntriesReportItem = Transaction++-- | Select transactions for an entries report.+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 = 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/PostingsReport.hs view
@@ -0,0 +1,458 @@+{-|++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 (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.Reports.ReportOptions+++-- | 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 = [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 :: ReportSpec -> Journal -> PostingsReport+postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items+    where+      (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 rspec j reportspan++      -- 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+          summariseps = summarisePostingsByInterval whichdate (dsFlatDepth depthSpec) showempty colspans+          showempty = empty_ || average_++      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+          -- 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+          postings | historical = if sortspec_ /= defsortspec +                        then error' "--historical and --sort should not be used together" +                        else sortedps+                   | otherwise = sortedps++-- | 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++-- | 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 :: ReportSpec -> Journal -> DateSpan -> ([Posting],[Posting])+matchedPostingsBeforeAndDuring rspec@ReportSpec{_rsReportOpts=ropts,_rsQuery=q} j reportspan =+    dbg5 "beforeps, duringps" $ span (beforestartq `matchesPosting`) beforeandduringps+  where+    beforestartq = dbg3 "beforestartq" $ dateqtype $ DateSpan Nothing (Exact <$> spanStart reportspan)+    beforeandduringps =+        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+        depthless  = filterQuery (not . queryIsDepth)+        dateless   = filterQuery (not . queryIsDateOrDate2)+        beforeendq = dateqtype $ DateSpan Nothing (Exact <$> spanEnd reportspan)++    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 periods attached) summary postings.+postingsReportItems :: [(Posting,Maybe Period)] -> (Posting,Maybe Period) -> WhichDate -> DepthSpec -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem]+postingsReportItems [] _ _ _ _ _ _ = []+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 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+  )++-- | Convert a list of postings into summary postings, one per interval,+-- aggregated to the specified depth if any.+-- 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. 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+-- postings in the span are aggregated into a single posting with+-- account name "...".+--+-- The showempty flag includes spans with no postings and also postings+-- with 0 amount.+--+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 = testGroup "PostingsReport" [++   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 (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)+     -- ,(Just (2008-06-02,"save"),assets:bank:saving               $1,$1)+     -- ,(Nothing,assets:bank:checking            $-1,0)+     -- ,(Just (2008-06-03,"eat & shop"),expenses:food                    $1,$1)+     -- ,(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)++    {-+        let opts = defreportopts+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank:checking             $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank:saving               $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"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+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"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+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank:checking             $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank:saving               $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ]++      ,"postings report sorts by date" ~:+       do+        j <- readJournal'' $ unlines+            ["2008/02/02 a"+            ,"  b  1"+            ,"  c"+            ,""+            ,"2008/01/01 d"+            ,"  e  1"+            ,"  f"+            ]+        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+        let opts = defreportopts{patterns_=["cash"]}+        (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+        let opts = defreportopts{patterns_=["cAsH"]}+        (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+        "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_=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_=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"+         ,"                                expenses:food                    $1            0"+         ,"                                expenses:supplies                $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"                                income:salary                   $-1          $-1"+         ,"                                liabilities:debts                $1            0"+         ]+        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_=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+        let opts = defreportopts{depth_=Just 2}+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank                      $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank                      $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank                      $1           $1"+         ,"                                assets:bank                     $-1            0"+         ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"2008/12/31 pay off              liabilities:debts                $1           $1"+         ,"                                assets:bank                     $-1            0"+         ]++    -}++  ,testCase "summarisePostingsByInterval" $+    summarisePostingsByInterval PrimaryDate Nothing False Nothing [] @?= []++  -- ,tests_summarisePostingsInDateSpan = [+    --  "summarisePostingsInDateSpan" ~: do+    --   let gives (b,e,depth,showempty,ps) =+    --           (summarisePostingsInDateSpan (DateSpan b e) depth showempty ps `is`)+    --   let ps =+    --           [+    --            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=fromGregorian 2008 01 01,lpdescription="- 2008/12/31"}+    --    ]+    --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`+    --    [+    --     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=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=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=fromGregorian 2008 01 01,lpdescription="- 2008/12/31",lpaccount="",lpamount=mixedAmount (usd 15)}+    --    ]++ ]
+ Hledger/Reports/ReportOptions.hs view
@@ -0,0 +1,1026 @@+{-|++Options common to most hledger reports.++-}++{-# 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
@@ -0,0 +1,249 @@+{- |+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+( PeriodicReport(..)+, PeriodicReportRow(..)++, 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++type Change  = MixedAmount  -- ^ A change in balance during a certain period.+type Balance = MixedAmount  -- ^ An ending balance as of some date.+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 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+  { 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)++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/Utils.hs view
@@ -1,427 +1,333 @@ {-|--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. -} -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 Debug.Trace,-                          -- module Text.RegexPR,-                          -- module Test.HUnit,-                          -- module Text.Printf,-                          ---- all of this one:-                          module Hledger.Utils,-                          Debug.Trace.trace-                          ---- and this for i18n - needs to be done in each module I think:-                          -- module Hledger.Utils.UTF8-                          )-where-import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)-import Data.Char-import Data.List-import Data.Maybe-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Tree-import Debug.Trace-import System.Info (os)-import Test.HUnit-import Text.ParserCombinators.Parsec-import Text.Printf-import Text.RegexPR--- import qualified Data.Map as Map--- --- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)--- import Hledger.Utils.UTF8+{-# LANGUAGE CPP #-} --- strings+module Hledger.Utils ( -lowercase = map toLower-uppercase = map toUpper+  -- * Functions+  applyN,+  mapM',+  sequence',+  curry2,+  uncurry2,+  curry3,+  uncurry3,+  curry4,+  uncurry4, -strip = lstrip . rstrip-lstrip = dropWhile (`elem` " \t")-rstrip = reverse . lstrip . reverse+  divideSafe, -elideLeft width s =-    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s+  -- * Lists+  maximum',+  maximumStrict,+  minimumStrict,+  splitAtElement,+  sumStrict,+  all1,+  takeUntilFails,+  takeUntilFailsNE, -elideRight width s =-    if length s > width then take (width - 2) s ++ ".." else s+  -- * Trees+  treeLeaves, -underline :: String -> String-underline s = s' ++ replicate (length s) '-' ++ "\n"-    where s'-            | last s == '\n' = s-            | otherwise = s ++ "\n"+  -- * Tuples+  first3,+  second3,+  third3,+  first4,+  second4,+  third4,+  fourth4,+  first5,+  second5,+  third5,+  fourth5,+  fifth5,+  first6,+  second6,+  third6,+  fourth6,+  fifth6,+  sixth6, --- | Wrap a string in single quotes, and \-prefix any embedded single--- quotes, if it contains whitespace and is not already single- or--- double-quoted.-quoteIfSpaced :: String -> String-quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s-                | not $ any (`elem` s) whitespacechars = s-                | otherwise = "'"++escapeSingleQuotes s++"'"-                  where escapeSingleQuotes = regexReplace "'" "\'"+  -- * Misc+  multicol,+  numDigitsInt,+  numDigitsInteger,+  makeHledgerClassyLenses, --- | Quote-aware version of words - don't split on spaces which are inside quotes.--- NB correctly handles "a'b" but not "''a''".-words' :: String -> [String]-words' = map stripquotes . fromparse . parsewith p-    where-      p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline-             -- eof-             return ss-      pattern = many (noneOf whitespacechars)-      quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""+  -- * 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, --- | Quote-aware version of unwords - single-quote strings which contain whitespace-unwords' :: [String] -> String-unwords' = unwords . map singleQuoteIfNeeded+  -- * Tests+  tests_Utils,+  module Hledger.Utils.Test, -singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"-                      | otherwise = s+)+where -whitespacechars = " \t\n\r"+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) --- | 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+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 -isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''-isSingleQuoted _ = False -isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'-isDoubleQuoted _ = False--unbracket :: String -> String-unbracket s-    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s-    | otherwise = s---- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.-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 (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.-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 (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Compose strings vertically and right-aligned.-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---- | Convert a multi-line string to a rectangular string left-padded to the specified 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.-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 ' '---- encoded platform strings---- | A platform string is a string value from or for the operating system,--- such as a file path or command-line argument (or environment variable's--- name or value ?). On some platforms (such as unix) these are not real--- unicode strings but have some encoding such as UTF-8. This alias does--- no type enforcement but aids code clarity.-type PlatformString = String---- | Convert a possibly encoded platform string to a real unicode string.--- We decode the UTF-8 encoding recommended for unix systems--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and leave anything else unchanged.-fromPlatformString :: PlatformString -> String-fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s---- | Convert a unicode string to a possibly encoded platform string.--- On unix we encode with the recommended UTF-8--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and elsewhere we leave it unchanged.-toPlatformString :: String -> PlatformString-toPlatformString = case os of-                     "unix" -> UTF8.encodeString-                     "linux" -> UTF8.encodeString-                     "darwin" -> UTF8.encodeString-                     _ -> id---- | A version of error that's better at displaying unicode.-error' :: String -> a-error' = error . toPlatformString+-- Functions --- | A version of userError that's better at displaying unicode.-userError' :: String -> IOError-userError' = userError . toPlatformString+-- | Apply a function the specified number of times,+-- which should be > 0 (otherwise does nothing).+-- Possibly uses O(n) stack ?+applyN :: Int -> (a -> a) -> a -> a+applyN n f | n < 1     = id+           | otherwise = (!! n) . iterate f+-- from protolude, compare+-- applyN :: Int -> (a -> a) -> a -> a+-- applyN n f = X.foldr (.) identity (X.replicate n f) --- math+-- | Like mapM but uses sequence'.+{-# INLINABLE mapM' #-}+mapM' :: Monad f => (a -> f b) -> [a] -> f [b]+mapM' f = sequence' . map f -difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]+-- | 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' --- regexps+curry2 :: ((a, b) -> c) -> a -> b -> c+curry2 f x y = f (x, y) --- regexMatch :: String -> String -> MatchFun Maybe-regexMatch r s = matchRegexPR r s+uncurry2 :: (a -> b -> c) -> (a, b) -> c+uncurry2 f (x, y) = f x y --- regexMatchCI :: String -> String -> MatchFun Maybe-regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s+curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 f x y z = f (x, y, z) -regexMatches :: String -> String -> Bool-regexMatches r s = isJust $ matchRegexPR r s+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z -regexMatchesCI :: String -> String -> Bool-regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s+curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e+curry4 f w x y z = f (w, x, y, z) -containsRegex = regexMatchesCI+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (w, x, y, z) = f w x y z -regexReplace :: String -> String -> String -> String-regexReplace r repl s = gsubRegexPR r repl s+-- | Division, returning 0 when the denominator is 0.+divideSafe :: (Eq a, Fractional a) => a -> a -> a+divideSafe _ 0 = 0+divideSafe a b = a / b -regexReplaceCI :: String -> String -> String -> String-regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s+-- Lists -regexReplaceBy :: String -> (String -> String) -> String -> String-regexReplaceBy r replfn s = gsubRegexPRBy r replfn s+-- | Total version of maximum, for integral types, giving 0 for an empty list.+maximum' :: Integral a => [a] -> a+maximum' [] = 0+maximum' xs = maximumStrict xs -regexToCaseInsensitive :: String -> String-regexToCaseInsensitive r = "(?i)"++ r+-- | Strict version of maximum that doesn’t leak space+{-# INLINABLE maximumStrict #-}+maximumStrict :: Ord a => [a] -> a+maximumStrict = foldl1' max --- lists+-- | Strict version of minimum that doesn’t leak space+{-# INLINABLE minimumStrict #-}+minimumStrict :: Ord a => [a] -> a+minimumStrict = foldl1' min  splitAtElement :: Eq a => a -> [a] -> [[a]]-splitAtElement e l = -    case dropWhile (e==) l of-      [] -> []-      l' -> first : splitAtElement e rest-        where-          (first,rest) = break (e==) l'---- trees--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---- debugging---- | trace (print on stdout at runtime) a showable expression--- (for easily tracing in the middle of a complex expression)-strace :: Show a => a -> a-strace a = trace (show a) a---- | labelled trace - like strace, with a label prepended-ltrace :: Show a => String -> a -> a-ltrace l a = trace (l ++ ": " ++ show a) a---- | monadic trace - like strace, but works as a standalone line in a monad-mtrace :: (Monad m, Show a) => a -> m a-mtrace a = strace a `seq` return a---- | trace an expression using a custom show function-tracewith :: (a -> String) -> a -> a-tracewith f e = trace (f e) e---- parsing---- | Backtracking choice, use this when alternatives share a prefix.--- Consumes no input if all choices fail.-choice' :: [GenParser tok st a] -> GenParser tok st a-choice' = choice . map Text.ParserCombinators.Parsec.try--parsewith :: Parser a -> String -> Either ParseError a-parsewith p = parse p ""--parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a-parseWithCtx ctx p = runParser p ctx ""--fromparse :: Either ParseError a -> a-fromparse = either parseerror id--parseerror :: ParseError -> a-parseerror e = error' $ showParseError e+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 -showParseError :: ParseError -> String-showParseError e = "parse error at " ++ show e+-- | Strict version of sum that doesn’t leak space+{-# INLINABLE sumStrict #-}+sumStrict :: Num a => [a] -> a+sumStrict = foldl' (+) 0 -showDateParseError :: ParseError -> String-showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)+-- | Version of all that fails on an empty list.+{-# INLINABLE all1 #-}+all1 :: (a -> Bool) -> [a] -> Bool+all1 _ [] = False+all1 p as = all p as -nonspace :: GenParser Char st Char-nonspace = satisfy (not . isSpace)+-- | 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 -spacenonewline :: GenParser Char st Char-spacenonewline = satisfy (`elem` " \v\f\t")+-- | 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]) [] -restofline :: GenParser Char st String-restofline = anyChar `manyTill` newline+-- Trees --- time+-- | 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 -getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t+-- Tuples --- testing+first3  (x,_,_) = x+second3 (_,x,_) = x+third3  (_,_,x) = x --- | Get a Test's label, or the empty string.-tname :: Test -> String-tname (TestLabel n _) = n-tname _ = ""+first4  (x,_,_,_) = x+second4 (_,x,_,_) = x+third4  (_,_,x,_) = x+fourth4 (_,_,_,x) = x --- | Flatten a Test containing TestLists into a list of single tests.-tflatten :: Test -> [Test]-tflatten (TestLabel _ t@(TestList _)) = tflatten t-tflatten (TestList ts) = concatMap tflatten ts-tflatten t = [t]+first5  (x,_,_,_,_) = x+second5 (_,x,_,_,_) = x+third5  (_,_,x,_,_) = x+fourth5 (_,_,_,x,_) = x+fifth5  (_,_,_,_,x) = x --- | Filter TestLists in a Test, recursively, preserving the structure.-tfilter :: (Test -> Bool) -> Test -> Test-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts-tfilter _ t = t+first6  (x,_,_,_,_,_) = x+second6 (_,x,_,_,_,_) = x+third6  (_,_,x,_,_,_) = x+fourth6 (_,_,_,x,_,_) = x+fifth6  (_,_,_,_,x,_) = x+sixth6  (_,_,_,_,_,x) = x --- | Simple way to assert something is some expected value, with no label.-is :: (Eq a, Show a) => a -> a -> Assertion-a `is` e = assertEqual "" e a+-- Misc --- | Assert a parse result is successful, printing the parse error on failure.-assertParse :: (Either ParseError a) -> Assertion-assertParse parse = either (assertFailure.show) (const (return ())) parse+-- | 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 --- | Assert a parse result is successful, printing the parse error on failure.-assertParseFailure :: (Either ParseError a) -> Assertion-assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse+-- | 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) --- | Assert a parse result is some expected value, printing the parse error on failure.-assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion-assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse+-- | 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 -printParseError :: (Show a) => a -> IO ()-printParseError e = do putStr "parse error at "; print e+-- | 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                      = [] --- misc+    -- 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+        ] -isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _        = False+    -- 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 -isRight :: Either a b -> Bool-isRight = not . isLeft+    -- Fields of ReportOpts which need to update the Query when they are updated.+    queryFields = Set.fromList ["period", "statuses", "depth", "date2", "real", "querystring"] --- | Apply a function the specified number of times. Possibly uses O(n) stack ?-applyN :: Int -> (a -> a) -> a -> a-applyN n f = (!! n) . iterate f+tests_Utils = testGroup "Utils" [+  tests_Text+  ]
+ Hledger/Utils/Debug.hs view
@@ -0,0 +1,653 @@+{- | ++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 (++  -- * 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+  ,dbg1+  ,dbg2+  ,dbg3+  ,dbg4+  ,dbg5+  ,dbg6+  ,dbg7+  ,dbg8+  ,dbg9++  -- * Trace/log a value in IO+  ,dbgIO+  ,dbg0IO+  ,dbg1IO+  ,dbg2IO+  ,dbg3IO+  ,dbg4IO+  ,dbg5IO+  ,dbg6IO+  ,dbg7IO+  ,dbg8IO+  ,dbg9IO++  -- * 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.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)++import Hledger.Utils.IO (progArgs, pshow, 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++-- | The progam name, with any ".log" suffix removed.+progName :: String+progName =+  if ".log" `isSuffixOf` modifiedProgName+  then reverse $ drop 4 $ reverse modifiedProgName+  else modifiedProgName++-- | 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 dropWhile (/="--debug") progArgs of+               ["--debug"]   -> 1+               "--debug":n:_ -> readDef 1 n+               _             ->+                 case take 1 $ filter ("--debug" `isPrefixOf`) progArgs of+                   ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v+                   _                                   -> 0++-- | 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 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 = const id+    | otherwise = \lbl a -> trace (labelledPretty True lbl a) a++-- 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 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)+++-- | 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 = dbg 1++dbg2 :: Show a => String -> a -> a+dbg2 = dbg 2++dbg3 :: Show a => String -> a -> a+dbg3 = dbg 3++dbg4 :: Show a => String -> a -> a+dbg4 = dbg 4++dbg5 :: Show a => String -> a -> a+dbg5 = dbg 5++dbg6 :: Show a => String -> a -> a+dbg6 = dbg 6++dbg7 :: Show a => String -> a -> a+dbg7 = dbg 7++dbg8 :: Show a => String -> a -> a+dbg8 = dbg 8++dbg9 :: Show a => String -> a -> a+dbg9 = dbg 9+++-- | 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 = dbgIO 0++dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg1IO = dbgIO 1++dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg2IO = dbgIO 2++dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg3IO = dbgIO 3++dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg4IO = dbgIO 4++dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg5IO = dbgIO 5++dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg6IO = dbgIO 6++dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg7IO = dbgIO 7++dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg8IO = dbgIO 8++dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()+dbg9IO = dbgIO 9+++-- | Like dbg, but with a custom show function.+dbgWith :: Int -> (a -> String) -> a -> a+dbgWith = if shouldLog then logAtWith else traceAtWith++dbg0With :: (a -> String) -> a -> a+dbg0With = dbgWith 0++dbg1With :: (a -> String) -> a -> a+dbg1With = dbgWith 1++dbg2With :: (a -> String) -> a -> a+dbg2With = dbgWith 2++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
@@ -0,0 +1,593 @@+{-# 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,++  -- * SourcePos+  SourcePos(..),+  mkPos,+  unPos,+  initialPos,+  sourcePosPretty,+  sourcePosPairPretty,++  -- * Parsers and helpers+  choice',+  choiceInState,+  surroundedBy,+  parsewith,+  runTextParser,+  rtp,+  parsewithString,+  parseWithState,+  parseWithState',+  fromparse,+  parseerror,+  showDateParseError,+  nonspace,+  isNewline,+  isNonNewlineSpace,+  restofline,+  eolof,+  spacenonewline,+  skipNonNewlineSpaces,+  skipNonNewlineSpaces1,+  skipNonNewlineSpaces',++  -- ** 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 (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.Char+-- import Text.Megaparsec.Debug (dbg)++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 HledgerParseErrorData String a++-- | A parser of strict text to some type.+type SimpleTextParser = Parsec HledgerParseErrorData Text  -- XXX an "a" argument breaks the CsvRulesParser declaration somehow++-- | A parser of text that runs in some monad.+type TextParser m a = ParsecT HledgerParseErrorData Text m a++-- class (Stream s, MonadPlus m) => MonadParsec e s m +-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m ()++-- | 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+choice' = choice . map try++-- | Backtracking choice, use this when alternatives share a prefix.+-- Consumes no input if all choices fail.+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+surroundedBy p = between p p++parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a+parsewith p = runParser p ""++-- | 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.+-- See also: runTextParser, runJournalParser.+parseWithState+  :: Monad m+  => st+  -> StateT st (ParsecT HledgerParseErrorData Text m) a+  -> Text+  -> m (Either HledgerParseErrors a)+parseWithState ctx p = runParserT (evalStateT p ctx) ""++parseWithState'+  :: (Stream s)+  => st+  -> StateT st (ParsecT e s Identity) a+  -> s+  -> (Either (ParseErrorBundle s e) a)+parseWithState' ctx p = runParser (evalStateT p ctx) ""++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 = errorWithoutStackTrace $ showParseError e  -- PARTIAL:++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 ", " $ 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 = not (isNewline c) && isSpace c++spacenonewline :: (Stream s, Char ~ Token s) => ParsecT HledgerParseErrorData s m Char+spacenonewline = satisfy isNonNewlineSpace+{-# INLINABLE spacenonewline #-}++restofline :: TextParser m String+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 = 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
@@ -0,0 +1,284 @@+{-|++Easy regular expression helpers, currently based on regex-tdfa. These should:++- be cross-platform, not requiring C libraries++- support unicode++- support extended regular expressions++- support replacement, with backreferences etc.++- support splitting++- have mnemonic names++- have simple monomorphic types++- 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.++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+  ,Replacement+  ,RegexError+   -- * total regex operations+  ,regexMatch+  ,regexMatchText+  ,regexMatchTextGroups+  ,regexReplace+  ,regexReplaceUnmemo+  ,regexReplaceAllBy+  )+where++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(..), defaultCompOpt, defaultExecOpt,+  makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,+  RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)+  )+++-- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax.+data Regexp+  = Regexp   { reString :: Text, reCompiled :: Regex }+  | RegexpCI { reString :: Text, reCompiled :: Regex }++instance Eq Regexp where+  Regexp   s1 _ == Regexp   s2 _ = s1 == s2+  RegexpCI s1 _ == RegexpCI s2 _ = s1 == s2+  _ == _ = False++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++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 "++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++instance ToJSON Regexp where+  toJSON (Regexp   s _) = String $ "Regexp "   <> s+  toJSON (RegexpCI s _) = String $ "RegexpCI " <> s++instance RegexLike Regexp String where+  matchOnce = matchOnce . reCompiled+  matchAll = matchAll . reCompiled+  matchCount = matchCount . reCompiled+  matchTest = matchTest . reCompiled+  matchAllText = matchAllText . reCompiled+  matchOnceText = matchOnceText . reCompiled++instance RegexContext Regexp String String where+  match = match . reCompiled+  matchM = matchM . reCompiled++instance NFData Regexp where rnf = rwhnf++-- 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++-- 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++-- | 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++-- Convert a Regexp string to a compiled Regex, throw an error+toRegex' :: Text -> Regexp+toRegex' = either errorWithoutStackTrace id . toRegex++-- Like toRegex', but make a case-insensitive Regex.+toRegexCI' :: Text -> Regexp+toRegexCI' = either errorWithoutStackTrace id . toRegexCI++-- | 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++-- | 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++--------------------------------------------------------------------------------+-- 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+    -- 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++-- 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+++-- 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+    (_, 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
@@ -0,0 +1,241 @@+-- | String formatting helpers, starting to get a bit out of control.++module Hledger.Utils.String (+ takeEnd,+ -- * misc+ capitalise,+ lowercase,+ uppercase,+ underline,+ stripbrackets,+ -- quoting+ quoteIfNeeded,+ singleQuoteIfNeeded,+ quoteForCommandLine,+ -- quotechars,+ -- whitespacechars,+ words',+ stripAnsi,+ -- * single-line layout+ strip,+ lstrip,+ rstrip,+ strip1Char,+ stripBy,+ strip1By,+ chomp,+ chomp1,+ singleline,+ elideLeft,+ elideRight,+ formatString,+ -- * wide-character-aware layout+ charWidth,+ strWidth,+ strWidthAnsi,+ takeWidth,+ ) where+++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 (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++-- | Remove leading and trailing whitespace.+strip :: String -> String+strip = lstrip . rstrip++-- | Remove leading whitespace.+lstrip :: String -> String+lstrip = dropWhile isSpace++-- | Remove trailing whitespace.+rstrip :: String -> String+rstrip = reverse . lstrip . reverse++-- | 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 ".." ++ takeEnd (width - 2) s else s++elideRight :: Int -> String -> String+elideRight width s =+    if length s > width then take (width - 2) s ++ ".." else s++-- | 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"++underline :: String -> String+underline s = s' ++ replicate (length s) '-' ++ "\n"+    where s'+            | last s == '\n' = s+            | otherwise = s ++ "\n"++-- | 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++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.+-- Does not work for strings containing single quotes.+singleQuoteIfNeeded :: String -> String+singleQuoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = singleQuote s+                      | otherwise = s++-- | Prepend and append single quotes to a string.+singleQuote :: String -> String+singleQuote s = "'"++s++"'"++-- | 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++-- | 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  -- PARTIAL+    where+      p = (singleQuotedPattern <|> doubleQuotedPattern <|> patterns) `sepBy` skipNonNewlineSpaces1+          -- eof+      patterns = many (noneOf whitespacechars)+      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")+      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")++-- | 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 $ tailErr s else s  -- PARTIAL tailErr won't fail because isDoubleQuoted++isSingleQuoted s@(_:_:_) = headErr s == '\'' && last s == '\''  -- PARTIAL headErr, last will succeed because of pattern+isSingleQuoted _ = False++isDoubleQuoted s@(_:_:_) = headErr s == '"' && last s == '"'  -- PARTIAL headErr, last will succeed because of pattern+isDoubleQuoted _ = False++-- Functions below treat wide (eg CJK) characters as double-width.++-- | Double-width-character-aware string truncation. Take as many+-- characters as possible from a string without exceeding the+-- specified width. Eg takeWidth 3 "りんご" = "り".+takeWidth :: Int -> String -> String+takeWidth _ ""     = ""+takeWidth 0 _      = ""+takeWidth w (c:cs) | cw <= w   = c:takeWidth (w-cw) cs+                   | otherwise = ""+  where cw = charWidth c++-- | 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++-- | Alias for 'realLength'.+strWidth :: String -> Int+strWidth = realLength++-- | Strip ANSI escape sequences from a string.+--+-- >>> stripAnsi "\ESC[31m-1\ESC[m"+-- "-1"+stripAnsi :: String -> String+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
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hledger.Utils.Test (+   module Test.Tasty+  ,module Test.Tasty.HUnit+  -- ,module QC+  -- ,module SC+  ,assertLeft+  ,assertRight+  ,assertParse+  ,assertParseEq+  ,assertParseEqOn+  ,assertParseError+  ,assertParseE+  ,assertParseEqE+  ,assertParseErrorE+  ,assertParseStateOn+)+where++import Control.Monad (unless)+import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, withExceptT)+import Control.Monad.State.Strict (StateT, evalStateT, execStateT)+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 Hledger.Utils.IO (pshow)+import Hledger.Utils.Parse+  ( HledgerParseErrorData,+    FinalParseError,+    attachSource,+    customErrorBundlePretty,+    finalErrorBundlePretty,+  )++-- * tasty helpers++-- TODO: pretty-print values in failure messages++-- | 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 ++ ")"++-- | 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 ++ ")"++-- | 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 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)++-- | 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 ())++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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)++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)++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 ())++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++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++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
@@ -0,0 +1,295 @@+-- | Text formatting helpers, ported from String as needed.+-- There may be better alternatives out there.++{-# LANGUAGE OverloadedStrings #-}++module Hledger.Utils.Text+  (+  -- * misc+  textCapitalise,+  -- underline,+  -- stripbrackets,+  textUnbracket,+  wrap,+  textChomp,+  -- quoting+  quoteIfSpaced,+  textQuoteIfNeeded,+  -- singleQuoteIfNeeded,+  -- quotechars,+  -- whitespacechars,+  escapeDoubleQuotes,+  escapeBackslash,+  -- escapeSingleQuotes,+  -- escapeQuotes,+  -- words',+  stripquotes,+  -- isSingleQuoted,+  -- isDoubleQuoted,+  -- * single-line layout+  -- elideLeft,+  textElideRight,+  formatText,+  -- * multi-line layout+  textConcatTopPadded,+  textConcatBottomPadded,+  fitText,+  linesPrepend,+  linesPrepend2,+  unlinesB,+  -- * wide-character-aware layout+  WideBuilder(..),+  wbToText,+  wbFromText,+  wbUnpack,+  textTakeWidth,+  -- * Reading+  readDecimal,+  -- * tests+  tests_Text+  )+where++import Data.Char (digitToInt)+import Data.Default (def)+import Data.Maybe (catMaybes)+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 Text.DocLayout (charWidth, realLength)++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)+++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++-- elideLeft :: Int -> String -> String+-- elideLeft width s =+--     if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s++textElideRight :: Int -> Text -> Text+textElideRight width t =+    if T.length t > width then T.take (width - 2) t <> ".." else t++-- | 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'+--             | last s == '\n' = s+--             | otherwise = s ++ "\n"++-- | Wrap a string in double quotes, and \-prefix any embedded single+-- quotes, if it contains whitespace and is not already single- or+-- double-quoted.+quoteIfSpaced :: T.Text -> T.Text+quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = 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+-- -- double-quoted.+-- quoteIfSpaced :: String -> String+-- quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s+--                 | not $ any (`elem` s) whitespacechars = s+--                 | otherwise = "'"++escapeSingleQuotes s++"'"++-- -- | Double-quote this string if it contains whitespace, single quotes+-- -- or double-quotes, escaping the quotes as needed.+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.+-- singleQuoteIfNeeded :: String -> String+-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"+--                       | otherwise = s++quotechars, whitespacechars :: [Char]+quotechars      = "'\""+whitespacechars = " \t\n\r"++escapeDoubleQuotes :: T.Text -> T.Text+escapeDoubleQuotes = T.replace "\"" "\\\""++escapeBackslash :: T.Text -> T.Text+escapeBackslash = T.replace "\\" "\\\\"++-- escapeSingleQuotes :: T.Text -> T.Text+-- escapeSingleQuotes = T.replace "'" "\'"++-- escapeQuotes :: String -> String+-- escapeQuotes = regexReplace "([\"'])" "\\1"++-- -- | 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 $ parsewith p s+--     where+--       p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline+--              -- eof+--              return ss+--       pattern = many (noneOf whitespacechars)+--       singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")+--       doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")++-- | 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 s >= 2 && T.head s == '\'' && T.last s == '\''++isDoubleQuoted :: Text -> Bool+isDoubleQuoted 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.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 = TL.toStrict . renderRow def{tableBorders=False, borderSpaces=False}+                    . Group NoLine . map (Header . textCell BottomLeft)++-- | 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.++-- | General-purpose wide-char-aware single-line text 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.+fitText :: Maybe Int -> Maybe Int -> Bool -> Bool -> Text -> Text+fitText mminwidth mmaxwidth ellipsify rightside = clip . pad+  where+    clip :: Text -> Text+    clip s =+      case mmaxwidth of+        Just w+          | 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 ""+        Nothing -> s+    pad :: Text -> Text+    pad s =+      case mminwidth of+        Just w+          | sw < w ->+            if rightside+              then s <> T.replicate (w - sw) " "+              else T.replicate (w - sw) " " <> s+          | otherwise -> s+        Nothing -> s+      where sw = realLength s++-- | Double-width-character-aware string truncation. Take as many+-- characters as possible from a string without exceeding the+-- specified width. Eg textTakeWidth 3 "りんご" = "り".+textTakeWidth :: Int -> Text -> Text+textTakeWidth _ ""     = ""+textTakeWidth 0 _      = ""+textTakeWidth w t | not (T.null t),+                let c = T.head t,+                let cw = charWidth c,+                cw <= w+                = T.cons c $ textTakeWidth (w-cw) (T.tail t)+              | otherwise = ""++-- | Add a prefix to each line of a string.+linesPrepend :: Text -> Text -> Text+linesPrepend prefix = T.unlines . map (prefix<>) . T.lines++-- | 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++-- | 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 = 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/UTF8.hs 
@@ -1,87 +0,0 @@-{--From pandoc, slightly extended. Example usage:-- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)- import Hledger.Utils.UTF8 (readFile,writeFile,getContents,putStr,putStrLn)--------------------------------------------------------------------------Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>--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 2 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, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- |-   Module      : Text.Pandoc.UTF8-   Copyright   : Copyright (C) 2010 John MacFarlane-   License     : GNU GPL, version 2 or above --   Maintainer  : John MacFarlane <jgm@berkeley.edu>-   Stability   : alpha-   Portability : portable--UTF-8 aware string IO functions that will work with GHC 6.10 or 6.12.--}-module Hledger.Utils.UTF8 ( readFile-                         , writeFile-                         , appendFile-                         , getContents-                         , hGetContents-                         , putStr-                         , putStrLn-                         , hPutStr-                         , hPutStrLn-                         )--where-import qualified Data.ByteString.Lazy as B-import Data.ByteString.Lazy.UTF8 (toString, fromString)-import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn)-import System.IO (Handle)-import Control.Monad (liftM)--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 (toString . stripBOM) . B.readFile--writeFile :: FilePath -> String -> IO ()-writeFile f = B.writeFile f . fromString--appendFile :: FilePath -> String -> IO ()-appendFile f = B.appendFile f . fromString--getContents :: IO String-getContents = liftM (toString . stripBOM) B.getContents--hGetContents :: Handle -> IO String-hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)--putStr :: String -> IO ()-putStr = B.putStr . fromString--putStrLn :: String -> IO ()-putStrLn = B.putStrLn . fromString--hPutStr :: Handle -> String -> IO ()-hPutStr h = B.hPutStr h . fromString--hPutStrLn :: Handle -> String -> IO ()-hPutStrLn h s = hPutStr h (s ++ "\n")
+ 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.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/Tabular/AsciiWide.hs view
@@ -0,0 +1,306 @@+-- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat+-- wide characters as double width.++{-# 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 Text.WideString (WideBuilder(..), wbFromText)+++-- | 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+  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 emptyCell, colHeaders]+  cells2 = headerContents ch2 : zipWith (:) (headerContents rowHeaders) cellContents++  -- maximum width for each column+  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 -> Bool -> Builder+leftBar pretty True  = fromString $ verticalBar pretty : " "+leftBar pretty False = singleton $ verticalBar pretty++rightBar :: Bool -> Bool -> Builder+rightBar pretty True  = fromString $ ' ' : [verticalBar pretty]+rightBar pretty False = singleton $ verticalBar pretty++midBar :: Bool -> Bool -> Builder+midBar pretty True  = fromString $ ' ' : verticalBar pretty : " "+midBar pretty False = singleton $ verticalBar pretty++doubleMidBar :: Bool -> Bool -> Builder+doubleMidBar pretty True  = fromText $ if pretty then " ║ " else " || "+doubleMidBar pretty False = fromText $ 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+++    -- 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++    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++    addBorders xs | borders   = leftBar pretty spaces <> xs <> rightBar pretty spaces+                  | spaces    = fromText " " <> xs <> fromText " "+                  | otherwise = xs++    nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h++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' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder+renderHLine' vpos borders pretty prop is hdr = addBorders $ sep <> coreLine <> sep+ where+  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,_)    = 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++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,82 +1,302 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack+ name:           hledger-lib-version: 0.16.1+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 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-synopsis:       Core data types, parsers and utilities for the hledger accounting tool.-description:-                hledger is a library and set of user tools for working-                with financial data (or anything that can be tracked in a-                double-entry accounting ledger.) It is a haskell port and-                friendly fork of John Wiegley's Ledger. hledger provides-                command-line, curses and web interfaces, and aims to be a-                reliable, practical tool for daily use.--license:        GPL-license-file:   LICENSE+stability:      stable+homepage:       http://hledger.org+bug-reports:    http://bugs.hledger.org author:         Simon Michael <simon@joyful.com> maintainer:     Simon Michael <simon@joyful.com>-homepage:       http://hledger.org-bug-reports:    http://code.google.com/p/hledger/issues-stability:      beta-tested-with:    GHC==6.12, GHC==7.0-cabal-version:  >= 1.6+license:        GPL-3.0-or-later+license-file:   LICENSE build-type:     Simple--- data-dir:       data--- data-files:--- extra-tmp-files:--- extra-source-files:---   README---   sample.ledger---   sample.timelog+tested-with:+    ghc==9.6.7, ghc==9.8.4, ghc==9.10.2, ghc==9.12.2+extra-source-files:+    CHANGES.md+    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-  -- should set patchlevel here as in Makefile-  cpp-options:    -DPATCHLEVEL=0   exposed-modules:-                  Hledger-                  Hledger.Data-                  Hledger.Data.Account-                  Hledger.Data.AccountName-                  Hledger.Data.Amount-                  Hledger.Data.Commodity-                  Hledger.Data.Dates-                  Hledger.Data.Transaction-                  Hledger.Data.Journal-                  Hledger.Data.Ledger-                  Hledger.Data.Matching-                  Hledger.Data.Posting-                  Hledger.Data.TimeLog-                  Hledger.Data.Types-                  Hledger.Read-                  Hledger.Read.JournalReader-                  Hledger.Read.TimelogReader-                  Hledger.Read.Utils-                  Hledger.Reports-                  Hledger.Utils-                  Hledger.Utils.UTF8-  Build-Depends:-                  base >= 3 && < 5-                 ,bytestring-                 ,cmdargs >= 0.8   && < 0.9-                 ,containers-                 ,directory-                 ,filepath-                 ,mtl-                 ,old-locale-                 ,old-time-                 ,parsec-                 ,regexpr >= 0.5.1-                 ,safe >= 0.2-                 ,split == 0.1.*-                 ,time-                 ,utf8-string >= 0.3.5 && < 0.4-                 ,HUnit--source-repository head-  type:     darcs-  location: http://joyful.com/repos/hledger+      Hledger+      Hledger.Data+      Hledger.Data.Account+      Hledger.Data.AccountName+      Hledger.Data.Amount+      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.Period+      Hledger.Data.PeriodData+      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.Data.Valuation+      Hledger.Query+      Hledger.Read+      Hledger.Read.Common+      Hledger.Read.CsvReader+      Hledger.Read.InputOptions+      Hledger.Read.JournalReader+      Hledger.Read.RulesReader+      Hledger.Read.TimeclockReader+      Hledger.Read.TimedotReader+      Hledger.Reports+      Hledger.Reports.AccountTransactionsReport+      Hledger.Reports.BalanceReport+      Hledger.Reports.BudgetReport+      Hledger.Reports.EntriesReport+      Hledger.Reports.MultiBalanceReport+      Hledger.Reports.PostingsReport+      Hledger.Reports.ReportOptions+      Hledger.Reports.ReportTypes+      Hledger.Utils+      Hledger.Utils.Debug+      Hledger.Utils.IO+      Hledger.Utils.Parse+      Hledger.Utils.Regex+      Hledger.Utils.String+      Hledger.Utils.Test+      Hledger.Utils.Text+      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:+      Paths_hledger_lib+  autogen-modules:+      Paths_hledger_lib+  hs-source-dirs:+      ./+  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 >=0.5.1+    , Glob >=0.9+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9+    , array+    , base >=4.18 && <4.23+    , blaze-html+    , blaze-markup >=0.5.1+    , bytestring+    , call-stack+    , cassava+    , cassava-megaparsec+    , cmdargs >=0.10+    , colour >=2.3.6+    , containers >=0.5.9+    , data-default >=0.5+    , deepseq+    , 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 && <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-simple >4 && <5+    , process+    , regex-tdfa+    , safe >=0.3.20+    , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2+    , template-haskell+    , 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+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG --- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html+test-suite doctest+  type: exitcode-stdio-1.0+  main-is: doctests.hs+  hs-source-dirs:+      test+  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 >=0.5.1+    , Glob >=0.7+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9+    , array+    , base >=4.18 && <4.23+    , blaze-html+    , blaze-markup >=0.5.1+    , bytestring+    , call-stack+    , cassava+    , cassava-megaparsec+    , cmdargs >=0.10+    , colour >=2.3.6+    , containers >=0.5.9+    , data-default >=0.5+    , deepseq+    , 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 && <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-simple >4 && <5+    , process+    , regex-tdfa+    , safe >=0.3.20+    , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2+    , template-haskell+    , 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+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG --- Additional dependencies:--- required for make test: test-framework, test-framework-hunit--- required for make bench: tabular-0.1+test-suite unittest+  type: exitcode-stdio-1.0+  main-is: unittest.hs+  hs-source-dirs:+      test+  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 >=0.5.1+    , Glob >=0.9+    , aeson >=1 && <2.3+    , aeson-pretty+    , ansi-terminal >=0.9+    , array+    , base >=4.18 && <4.23+    , blaze-html+    , blaze-markup >=0.5.1+    , bytestring+    , call-stack+    , cassava+    , cassava-megaparsec+    , cmdargs >=0.10+    , colour >=2.3.6+    , containers >=0.5.9+    , data-default >=0.5+    , deepseq+    , 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 && <1.3 || >=1.4.0+    , hledger-lib+    , lucid+    , megaparsec >=7.0.0 && <9.8+    , microlens >=0.4+    , microlens-th >=0.4+    , mtl >=2.2.1+    , parser-combinators >=0.4.0+    , pretty-simple >4 && <5+    , process+    , regex-tdfa+    , safe >=0.3.20+    , tabular >=0.2+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2+    , template-haskell+    , 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+  buildable: True+  default-language: GHC2021+  if (flag(debug))+    cpp-options: -DDEBUG
+ test/doctests.hs view
@@ -0,0 +1,68 @@+{-+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: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+import Data.Char+import Data.List+import System.Environment+import "Glob" System.FilePath.Glob+import Test.DocTest++main :: IO ()+main = do+  args <- getArgs+  let+    verbose = "--verbose" `elem` args+    slow    = "--slow" `elem` args+    pats    = filter (not . ("-" `isPrefixOf`)) args++  -- find source files+  sourcefiles <- (filter (not . isInfixOf "/.") . concat) <$> sequence [+     glob "Hledger.hs"+    ,glob "Hledger/**/*.hs"+    ,glob "Text/**/*.hs"+    ]++  -- filter by patterns (case insensitive infix substring match)+  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+      ++ if fslen > 1 then " files, plus any files they import:" else " file, plus any files it imports:"+    when verbose $ putStrLn $ unwords fs++    doctest $+      (if verbose then ("--verbose" :) else id) $  -- doctest >= 0.15.0+      (if slow then id else ("--fast" :)) $        -- doctest >= 0.11.4+      fs
+ 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