hledger-lib 1.42.2 → 1.43

raw patch · 24 files changed

+1094/−483 lines, 24 filesdep −base-compatdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: base-compat

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.md +36/−0
• Hledger.hs +15/−0
• Hledger/Data/Balancing.hs +41/−3
• Hledger/Data/Dates.hs +33/−12
• Hledger/Data/Journal.hs +6/−1
• Hledger/Data/Posting.hs +5/−5
• Hledger/Data/Timeclock.hs +103/−3
• Hledger/Data/Types.hs +38/−0
• Hledger/Data/Valuation.hs +8/−13
• Hledger/Query.hs +63/−21
• Hledger/Read.hs +50/−24
• Hledger/Read/Common.hs +16/−6
• Hledger/Read/InputOptions.hs +2/−0
• Hledger/Read/JournalReader.hs +7/−3
• Hledger/Read/RulesReader.hs +53/−19
• Hledger/Read/TimeclockReader.hs +24/−15
• Hledger/Reports/AccountTransactionsReport.hs +5/−5
• Hledger/Reports/ReportOptions.hs +11/−11
• Hledger/Utils/Debug.hs +376/−274
• Hledger/Utils/IO.hs +182/−43
• Hledger/Utils/Parse.hs +4/−11
• Hledger/Utils/Regex.hs +3/−0
• LICENSE +4/−4
• hledger-lib.cabal +9/−10

@@ -22,6 +22,42 @@ For user-visible changes, see the hledger package changelog.  +# 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)

@@ -2,6 +2,21 @@ 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 (

@@ -18,6 +18,8 @@ , isTransactionBalanced , balanceTransaction , balanceTransactionHelper+  -- * assertion validation+, transactionCheckAssertions   -- * journal balancing , journalBalanceTransactions   -- * tests@@ -34,8 +36,7 @@ import Data.Array.ST (STArray, getElems, newListArray, writeArray) import Data.Foldable (asum) import Data.Function ((&))-import Data.Functor ((<&>))-import "base-compat" Data.Functor.Compat (void)+import Data.Functor ((<&>), void) import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H import Data.List (partition, sortOn)@@ -147,6 +148,17 @@ 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 transaction, ensuring that its postings -- (and its balanced virtual postings) sum to 0, -- by inferring a missing amount or conversion price(s) if needed.@@ -528,7 +540,7 @@         ts' <- lift $ getElems balancedtxns         return j{jtxns=ts'} --- Before #2039: "Costs are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments."+-- 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@@ -1071,6 +1083,32 @@               ,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" $ [

@@ -38,7 +38,7 @@   nulldate,   spanContainsDate,   periodContainsDate,-  parsedateM,+  parsedate,   showDate,   showEFDate,   showDateSpan,@@ -778,26 +778,47 @@ -- parsing  -- -- | Parse a couple of date-time string formats to a time type.--- parsedatetimeM :: String -> Maybe LocalTime--- parsedatetimeM s = asum [+-- 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 --     ] --- | Try to parse a couple of date string formats:--- `YYYY-MM-DD`, `YYYY/MM/DD` or `YYYY.MM.DD`, with leading zeros required.--- For internal use, not quite the same as the journal's "simple dates".--- >>> parsedateM "2008/02/03"+-- | 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--- >>> parsedateM "2008/02/03/"+-- >>> parsedate "2008/02/03/" -- Nothing--- >>> parsedateM "2008/02/30"+-- >>> parsedate "2008/02/30" -- Nothing-parsedateM :: String -> Maybe Day-parsedateM s = asum [+-- >>> 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,+     parseTimeM True defaultTimeLocale "%Y%m%d" s      ]  {-|

@@ -74,6 +74,7 @@   journalTagsUsed,   journalTagsDeclaredOrUsed,   journalCommoditiesDeclared,+  journalCommoditiesUsed,   journalCommodities,   journalDateSpan,   journalDateSpanBothDates,@@ -310,7 +311,7 @@ -- (at debug level 5+). dbgJournalAcctDeclOrder :: String -> Journal -> Journal dbgJournalAcctDeclOrder prefix =-  traceOrLogAtWith 5 ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)+  dbg5With ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)   where     showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String     showAcctDeclsSummary adis@@ -405,6 +406,10 @@ -- | Sorted unique commodity symbols declared by commodity directives in this journal. journalCommoditiesDeclared :: Journal -> [CommoditySymbol] journalCommoditiesDeclared = M.keys . jdeclaredcommodities++-- | Sorted unique commodity symbols used in this journal.+journalCommoditiesUsed :: Journal -> [CommoditySymbol]+journalCommoditiesUsed = S.elems . S.fromList . concatMap (map acommodity . amounts) . journalPostingAmounts  -- | Sorted unique commodity symbols mentioned in this journal. journalCommodities :: Journal -> S.Set CommoditySymbol

@@ -116,11 +116,11 @@ -- 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+generatedTransactionTagName = "_generated-transaction"  -- transactions generated by a periodic txn rule+modifiedTransactionTagName  = "_modified-transaction"   -- transactions modified by an auto posting rule+generatedPostingTagName     = "_generated-posting"      -- postings generated by hledger for one reason or another+costPostingTagName          = "_cost-posting"           -- postings which have or could have a cost that's equivalent to nearby conversion postings+conversionPostingTagName    = "_conversion-posting"     -- postings to an equity account of Conversion type which have an amount that's equivalent to a nearby costful or potentially costful posting  instance HasAmounts BalanceAssertion where   styleAmounts styles ba@BalanceAssertion{baamount} = ba{baamount=styleAmounts styles baamount}

@@ -10,10 +10,12 @@  module Hledger.Data.Timeclock (    timeclockEntriesToTransactions+  ,timeclockEntriesToTransactionsSingle   ,tests_Timeclock ) where +import Data.List (partition, sortBy, uncons) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Time.Calendar (addDays)@@ -47,12 +49,97 @@     readsPrec _ ('O' : xs) = [(FinalOut, xs)]     readsPrec _ _ = [] +data Session = Session+    { in' :: TimeclockEntry,+      out :: TimeclockEntry+    }++data Sessions = Sessions+    { completed :: [Session],+      active :: [TimeclockEntry]+    }++-- 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 ' ' ++ "^")++-- Assuming that entries has 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 sessions = Sessions {completed = sessions, active = actives}+pairClockEntries (entry : rest) actives sessions+    | tlcode entry == In = pairClockEntries rest inentries sessions+    | tlcode entry == Out = pairClockEntries rest' actives' sessions'+    | otherwise = pairClockEntries rest actives sessions+    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}}+        (sessions', actives', rest') = if odate > idate then+              (Session {in' = inentry, out = omidnight} : sessions, imidnight : newactive, entry : rest)+            else+              (Session {in' = inentry, out = entry} : sessions, newactive, rest)+        l = show $ unPos $ sourceLine $ tlsourcepos entry+        c = unPos $ sourceColumn $ tlsourcepos entry+        inentries =+          if any (\e -> tlaccount e == tlaccount entry) actives+            then error' $+                printf+                  "%s:\n%s\n%s\n\nEncountered clockin entry for session \"%s\" that is already active."+                  (sourcePosPretty $ tlsourcepos entry)+                  (l ++ " | " ++ show entry)+                  (replicate (length l) ' ' ++ " |" ++ replicate c ' ' ++ "^")+                  (tlaccount entry)+            else entry : actives+ -- | 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.+-- If any entries cannot be paired as expected, then an error is raised. timeclockEntriesToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]-timeclockEntriesToTransactions _ [] = []-timeclockEntriesToTransactions now [i]+timeclockEntriesToTransactions now entries = transactions+  where+    sessions = pairClockEntries (sortBy (\e1 e2 -> compare (tldatetime e1) (tldatetime e2)) entries) [] []+    transactionsFromSession s = entryFromTimeclockInOut (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 = pairClockEntries ((active sessions) <> outs) [] []+    transactions = map transactionsFromSession $ sortBy (\s1 s2 -> compare (in' s1) (in' s2)) (completed sessions ++ completed stillopen)++-- | Convert time log entries to journal transactions, expecting the entries to be+-- a strict in/out cycle. 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.+timeclockEntriesToTransactionsSingle :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockEntriesToTransactionsSingle _ [] = []+timeclockEntriesToTransactionsSingle now [i]     | tlcode i /= In = errorExpectedCodeButGot In i     | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now [i',o]     | otherwise = [entryFromTimeclockInOut i o]@@ -63,7 +150,7 @@       (idate,odate) = (localDay itime,localDay otime)       o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}       i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-timeclockEntriesToTransactions now (i:o:rest)+timeclockEntriesToTransactionsSingle now (i:o:rest)     | tlcode i /= In  = errorExpectedCodeButGot In i     | tlcode o /= Out = errorExpectedCodeButGot Out o     | odate > idate   = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now (i':o:rest)@@ -98,6 +185,8 @@     | 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.")@@ -155,6 +244,7 @@           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"@@ -169,4 +259,14 @@       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+        [ 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"]  ]

@@ -23,6 +23,7 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE StrictData           #-}  module Hledger.Data.Types (   module Hledger.Data.Types,@@ -33,6 +34,7 @@ where  import GHC.Generics (Generic)+import Control.DeepSeq (NFData(..)) import Data.Bifunctor (first) import Data.Decimal (Decimal, DecimalRaw(..)) import Data.Default (Default(..))@@ -761,3 +763,39 @@    ljournal  :: Journal   ,laccounts :: [Account]   } 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 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` ()

@@ -97,7 +97,7 @@     declaredprices = map priceDirectiveToMarketPrice jpricedirectives     inferredprices =       (if infer then jinferredmarketprices else [])-      & traceOrLogAt 2 ("use prices inferred from costs? " <> if infer then "yes" else "no")+      & dbg2Msg ("use prices inferred from costs? " <> if infer then "yes" else "no")     makepricegraph = memo $ makePriceGraph declaredprices inferredprices   in     memo $ uncurry3 $ priceLookup makepricegraph@@ -264,7 +264,7 @@               ,pgEdgesRev=allprices               ,pgDefaultValuationCommodities=defaultdests               } =-      traceOrLogAt 1 ("valuation date: "++show d) $ makepricegraph d+      dbg1Msg ("valuation date: "++show d) $ makepricegraph d     mto' = mto <|> mdefaultto       where         mdefaultto = dbg1 ("default valuation commodity for "++T.unpack from) $@@ -279,12 +279,12 @@         let           msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to)           prices =-            (traceOrLogAt 2 (msg++" using forward prices") $-             traceOrLogAt 2 ("forward prices:\n" <> showMarketPrices forwardprices) $+            (dbg2Msg (msg++" using forward prices") $+             dbg2Msg ("forward prices:\n" <> showMarketPrices forwardprices) $              pricesShortestPath from to forwardprices)             <|>-            (traceOrLogAt 2 (msg++" using forward and reverse prices") $-             traceOrLogAt 2 ("forward and reverse prices:\n" <> showMarketPrices allprices) $+            (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@@ -375,13 +375,8 @@       case concatMap extend paths of         [] -> Nothing          _ | pathlength > maxpathlength -> -          -- XXX This is unusual:-          -- 1. A warning, not an error, which we usually avoid-          -- 2. Not a debug message (when triggered, we always print it)-          -- 3. Printed either to stdout or (eg in hledger-ui) to the debug log file.-          -- This is the only place we use traceOrLog like this.-          -- Also before 1.32.2, traceOrLog was doing the opposite of what it should [#2134].-          traceOrLog ("gave up searching for a price chain at length "++show maxpathlength++", please report a bug")+          -- 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)

@@ -95,17 +95,14 @@ 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 = -  -- compound queries-    Not Query                 -- ^ negate this match-  | And [Query]               -- ^ match if all of these match-  | Or  [Query]               -- ^ match if any of these match   -- no-op queries-  | Any                       -- ^ always match+    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@@ -121,6 +118,14 @@   | 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 postings are matched by all of these   deriving (Eq,Show)  instance Default Query where def = Any@@ -263,6 +268,8 @@     ,"tag"     ,"type"     ,"expr"+    ,"any"+    ,"all"     ]  defaultprefix :: T.Text@@ -308,6 +315,8 @@ 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 @@ -805,6 +814,8 @@ 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 = all (`matchesAmount` a) qs matchesAmount (Amt ord n) a = compareAmount ord n a matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) matchesAmount _ _ = True@@ -834,6 +845,8 @@ 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 = all (`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)@@ -852,6 +865,8 @@ 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 = all (\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 = matchesTags npat vpat $ atags a matchesAccountExtra _      _     q         a = matchesAccount q a@@ -865,6 +880,8 @@ 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 = all (`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@@ -889,6 +906,8 @@ 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 = all (\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)@@ -908,6 +927,8 @@ 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 = all (\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@@ -932,20 +953,24 @@ 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 = all (\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 ? -- Tests desc: terms, any other terms are ignored. 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 (Code _) _     = False-matchesDescription (Desc r) d     = regexMatchText r d-matchesDescription _ _            = False+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 = all (`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.@@ -962,14 +987,16 @@  -- | 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 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+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 = all (`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@@ -1137,4 +1164,19 @@      -- 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"}]}  ]

@@ -89,9 +89,15 @@   -- * Journal files   PrefixedFilePath,   defaultJournal,+  defaultJournalWith,+  defaultJournalSafely,+  defaultJournalSafelyWith,   defaultJournalPath,   requireJournalFileExists,   ensureJournalFileExists,+  journalEnvVar,+  -- journalEnvVar2,+  journalDefaultFilename,    -- * Journal parsing   runExceptT,@@ -110,6 +116,7 @@   -- * Misc   saveLatestDates,   saveLatestDatesForFiles,+  isWindowsUnsafeDotPath,    -- * Re-exported   JournalReader.tmpostingrulep,@@ -141,14 +148,13 @@ import qualified Data.Text.IO as T import Data.Time (Day) import Safe (headDef, headMay)-import System.Directory (doesFileExist, getHomeDirectory)+import System.Directory (doesFileExist) import System.Environment (getEnv)-import System.Exit (exitFailure) import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeFileName) import System.Info (os)-import System.IO (Handle, hPutStr, stderr)+import System.IO (Handle, hPutStrLn, stderr) -import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate)+import Hledger.Data.Dates (getCurrentDay, parsedate, showDate) import Hledger.Data.Types import Hledger.Read.Common import Hledger.Read.InputOptions@@ -172,10 +178,31 @@ journalEnvVar2          = "LEDGER" journalDefaultFilename  = ".hledger.journal" --- | Read the default journal file specified by the environment, or raise an error.+-- | Read the default journal file specified by the environment, +-- with default input options, or raise an error. defaultJournal :: IO Journal-defaultJournal = defaultJournalPath >>= runExceptT . readJournalFile definputopts >>= either error' return  -- PARTIAL:+defaultJournal = defaultJournalSafely >>= either error' return -- PARTIAL: +-- | Read the default journal file specified by the environment,+-- with the given input options, or raise an error.+defaultJournalWith :: InputOpts -> IO Journal+defaultJournalWith iopts = defaultJournalSafelyWith iopts >>= either error' return -- PARTIAL:++-- | Read the default journal file specified by the environment,+-- with default input options, or return an error message.+defaultJournalSafely :: IO (Either String Journal)+defaultJournalSafely = defaultJournalSafelyWith definputopts++-- | Read the default journal file specified by the environment,+-- with the given input options, or return an error message.+defaultJournalSafelyWith :: InputOpts -> IO (Either String Journal)+defaultJournalSafelyWith iopts = (do+  f <- defaultJournalPath+  runExceptT $ readJournalFile iopts f+  ) `C.catches` [  -- XXX+     C.Handler (\(e :: C.ErrorCall)   -> return $ Left $ show e)+    ,C.Handler (\(e :: C.IOException) -> return $ Left $ show e)+    ] -- | Get the default journal file path specified by the environment. -- Like ledger, we look first for the LEDGER_FILE environment -- variable, and if that does not exist, for the legacy LEDGER@@ -197,7 +224,7 @@          `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2                                             `C.catch` (\(_::C.IOException) -> return ""))       defpath = do-        home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")+        home <- fromMaybe "" <$> getHomeSafe         return $ home </> journalDefaultFilename  -- | A file path optionally prefixed by a reader name and colon@@ -234,6 +261,8 @@  -- | 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. --@@ -270,7 +299,7 @@     iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}   liftIO $ requireJournalFileExists f   h <--    traceOrLogAt 6 ("readJournalFile: "++takeFileName f) $+    dbg6Msg ("readJournalFile: "++takeFileName f) $     liftIO $ openFileOrStdin f     -- <- T.readFile f  -- or without line ending translation, for testing   j <- readJournal iopts' (Just f) h@@ -302,7 +331,7 @@ readJournalFiles iopts@InputOpts{strict_, new_, new_save_} prefixedfiles = do   let iopts' = iopts{_defer=True}   (j, latestdatesforfiles) <--    traceOrLogAt 6 ("readJournalFiles: "++show prefixedfiles) $+    dbg6Msg ("readJournalFiles: "++show prefixedfiles) $     readJournalFilesAndLatestDates iopts' prefixedfiles   when strict_ $ liftEither $ journalStrictChecks j   when (new_ && new_save_) $ liftIO $ saveLatestDatesForFiles latestdatesforfiles@@ -316,13 +345,11 @@   (js, lastdates) <- unzip <$> mapM (readJournalFileAndLatestDates iopts) pfs   return (maybe def sconcat $ nonEmpty js, catMaybes lastdates) --- | An easy version of 'readJournal' which assumes default options, and fails--- in the IO monad.+-- | 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 additionally to 'readJournal''--- also takes a 'Text' instead of a 'Handle'.+-- | An even easier version of readJournal' which takes a 'Text' instead of a 'Handle'. readJournal'' :: Text -> IO Journal readJournal'' = readJournal' <=< inputToHandle @@ -342,29 +369,28 @@ 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 "-"), give a helpful error and quit.+-- | If the specified journal file does not exist (and is not "-"), call error with an informative message. -- (Using "journal file" generically here; it could be in any of hledger's supported formats.) requireJournalFileExists :: FilePath -> IO () requireJournalFileExists "-" = return () requireJournalFileExists f = do   exists <- doesFileExist f-  unless exists $ do-    hPutStr stderr $ "The hledger data file \"" <> f <> "\" was not found.\n"-    hPutStr stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"-    hPutStr stderr "Or, specify an existing data 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. -- 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) $ do-    hPutStr stderr $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n"-    exitFailure+  when (os=="mingw32" && isWindowsUnsafeDotPath f) $+    error' $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n"   exists <- doesFileExist f   unless exists $ do-    hPutStr stderr $ "Creating hledger journal file " <> show f <> ".\n"+    hPutStrLn stderr $ "Creating hledger journal file " <> show f     -- note Hledger.Utils.UTF8.* do no line ending conversion on windows,     -- we currently require unix line endings on all platforms.     newJournalContent >>= T.writeFile f@@ -417,7 +443,7 @@   let nls = zip [1::Int ..] $ T.lines t   fmap catMaybes $ forM nls $ \(n,l) -> do     let s = T.unpack $ T.strip l-    case (s, parsedateM s) of+    case (s, parsedate s) of       ("", _)       -> return Nothing       (_,  Nothing) -> error' (printf "%s:%d: invalid date: \"%s\"" latestfile n s)       (_,  Just d)  -> return $ Just d

@@ -197,7 +197,16 @@ rawOptsToInputOpts :: Day -> Bool -> Bool -> RawOpts -> InputOpts rawOptsToInputOpts day usecoloronstdout postingaccttags rawopts = -    let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balanced"+    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.@@ -231,6 +240,7 @@                                }       ,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@@ -376,7 +386,7 @@       <&> (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".showJournalAmountsDebug)       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions-      -- <&> traceOrLogAt 6 fname  -- debug logging+      -- <&> dbg6Msg fname  -- debug logging       <&> dbgJournalAcctDeclOrder (fname <> ": acct decls           : ")       <&> journalRenumberAccountDeclarations       <&> dbgJournalAcctDeclOrder (fname <> ": acct decls renumbered: ")@@ -416,7 +426,7 @@  dp :: String -> TextParser m () dp = const $ return ()  -- no-op--- dp = dbgparse 1  -- trace parse state at this --debug level+-- 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).@@ -1289,6 +1299,7 @@  -- | 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@@ -1298,7 +1309,7 @@     where       commentp = do         choice (map (some.char) cs)-        takeWhileP Nothing (/='\n') <* newline+        takeWhileP Nothing (/='\n') <* optional newline  -- | Is this a character that, as the first non-whitespace on a line, -- starts a comment line ?@@ -1329,8 +1340,7 @@ -- Right "\n\n" -- followingcommentp :: TextParser m Text-followingcommentp =-  fst <$> followingcommentpWith (void $ takeWhileP Nothing (/= '\n'))  -- XXX support \r\n ?+followingcommentp = fst <$> followingcommentpWith (void $ takeWhileP Nothing (/= '\n'))  {-# INLINABLE followingcommentp #-} 

@@ -44,6 +44,7 @@     ,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@@ -66,6 +67,7 @@     , strict_            = False     , _defer             = False     , _ioDay             = nulldate+    , _oldtimeclock      = False     }  -- | Get the Maybe the DateSpan to generate forecast options from.

@@ -289,18 +289,22 @@ -- Examples: foo.j, ../foo/bar.j, timedot:/foo/2020*, *.journal includedirectivep :: MonadIO m => ErroringJournalParser m () includedirectivep = do+  -- parse   string "include"   lift skipNonNewlineSpaces1-  prefixedglob <- rstrip . T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet+  prefixedglob <- rstrip . T.unpack <$> takeWhileP Nothing (`notElem` [';','\n'])+  lift followingcommentp+  -- save the position (does sequencing wrt newline matter ? seems not)   parentoff <- getOffset   parentpos <- getSourcePos+  -- find file(s)   let (mprefix,glb) = splitReaderPrefix prefixedglob   paths <- getFilePaths parentoff parentpos glb   let prefixedpaths = case mprefix of         Nothing  -> paths         Just fmt -> map ((show fmt++":")++) paths+  -- parse them inline   forM_ prefixedpaths $ parseChild parentpos-  void newline    where     getFilePaths@@ -334,7 +338,7 @@         Fail.fail ("Cyclic include: " ++ filepath)        childInput <--        traceOrLogAt 6 ("parseChild: "++takeFileName filepath) $+        dbg6Msg ("parseChild: "++takeFileName filepath) $         lift $ readFilePortably filepath           `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)       let initChildj = newJournalWithParseStateFrom filepath parentj

@@ -86,6 +86,7 @@ import Hledger.Write.Csv import System.Directory (doesFileExist, getHomeDirectory) import Data.Either (fromRight)+import Control.DeepSeq (deepseq)  --- ** doctest setup -- $setup@@ -178,7 +179,8 @@  -- | Inline all files referenced by include directives in this hledger CSV rules text, recursively. -- Included file paths may be relative to the directory of the provided file path.--- This is done as a pre-parse step to simplify the CSV rules parser.+-- 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@@ -315,11 +317,16 @@ -- interpreted or combined with other matchers. data MatcherPrefix =     Or      -- ^ no prefix-  | And     -- ^ &+  | And     -- ^ &&   | Not     -- ^ !-  | AndNot  -- ^ & !+  | 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@@ -334,6 +341,11 @@ 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.@@ -346,6 +358,9 @@   ,cbAssignments :: [(HledgerFieldName, FieldTemplate)]   } deriving (Show, Eq) +dbgShowConditionalBlock :: ConditionalBlock -> String+dbgShowConditionalBlock = unwords . map dbgShowMatcher . cbMatchers+ defrules :: CsvRulesParsed defrules = CsvRules' {   rdirectives=[],@@ -784,15 +799,22 @@ getEffectiveAssignment rules record f = lastMay assignments   where     -- all active assignments to field f, in order-    assignments = dbg9 "csv assignments" $ toplevelassignments ++ conditionalassignments+    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@@ -812,7 +834,7 @@     --     matcherMatches :: Matcher -> Bool     matcherMatches = \case-      RecordMatcher prefix             pat -> maybeNegate prefix $ match pat $ T.intercalate "," record+      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"@@ -835,6 +857,13 @@         (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@@ -877,7 +906,7 @@  getMatchGroups :: CsvRules -> CsvRecord -> Matcher -> [Text] getMatchGroups _ record (RecordMatcher _ regex) =-  regexMatchTextGroups regex $ T.intercalate "," record -- see caveats in matcherMatches+  regexMatchTextGroups regex $ recordAsApproximateText record  -- groups might be wrong getMatchGroups rules record (FieldMatcher _ fieldref regex) =   regexMatchTextGroups regex $ fromMaybe "" $ replaceCsvFieldReference rules record fieldref @@ -942,7 +971,7 @@     skiplines <- case getDirective "skip" rules of                       Nothing -> return 0                       Just "" -> return 1-                      Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s+                      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@@ -1105,8 +1134,13 @@ --- ** converting csv records to transactions  transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction-transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t+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: @@ -1115,9 +1149,9 @@     field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text     mdateformat = rule "date-format"-    parsedate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat+    parseDate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat     mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines-      ["error: could not parse \""<>datevalue<>"\" as a date using date format "+      ["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)@@ -1138,16 +1172,16 @@      date        = fromMaybe "" $ fieldval "date"     -- PARTIAL:-    date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date+    date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parseDate date     mdate2      = fieldval "date2"-    mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2+    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-              ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)"+              ["could not parse status value \""<>s<>"\" (should be *, ! or empty)"               ,"the parse error is:      "<>T.pack (customErrorBundlePretty err)               ]     code        = maybe "" singleline' $ fieldval "code"@@ -1362,7 +1396,7 @@   where     journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}     mkerror e = error' . T.unpack $ T.unlines-      ["error: could not parse \"" <> s <> "\" as an amount"+      ["could not parse \"" <> s <> "\" as an amount"       ,showRecord record       ,showRules rules record       -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)@@ -1375,10 +1409,6 @@   [ (("the "<>fld<>" rule is: ")<>) <$>     hledgerField rules record fld | fld <- journalfieldnames ] --- | Show a (approximate) recreation of the original CSV record.-showRecord :: CsvRecord -> Text-showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r)- -- XXX unify these ^v  -- | Almost but not quite the same as parseAmount.@@ -1395,12 +1425,16 @@   where     journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}     mkerror n' s' e = error' . T.unpack $ T.unlines-      ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount"+      ["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.

@@ -80,32 +80,41 @@   {rFormat     = Timeclock   ,rExtensions = ["timeclock"]   ,rReadFn     = handleReadFnToTextReadFn parse-  ,rParser    = timeclockfilep+  ,rParser     = timeclockfilep definputopts   }  -- | 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 fp t+parse iopts fp t = initialiseAndParseJournal (timeclockfilep iopts) iopts fp t                    >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)                    >>= journalFinalise iopts fp t  --- ** parsers -timeclockfilep :: MonadIO m => JournalParser m ParsedJournal-timeclockfilep = do many timeclockitemp-                    eof-                    j@Journal{jparsetimeclockentries=es} <- get-                    -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.-                    -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,-                    -- but it simplifies code above.-                    now <- liftIO getCurrentLocalTime-                    -- entries have been parsed in reverse order. timeclockEntriesToTransactions-                    -- expects them to be in normal order, then we must reverse again since-                    -- journalFinalise expects them in reverse order-                    let j' = j{jtxns = reverse $ timeclockEntriesToTransactions now $ reverse es, jparsetimeclockentries = []}-                    return j'+-- 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 +                                -- timeclockEntriesToTransactionsSingle expects the entries to be in normal order, +                                -- but they have been parsed in reverse order, so reverse them before calling+                                j{jtxns = reverse $ timeclockEntriesToTransactionsSingle now $ reverse es, jparsetimeclockentries = []}+                              else +                                -- We don't need to reverse these transactions +                                -- since they are sorted inside of timeclockEntiresToTransactions+                                j{jtxns = reverse $ timeclockEntriesToTransactions now es, jparsetimeclockentries = []}+                          return j'     where       -- As all ledger line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or

@@ -125,16 +125,16 @@         -- 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)-        . traceOrLogAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns)+        . dbg5With (("ts3:\n"++).pshowTransactions.jtxns)         -- maybe convert these transactions to cost or value         . journalApplyValuationFromOpts rspec-        . traceOrLogAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns)+        . 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)-        . traceOrLogAt 3 ("thisacctq: "++show thisacctq)-        $ traceOrLogAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns)+        . dbg3Msg ("thisacctq: "++show thisacctq)+        $ dbg5With (("ts1:\n"++).pshowTransactions.jtxns)           j{jtxns = filter (matchesTransaction thisacctq . relevantPostings) $ jtxns j}       where         relevantPostings@@ -159,7 +159,7 @@     items =         accountTransactionsReportItems reportq thisacctq startbal maNegate (journalAccountType j)       -- sort by the transaction's register date, then index, for accurate starting balance-      . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)+      . 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)

@@ -516,7 +516,7 @@       | t `elem` ["then" ,"t"] = Just $ AtThen mc       | t `elem` ["end" ,"e"]  = Just $ AtEnd  mc       | t `elem` ["now" ,"n"]  = Just $ AtNow  mc-      | otherwise = case parsedateM t of+      | 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@@ -588,21 +588,21 @@ journalValueAndFilterPostings rspec j = 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 rspec@ReportSpec{_rsQuery=q, _rsReportOpts=ropts} j =-    -- Filter by the remainder of the query-      filterJournal reportq-    -- Apply valuation and costing-    . journalApplyValuationFromOptsWith rspec-    -- Filter by amount and currency, so it matches pre-valuation/costing-      (if queryIsNull amtsymq then j else filterJournalAmounts amtsymq j)+journalValueAndFilterPostingsWith rspec@ReportSpec{_rsQuery=q, _rsReportOpts=ropts} =+    journalApplyValuationFromOptsWith rspec . filterJournal q   where     -- with -r, replace each posting with its sibling postings     filterJournal = if related_ ropts then filterJournalRelatedPostings else filterJournalPostings-    amtsymq = dbg3 "amtsymq" $ filterQuery queryIsAmtOrSym q-    reportq = dbg3 "reportq" $ filterQuery (not . queryIsAmtOrSym) q-    queryIsAmtOrSym = liftA2 (||) queryIsAmt queryIsSym  -- | 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

@@ -1,59 +1,72 @@ {- |  -Here are fancier versions of Debug.Trace, with these features:+Here are debug tracing/logging helpers built on Debug.Trace, extracted from the hledger project.+Features: -- unsafePerformIO-based for easy usage in pure code, IO code, and program startup code-- reasonably short and memorable function names-- pretty-printing haskell values, with or without colour, using pretty-simple-- enabling/disabling debug output with --debug-- multiple debug verbosity levels, from 1 to 9-- sending debug output to stderr or to a log file-- enabling logging based on program name+- 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. -The basic "trace" functions print to stderr.-This debug output will be interleaved with the program's normal output, which can be-useful for understanding when code executes.+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: -The "Log" functions log to a file instead.-The need for these is arguable, since a technically savvy user can redirect-stderr output to a log file, eg: @CMD 2>debug.log@.-But here is how they currently work:+> dbg4 "foo" foo -The "traceLog" functions log to the program's debug log file,-which is @PROGNAME.log@ in the current directory,-where PROGNAME is the program name returned by @getProgName@.-When using this logging feature you should call @withProgName@ explicitly-at the start of your program to ensure a stable program name,-otherwise it can change to "<interactive>" eg when running in GHCI.-Eg: @main = withProgName "MYPROG" $ do ...@.+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. -The "OrLog" functions can either print to stderr or log to a file.+They are intended to be easy to use and to find in your code, with a consistent naming scheme: -- By default, they print to stderr.+> 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 -- If the program name has been set (with @withProgName) to something ending with ".log", they log to that file instead.-  This can be useful for programs which should never print to stderr, eg TUI programs like hledger-ui.+Or if you prefer you can ignore the numbered variants and write an extra argument: -The "At" functions produce output only when the program was run with a -sufficiently high debug level, as set by a @--debug[=N]@ command line option.-N ranges from 1 (least debug output) to 9 (most debug output),-@--debug@ with no argument means 1.+> dbgMsg   LEVEL  STR    VAL+> dbgMsgIO LEVEL  STR+>+> dbg      LEVEL  STR    VAL+> dbgIO    LEVEL  STR    VAL+>+> dbgWith  LEVEL  SHOWFN VAL -The "dbgN*" functions are intended to be the most convenient API, to be embedded-at points of interest in your code. They combine the conditional output of "At",-the conditional logging of "OrLog", pretty printing, and short searchable function names.+Haskell values will be pretty-printed by default, using pretty-simple. -Parsing the command line, detecting program name, and file logging is done with unsafePerformIO.-If you are working in GHCI, changing the debug level requires editing and reloading this file-(sometimes it's more convenient to add a dbg0 temporarily).+ANSI color will also be used if appropriate,+respecting output capabilities, @NO_COLOR@, and/or a @--color [YNA]@ (or @--colour@) command line option. -In hledger, debug levels are used as follows:+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 command output only (no warnings, eg)-1             useful warnings, most common troubleshooting info (config file args, valuation..)+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@@ -64,22 +77,7 @@ 9             any other rarely needed / more in-depth info @ -We don't yet have the ability to select debug output by topic. For now, here-are some standardish topic strings to search for in hledger debug messages:--acct-arg-budget-calc-csv-journalFinalise-multiBalanceReport-opts-precision-price-q-style-val+It's not yet possible to select debug output by topic; that would be useful.  -} @@ -93,39 +91,73 @@ -- 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 ( -   debugLevel--  -- * Tracing to stderr-  ,traceWith-  ,traceAt-  ,traceAtWith-  ,ptrace-  ,ptraceAt-  ,ptraceAtIO+  -- * Debug level+  debugLevel -  -- * Logging to PROGNAME.log-  ,traceLog-  ,traceLogAt-  ,traceLogIO-  ,traceLogAtIO-  ,traceLogWith-  ,traceLogAtWith-  ,ptraceLogAt-  ,ptraceLogAtIO+  -- * Trace/log a string+  ,dbgMsg+  ,dbg0Msg+  ,dbg1Msg+  ,dbg2Msg+  ,dbg3Msg+  ,dbg4Msg+  ,dbg5Msg+  ,dbg6Msg+  ,dbg7Msg+  ,dbg8Msg+  ,dbg9Msg -  -- * Tracing or logging based on shouldLog-  ,traceOrLog-  ,traceOrLogAt-  ,ptraceOrLogAt-  ,ptraceOrLogAtIO-  ,traceOrLogAtWith+  -- * Trace/log a string in IO+  ,dbgMsgIO+  ,dbg0MsgIO+  ,dbg1MsgIO+  ,dbg2MsgIO+  ,dbg3MsgIO+  ,dbg4MsgIO+  ,dbg5MsgIO+  ,dbg6MsgIO+  ,dbg7MsgIO+  ,dbg8MsgIO+  ,dbg9MsgIO -  -- * Pretty tracing/logging in pure code+  -- * Trace/log a value+  ,dbg+  ,dbg_   ,dbg0   ,dbg1   ,dbg2@@ -136,9 +168,9 @@   ,dbg7   ,dbg8   ,dbg9-  ,dbgExit -  -- * Pretty tracing/logging in IO+  -- * Trace/log a value in IO+  ,dbgIO   ,dbg0IO   ,dbg1IO   ,dbg2IO@@ -150,7 +182,8 @@   ,dbg8IO   ,dbg9IO -  -- * Tracing/logging with a show function+  -- * Trace/log a value with a show function+  ,dbgWith   ,dbg0With   ,dbg1With   ,dbg2With@@ -163,15 +196,17 @@   ,dbg9With    -- * Utilities+  ,lbl_+  ,progName++  -- * ghc-debug helpers   ,ghcDebugSupportedInLib   ,GhcDebugMode(..)   ,ghcDebugMode   ,withGhcDebug'   ,ghcDebugPause'-  ,lbl_-  ,progName -  -- * Re-exports+  -- * Re-exports: Debug.Trace   -- ,module Debug.Breakpoint   ,module Debug.Trace @@ -182,18 +217,18 @@ import Control.Exception (evaluate) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List hiding (uncons)--- import Debug.Breakpoint 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.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>".@@ -210,9 +245,11 @@   then reverse $ drop 4 $ reverse modifiedProgName   else modifiedProgName --- | The programs debug output verbosity. The default is 0 meaning no debug output.--- The @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to--- a higher value (the = is required). Uses unsafePerformIO. +-- | 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@@ -223,78 +260,7 @@                    ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v                    _                                   -> 0 --- | 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---- | Trace a value with the given show function before returning it.-traceWith :: (a -> String) -> a -> a-traceWith f a = trace (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---- | Trace (print to stderr) a string if the global debug level is at+-- | 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@@ -302,14 +268,30 @@     | 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 global debug level is at or above the specified level.+-- if the program debug level is at or above the specified level. -- At level 0, always prints. Otherwise, uses unsafePerformIO. traceAtWith :: Int -> (a -> String) -> a -> a traceAtWith level f a = traceAt level (f a) a +-- -- | Pretty-trace a showable value before returning it.+-- -- Like Debug.Trace.traceShowId, but pretty-printing and easier to type.+-- ptrace :: Show a => a -> a+-- ptrace = traceWith pshow+ -- | Pretty-print a label and a showable value to the console--- if the global debug level is at or above the specified level.+-- if the program debug level is at or above the specified level. -- At level 0, always prints. Otherwise, uses unsafePerformIO. ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level@@ -326,216 +308,273 @@     ls' | length ls > 1 = map (' ':) ls         | otherwise     = ls --- | Like ptraceAt, but convenient to insert in an IO monad and--- enforces monadic sequencing.+-- | 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) --- | Should the "trace or log" functions output to a file instead of stderr ?--- True if the program name ends with ".log".-shouldLog :: Bool-shouldLog = ".log" `isSuffixOf` modifiedProgName  -- | The debug log file: PROGNAME.log in the current directory. -- See modifiedProgName. debugLogFile :: FilePath debugLogFile = progName ++ ".log" --- -- | The debug log file: debug.log in the current directory.--- debugLogFile :: FilePath--- debugLogFile = "debug.log"- -- | Log a string to the debug log before returning the second argument. -- Uses unsafePerformIO.-traceLog :: String -> a -> a-traceLog s x = unsafePerformIO $ do+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 global debug level is at or above the specified level.+-- if the program debug level is at or above the specified level. -- At level 0, always logs. Otherwise, uses unsafePerformIO.-traceLogAt :: Int -> String -> a -> a-traceLogAt level str+logAt :: Int -> String -> a -> a+logAt level str   | level > 0 && debugLevel < level = id-  | otherwise = traceLog str+  | otherwise = log' str --- | Like traceLog but sequences properly in IO.-traceLogIO :: MonadIO m => String -> m ()-traceLogIO s = do+-- | 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 traceLogAt, but convenient to use in IO.-traceLogAtIO :: MonadIO m => Int -> String -> m ()-traceLogAtIO level str+-- | Like logAt, but convenient to use in IO.+logAtIO :: (MonadIO m) => Int -> String -> m ()+logAtIO level str   | level > 0 && debugLevel < level = return ()-  | otherwise = traceLogIO str+  | otherwise = logIO str --- | Log a value to the debug log with the given show function before returning it.-traceLogWith :: (a -> String) -> a -> a-traceLogWith f a = traceLog (f a) a+-- -- | 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 global debug level is at or above the specified level.+-- if the program debug level is at or above the specified level. -- At level 0, always logs. Otherwise, uses unsafePerformIO.-traceLogAtWith :: Int -> (a -> String) -> a -> a-traceLogAtWith level f a = traceLogAt level (f a) a+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 global debug level is at or above the specified level. +-- if the program debug level is at or above the specified level.  -- At level 0, always prints. Otherwise, uses unsafePerformIO.-ptraceLogAt :: Show a => Int -> String -> a -> a-ptraceLogAt level+plogAt :: (Show a) => Int -> String -> a -> a+plogAt level   | level > 0 && debugLevel < level = const id-  | otherwise = \lbl a -> traceLog (labelledPretty False lbl a) a+  | otherwise = \lbl a -> log' (labelledPretty False lbl a) a --- | Like ptraceAt, but convenient to insert in an IO monad and--- enforces monadic sequencing.-ptraceLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()-ptraceLogAtIO level label 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 traceLogIO (labelledPretty False label a)+  else logIO (labelledPretty False label a) --- | Trace or log a string depending on shouldLog,--- before returning the second argument.-traceOrLog :: String -> a -> a-traceOrLog = if shouldLog then traceLog else trace --- | Trace or log a string depending on shouldLog,--- when global debug level is at or above the specified level,--- before returning the second argument.-traceOrLogAt :: Int -> String -> a -> a-traceOrLogAt = if shouldLog then traceLogAt else traceAt+-- | 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 --- | Pretty-trace or log depending on shouldLog, when global debug level--- is at or above the specified level.-ptraceOrLogAt :: Show a => Int -> String -> a -> a-ptraceOrLogAt = if shouldLog then ptraceLogAt else ptraceAt --- | Like ptraceOrLogAt, but convenient in IO.-ptraceOrLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()-ptraceOrLogAtIO = if shouldLog then ptraceLogAtIO else ptraceAtIO+-- | 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 --- | Trace or log, with a show function, depending on shouldLog.-traceOrLogAtWith :: Int -> (a -> String) -> a -> a-traceOrLogAtWith = if shouldLog then traceLogAtWith else traceAtWith+dbg0Msg :: String -> a -> a+dbg0Msg = dbgMsg 0 --- | Pretty-trace to stderr (or log to debug log) a label and showable value,--- then return it.+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 = ptraceOrLogAt 0+dbg0 = dbg 0 --- | Pretty-trace to stderr (or log to debug log) a label and showable value--- if the --debug level is high enough, then return the value.--- Uses unsafePerformIO. dbg1 :: Show a => String -> a -> a-dbg1 = ptraceOrLogAt 1+dbg1 = dbg 1  dbg2 :: Show a => String -> a -> a-dbg2 = ptraceOrLogAt 2+dbg2 = dbg 2  dbg3 :: Show a => String -> a -> a-dbg3 = ptraceOrLogAt 3+dbg3 = dbg 3  dbg4 :: Show a => String -> a -> a-dbg4 = ptraceOrLogAt 4+dbg4 = dbg 4  dbg5 :: Show a => String -> a -> a-dbg5 = ptraceOrLogAt 5+dbg5 = dbg 5  dbg6 :: Show a => String -> a -> a-dbg6 = ptraceOrLogAt 6+dbg6 = dbg 6  dbg7 :: Show a => String -> a -> a-dbg7 = ptraceOrLogAt 7+dbg7 = dbg 7  dbg8 :: Show a => String -> a -> a-dbg8 = ptraceOrLogAt 8+dbg8 = dbg 8  dbg9 :: Show a => String -> a -> a-dbg9 = ptraceOrLogAt 9+dbg9 = dbg 9 --- | Like dbg0, but also exit the program. Uses unsafePerformIO.-dbgExit :: Show a => String -> a -> a-dbgExit label a = unsafePerformIO $ dbg0IO label a >> exitFailure --- | Like dbgN, but convenient to use in IO.+-- | 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 = ptraceOrLogAtIO 0+dbg0IO = dbgIO 0  dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg1IO = ptraceOrLogAtIO 1+dbg1IO = dbgIO 1  dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg2IO = ptraceOrLogAtIO 2+dbg2IO = dbgIO 2  dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg3IO = ptraceOrLogAtIO 3+dbg3IO = dbgIO 3  dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg4IO = ptraceOrLogAtIO 4+dbg4IO = dbgIO 4  dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg5IO = ptraceOrLogAtIO 5+dbg5IO = dbgIO 5  dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg6IO = ptraceOrLogAtIO 6+dbg6IO = dbgIO 6  dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg7IO = ptraceOrLogAtIO 7+dbg7IO = dbgIO 7  dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg8IO = ptraceOrLogAtIO 8+dbg8IO = dbgIO 8  dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg9IO = ptraceOrLogAtIO 9+dbg9IO = dbgIO 9 --- | Like dbgN, but taking a show function instead of a label.++-- | 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 = traceOrLogAtWith 0+dbg0With = dbgWith 0 -dbg1With :: Show a => (a -> String) -> a -> a-dbg1With = traceOrLogAtWith 1+dbg1With :: (a -> String) -> a -> a+dbg1With = dbgWith 1 -dbg2With :: Show a => (a -> String) -> a -> a-dbg2With = traceOrLogAtWith 2+dbg2With :: (a -> String) -> a -> a+dbg2With = dbgWith 2 -dbg3With :: Show a => (a -> String) -> a -> a-dbg3With = traceOrLogAtWith 3+dbg3With :: (a -> String) -> a -> a+dbg3With = dbgWith 3 -dbg4With :: Show a => (a -> String) -> a -> a-dbg4With = traceOrLogAtWith 4+dbg4With :: (a -> String) -> a -> a+dbg4With = dbgWith 4 -dbg5With :: Show a => (a -> String) -> a -> a-dbg5With = traceOrLogAtWith 5+dbg5With :: (a -> String) -> a -> a+dbg5With = dbgWith 5 -dbg6With :: Show a => (a -> String) -> a -> a-dbg6With = traceOrLogAtWith 6+dbg6With :: (a -> String) -> a -> a+dbg6With = dbgWith 6 -dbg7With :: Show a => (a -> String) -> a -> a-dbg7With = traceOrLogAtWith 7+dbg7With :: (a -> String) -> a -> a+dbg7With = dbgWith 7 -dbg8With :: Show a => (a -> String) -> a -> a-dbg8With = traceOrLogAtWith 8+dbg8With :: (a -> String) -> a -> a+dbg8With = dbgWith 8 -dbg9With :: Show a => (a -> String) -> a -> a-dbg9With = traceOrLogAtWith 9+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 new helper for defining a local "dbg" function.+-- -- | 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,@@ -544,8 +583,71 @@ -- -- 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. Show a => Int -> String -> (String -> (a -> String) -> a -> a)+-- dbg_ :: forall a. Int -> String -> (String -> (a -> String) -> a -> a) -- dbg_ level topic = --   \desc showfn val ->---     traceOrLogAtWith level (lbl_ 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

@@ -22,12 +22,18 @@   error',   usageError,   warn,+  ansiFormatError,+  ansiFormatWarning,+  printError,+  exitWithErrorMessage,+  exitOnError,    -- * Time   getCurrentLocalTime,   getCurrentZonedTime,    -- * Files+  getHomeSafe,   embedFileRelative,   expandHomePath,   expandPath,@@ -59,6 +65,7 @@    -- * Pager output   setupPager,+  findPager,   runPager,    -- * ANSI colour/styles@@ -111,9 +118,9 @@ where  import           Control.Concurrent (forkIO)-import           Control.Exception (catch, evaluate, throwIO)+import           Control.Exception import           Control.Monad (when, forM, guard, void)-import           Data.Char (toLower)+import           Data.Char (toLower, isSpace) import           Data.Colour.RGBSpace (RGB(RGB)) import           Data.Colour.RGBSpace.HSL (lightness) import           Data.Colour.SRGB (sRGB)@@ -124,25 +131,28 @@ import           Data.Maybe (isJust, catMaybes) import           Data.Ord (comparing, Down (Down)) import qualified Data.Text as T+import           Data.Text.Encoding.Error (UnicodeException) import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import           Data.Time.Clock (getCurrentTime) import           Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime) import           Data.Word (Word16)-import           Debug.Trace (trace)+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, lookupEnv, setEnv)+import           System.Environment (getArgs, lookupEnv, setEnv, getProgName)+import           System.Exit (exitFailure) import           System.FilePath (isRelative, (</>)) import "Glob"    System.FilePath.Glob (glob) import           System.Info (os)-import           System.IO (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode, openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom, hIsTerminalDevice, hPutStr, hClose)+import           System.IO (Handle, IOMode (..), hClose, hGetEncoding, hIsTerminalDevice, hPutStr, hPutStrLn, hSetNewlineMode, hSetEncoding, openFile, stderr, stdin, stdout, universalNewlineMode, utf8_bom) import qualified System.IO.Encoding as Enc import           System.IO.Unsafe (unsafePerformIO) import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, shell, waitForProcess, withCreateProcess)@@ -151,7 +161,6 @@ import Hledger.Utils.Text (WideBuilder(WideBuilder))  - -- Pretty showing/printing -- using pretty-simple @@ -196,39 +205,155 @@ -- Errors  -- | Call errorWithoutStackTrace, prepending a "Error:" label.--- Also do some ANSI styling of the first line when allowed (using unsafe IO). error' :: String -> a-error' =-  if useColorOnStderrUnsafe-  then  -- color the program name as well-    unsafePerformIO $ do-      putStr fmt-      return $ errorWithoutStackTrace . modifyFirstLine ((<>sgrresetall) . (label<>))-  else-    errorWithoutStackTrace . modifyFirstLine (label<>)-  where-    label = "Error: "-    fmt = sgrbrightred <> sgrbold+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 message, with "Warning:" label, on stderr before returning the given value.--- Also do some ANSI styling of the first line when we detect that's supported (using unsafe IO).+-- Also do 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.) warn :: String -> a -> a-warn msg = trace (modifyFirstLine f (label <> msg))+warn msg = trace msg'   where-    label = "Warning: "-    f = if useColorOnStderrUnsafe then ((<>sgrresetall).(fmt<>)) else id-      where-        fmt = sgrbrightyellow <> sgrbold+    msg' =+      (if useColorOnStderrUnsafe then modifyFirstLine ansiFormatWarning else id) $+      "Warning: "<> msg +-- | 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.-modifyFirstLine f s = unlines $ map f l <> ls where (l,ls) = splitAt 1 $ lines s  -- total+-- 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+-- and useful error output for some common program-terminating exceptions,+-- independent of compiler version. It catches:+--+-- - UnicodeException - unicode errors in pure code+--+-- - IOException AKA IOError - I/O errors, including unicode errors during I/O+--+-- - ErrorCall - @error@ / @errorWithoutStackTrace@ calls+--+-- and:+-- +-- - removes the trailing newlines added by some GHC 9.10.*+--+-- - removes "uncaught exception" output added by some GHC 9.12.*+--+-- - ensures a consistent "programname: " prefix+--+-- - applies ANSI styling (bold bright red) to the first line if that is supported and allowed+--+-- - for unicode exceptions, and I/O exceptions which look like they were+--   caused by a unicode error (usually text decoding failure),+--   it adds (english) text explaining the problem and what to do.+--+-- Some exceptions this does not handle:+-- ExitCode (exitSuccess / exitFailure / exitWith calls)+-- and UserInterrupt (control-C).+--+exitOnError :: IO () -> IO ()+exitOnError = flip catches+  [-- Handler (\(e::SomeException) -> error' $ pshow e),  -- debug+   Handler (\(e::UnicodeException) -> exitUnicode e)+  ,Handler (\(e::IOException) -> if isUnicodeError e then exitUnicode e else exitOther e)+  ,Handler (\(e::ErrorCall) -> exitOther e)+  ]++  where+    -- 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 text encoding, " <> enc <> "."+          ] +++          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@@ -247,6 +372,10 @@  -- 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 tilde (representing home directory) at the start of a file path. -- ~username is not supported. Can raise an error. expandHomePath :: FilePath -> IO FilePath@@ -294,25 +423,33 @@ readFileOrStdinPortably' :: Maybe DynEncoding -> String -> IO T.Text readFileOrStdinPortably' c f = openFileOrStdin f >>= readHandlePortably' 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 +-- readHandlePortably' with no text encoding specified. readHandlePortably :: Handle -> IO T.Text readHandlePortably = readHandlePortably' Nothing +-- | Read text from a handle with a specified encoding, using the encoding package.+-- Or if no encoding is specified, it uses the handle's current encoding,+-- after first changing it to UTF-8BOM if it was UTF-8, to allow a 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). readHandlePortably' :: Maybe DynEncoding -> Handle -> IO T.Text readHandlePortably' Nothing h = do   hSetNewlineMode h universalNewlineMode   menc <- hGetEncoding h-  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show-    hSetEncoding h utf8_bom+  when (fmap show menc == Just "UTF-8") $ hSetEncoding h utf8_bom   T.hGetContents h readHandlePortably' (Just e) h =-  -- We need to manually apply the newline mode-  -- Since we already have a Text+  -- 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-8BOM. inputToHandle :: T.Text -> IO Handle inputToHandle t = do   (r, w) <- createPipe@@ -374,23 +511,23 @@ toFlag [c] = ['-',c] toFlag s   = '-':'-':s --- | Parse y/yes/always or n/no/never to true or false, or with any other value raise an error.-parseYN :: String -> Bool+-- | 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"] = True-  | l `elem` ["n","no","never"]   = False-  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no"])+  | 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 with any other value raise an error.-parseYNA :: String -> YNA+-- | 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"] = Yes-  | l `elem` ["n","no","never"]   = No-  | l `elem` ["a","auto"]         = Auto-  | otherwise = error' $ "value should be one of " <> (intercalate ", " ["y","yes","n","no","a","auto"])+  | 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 ?@@ -497,7 +634,7 @@   setEnv "LESS" $     case (mhledgerless, mless) of       (Just hledgerless, _) -> hledgerless-      (_, Just less)        -> unwords [less, deflessopts]+      (_, Just less)        -> if deflessopts `isInfixOf` less then less else unwords [less, deflessopts]       _                     -> deflessopts  -- | Display the given text on the terminal, trying to use a pager ($PAGER, less, or more)@@ -536,6 +673,7 @@ -- 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@@ -543,7 +681,7 @@     oh = length ls     ow = maximumDef 0 $ map length ls     windows = os == "mingw32"-  pagerno    <- maybe False (not.parseYN) <$> getOpt ["pager"]+  pagerno    <- maybe False (not . either error' id . parseYN) <$> getOpt ["pager"]   outputfile <- hasOutputFile   emacsterm  <- lookupEnv "INSIDE_EMACS" <&> (`notElem` [Nothing, Just "vterm"])   mhw        <- getTerminalHeightWidth@@ -573,8 +711,9 @@ -- 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 parseYNA <$> getOpt ["color","colour"]+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.

@@ -47,7 +47,6 @@    -- ** Trace the state of hledger parsers   dbgparse,-  traceOrLogParse,    -- * More helpers, previously in Text.Megaparsec.Custom @@ -111,7 +110,7 @@ import Data.Monoid (Alt(..)) import qualified Data.Set as S -import Hledger.Utils.Debug (debugLevel, traceOrLog)+import Hledger.Utils.Debug (debugLevel, dbg0Msg)  -- | A parser of string to some type. type SimpleStringParser a = Parsec HledgerParseErrorData String a@@ -128,23 +127,17 @@ -- | 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.--- Uses unsafePerformIO.-dbgparse :: Int -> String -> TextParser m ()-dbgparse level msg = when (level <= debugLevel) $ traceOrLogParse msg---- | Trace to stderr or log to debug log the provided label (if non-null)--- and current parser state (position and next input). -- See also: Hledger.Utils.Debug, megaparsec's dbg. -- Uses unsafePerformIO. -- XXX Can be hard to make this evaluate.-traceOrLogParse :: String -> TextParser m ()-traceOrLogParse msg = do+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-  traceOrLog s' $ return ()+  dbg0Msg s' $ return ()   where     peeklength = 30 

@@ -64,6 +64,7 @@   ) where +import Control.DeepSeq (NFData(..), rwhnf) import Control.Monad (foldM) import Data.Aeson (ToJSON(..), Value(String)) import Data.Array ((!), elems, indices)@@ -128,6 +129,8 @@ 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

@@ -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>.

@@ -1,11 +1,11 @@-cabal-version: 1.12+cabal-version: 2.2  -- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.42.2+version:        1.43 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@@ -30,11 +30,11 @@ bug-reports:    http://bugs.hledger.org author:         Simon Michael <simon@joyful.com> maintainer:     Simon Michael <simon@joyful.com>-license:        GPL-3+license:        GPL-3.0-or-later license-file:   LICENSE build-type:     Simple tested-with:-    GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.5, GHC==9.6.2+    ghc==8.10.7, ghc==9.0.2, ghc==9.2.8, ghc==9.4.8, ghc==9.6.7, ghc==9.8.4, ghc==9.10.1 extra-source-files:     CHANGES.md     README.md@@ -116,6 +116,8 @@       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@@ -126,8 +128,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.21-    , base-compat >=0.14.0+    , base >=4.14 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring@@ -185,8 +186,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.21-    , base-compat >=0.14.0+    , base >=4.14 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring@@ -247,8 +247,7 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.21-    , base-compat >=0.14.0+    , base >=4.14 && <4.22     , blaze-html     , blaze-markup >=0.5.1     , bytestring