hledger-lib 1.27.1 → 1.28

raw patch · 20 files changed

+989/−733 lines, 20 filesdep −breakpointdep ~basedep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies removed: breakpoint

Dependency ranges changed: base, megaparsec

API changes (from Hackage documentation)

Files

• CHANGES.md +53/−0
• Hledger/Data/Amount.hs +8/−9
• Hledger/Data/Balancing.hs +2/−2
• Hledger/Data/Dates.hs +0/−1
• Hledger/Data/Journal.hs +2/−3
• Hledger/Data/Types.hs +21/−30
• Hledger/Data/Valuation.hs +4/−4
• Hledger/Read.hs +1/−1
• Hledger/Read/Common.hs +21/−15
• Hledger/Read/CsvReader.hs +88/−34
• Hledger/Read/JournalReader.hs +1/−1
• Hledger/Reports/AccountTransactionsReport.hs +5/−5
• Hledger/Reports/ReportOptions.hs +8/−7
• Hledger/Utils.hs +136/−210
• Hledger/Utils/Debug.hs +288/−392
• Hledger/Utils/IO.hs +298/−0
• Hledger/Utils/Parse.hs +38/−6
• Hledger/Utils/Test.hs +1/−1
• Text/Megaparsec/Custom.hs +4/−0
• hledger-lib.cabal +10/−12

@@ -9,6 +9,59 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.28 2022-11-30++- Hledger.Utils.Debug's debug logging helpers have been unified.+  The "trace or log" functions log to stderr by default, or to a file+  if ",logging" is appended to the program name (using withProgName). +  The debug log file is PROGNAME.log (changed from debug.log).++- Moved from Hledger.Utils.Debug to Hledger.Utils.Parse:+  traceParse+  traceParseAt+  dbgparse++- Moved from Hledger.Utils.Debug to Hledger.Utils.Print:+  pshow+  pshow'+  pprint+  pprint'+  colorOption+  useColorOnStdout+  useColorOnStderr+  outputFileOption+  hasOutputFile++- Rename Hledger.Utils.Print -> Hledger.Utils.IO, consolidate utils there.++- Hledger.Utils cleaned up.++- Hledger.Data.Amount: showMixedAmountOneLine now also shows costs.+  Note that different costs are kept separate in amount arithmetic.++- Hledger.Read.Common: rename/add amount parsing helpers.++  added:+   parseamount+   parseamount'+   parsemixedamount+   parsemixedamount'++  removed:+   amountp'+   mamountp'++- Hledger.Utils.Parse:+  export customErrorBundlePretty, +  for pretty-printing hledger parse errors.++- Support megaparsec 9.3. (Felix Yan)++- Support GHC 9.4.++- Update cabal files to match hpack 0.35/stack 2.9++ # 1.27 2022-09-01  Breaking changes

@@ -141,7 +141,6 @@   mixedAmountSetFullPrecision,   canonicaliseMixedAmount,   -- * misc.-  ltraceamount,   tests_Amount ) where @@ -163,7 +162,6 @@ import Safe (headDef, lastDef, lastMay) import System.Console.ANSI (Color(..),ColorIntensity(..)) -import Debug.Trace (trace) import Test.Tasty (testGroup) import Test.Tasty.HUnit ((@?=), assertBool, testCase) @@ -585,10 +583,12 @@ mixedAmount a = Mixed $ M.singleton (amountKey a) a  -- | Add an Amount to a MixedAmount, normalising the result.+-- Amounts with different costs are kept separate. maAddAmount :: MixedAmount -> Amount -> MixedAmount maAddAmount (Mixed ma) a = Mixed $ M.insertWith sumSimilarAmountsUsingFirstPrice (amountKey a) a ma  -- | Add a collection of Amounts to a MixedAmount, normalising the result.+-- Amounts with different costs are kept separate. maAddAmounts :: Foldable t => MixedAmount -> t Amount -> MixedAmount maAddAmounts = foldl' maAddAmount @@ -596,15 +596,18 @@ maNegate :: MixedAmount -> MixedAmount maNegate = transformMixedAmount negate --- | Sum two MixedAmount.+-- | Sum two MixedAmount, keeping the cost of the first if any.+-- Amounts with different costs are kept separate (since 2021). maPlus :: MixedAmount -> MixedAmount -> MixedAmount maPlus (Mixed as) (Mixed bs) = Mixed $ M.unionWith sumSimilarAmountsUsingFirstPrice as bs  -- | Subtract a MixedAmount from another.+-- Amounts with different costs are kept separate. maMinus :: MixedAmount -> MixedAmount -> MixedAmount maMinus a = maPlus a . maNegate  -- | Sum a collection of MixedAmounts.+-- Amounts with different costs are kept separate. maSum :: Foldable t => t MixedAmount -> MixedAmount maSum = foldl' maPlus nullmixedamt @@ -781,11 +784,11 @@ showMixedAmount :: MixedAmount -> String showMixedAmount = wbUnpack . showMixedAmountB noColour --- | Get the one-line string representation of a mixed amount.+-- | Get the one-line string representation of a mixed amount (also showing any costs). -- -- > showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine showMixedAmountOneLine :: MixedAmount -> String-showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine+showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine{displayPrice=True}  -- | Like showMixedAmount, but zero amounts are shown with their -- commodity if they have one.@@ -942,10 +945,6 @@ maybeAppend :: Maybe a -> [a] -> [a] maybeAppend Nothing  = id maybeAppend (Just a) = (++[a])---- | Compact labelled trace of a mixed amount, for debugging.-ltraceamount :: String -> MixedAmount -> MixedAmount-ltraceamount s a = trace (s ++ ": " ++ showMixedAmount a) a  -- | Set the display precision in the amount's commodities. mixedAmountSetPrecision :: AmountPrecision -> MixedAmount -> MixedAmount

@@ -118,11 +118,11 @@         rmsg           | rsumok        = ""           | not rsignsok  = "The real postings all have the same sign. Consider negating some of them."-          | otherwise     = "The real postings' sum should be 0 but is: " ++ showMixedAmountOneLine rsumcost+          | otherwise     = "The real postings' sum should be 0 but is: " ++ showMixedAmountOneLineWithoutPrice False rsumcost         bvmsg           | bvsumok       = ""           | not bvsignsok = "The balanced virtual postings all have the same sign. Consider negating some of them."-          | otherwise     = "The balanced virtual postings' sum should be 0 but is: " ++ showMixedAmountOneLine bvsumcost+          | otherwise     = "The balanced virtual postings' sum should be 0 but is: " ++ showMixedAmountOneLineWithoutPrice False bvsumcost  -- | Legacy form of transactionCheckBalanced. isTransactionBalanced :: BalancingOpts -> Transaction -> Bool

@@ -104,7 +104,6 @@ import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, string, string') import Text.Megaparsec.Char.Lexer (decimal, signed)-import Text.Megaparsec.Custom (customErrorBundlePretty) import Text.Printf (printf)  import Hledger.Data.Types

@@ -246,9 +246,8 @@ -- | Debug log the ordering of a journal's account declarations -- (at debug level 5+). dbgJournalAcctDeclOrder :: String -> Journal -> Journal-dbgJournalAcctDeclOrder prefix-  | debugLevel >= 5 = traceWith ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)-  | otherwise       = id+dbgJournalAcctDeclOrder prefix =+  traceOrLogAtWith 5 ((prefix++) . showAcctDeclsSummary . jdeclaredaccounts)   where     showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String     showAcctDeclsSummary adis

@@ -163,6 +163,21 @@   show Cash       = "C"   show Conversion = "V" +isBalanceSheetAccountType :: AccountType -> Bool+isBalanceSheetAccountType t = t `elem` [+  Asset,+  Liability,+  Equity,+  Cash,+  Conversion+  ]++isIncomeStatementAccountType :: AccountType -> Bool+isIncomeStatementAccountType t = t `elem` [+  Revenue,+  Expense+  ]+ -- | Check whether the first argument is a subtype of the second: either equal -- or one of the defined subtypes. isAccountSubtypeOf :: AccountType -> AccountType -> Bool@@ -338,38 +353,14 @@ -- at a certain point (posting date and parse order). They provide additional -- error checking and readability to a journal file. ----- The 'BalanceAssertion' type is also used to represent balance assignments,--- which instruct hledger what an account's balance should become at a certain--- point.------ Different kinds of balance assertions are discussed eg on #290.--- Variables include:------ - which postings are to be summed (real/virtual; unmarked/pending/cleared; this account/this account including subs)------ - which commodities within the balance are to be checked------ - whether to do a partial or a total check (disallowing other commodities)------ I suspect we want:------ 1. partial, subaccount-exclusive, Ledger-compatible assertions. Because---    they're what we've always had, and removing them would break some---    journals unnecessarily.  Implemented with = syntax.------ 2. total assertions. Because otherwise assertions are a bit leaky.---    Implemented with == syntax.------ 3. subaccount-inclusive assertions. Because that's something folks need.---    Not implemented.+-- A balance assignments is an instruction to hledger to adjust an+-- account's balance to a certain amount at a certain point. ----- 4. flexible assertions allowing custom criteria (perhaps arbitrary---    queries). Because power users have diverse needs and want to try out---    different schemes (assert cleared balances, assert balance from real or---    virtual postings, etc.). Not implemented.+-- The 'BalanceAssertion' type is used for representing both of these. ----- 5. multicommodity assertions, asserting the balance of multiple commodities---    at once. Not implemented, requires #934.+-- hledger supports multiple kinds of balance assertions/assignments,+-- which differ in whether they refer to a single commodity or all commodities,+-- and the (subaccount-)inclusive or exclusive account balance. -- data BalanceAssertion = BalanceAssertion {       baamount    :: Amount,    -- ^ the expected balance in a particular commodity

@@ -244,7 +244,7 @@               ,pgEdgesRev=allprices               ,pgDefaultValuationCommodities=defaultdests               } =-      traceAt 1 ("valuation date: "++show d) $ makepricegraph d+      traceOrLogAt 1 ("valuation date: "++show d) $ makepricegraph d     mto' = mto <|> mdefaultto       where         mdefaultto = dbg1 ("default valuation commodity for "++T.unpack from) $@@ -258,10 +258,10 @@         -- according to the rules described in makePriceGraph.         let msg = printf "seeking %s to %s price" (showCommoditySymbol from) (showCommoditySymbol to)         in case -          (traceAt 2 (msg++" using forward prices") $ +          (traceOrLogAt 2 (msg++" using forward prices") $              pricesShortestPath from to forwardprices)           <|> -          (traceAt 2 (msg++" using forward and reverse prices") $ +          (traceOrLogAt 2 (msg++" using forward and reverse prices") $              pricesShortestPath from to allprices)         of           Nothing -> Nothing@@ -335,7 +335,7 @@       case concatMap extend paths of         [] -> Nothing          _ | pathlength > maxpathlength -> -          trace ("gave up searching for a price chain at length "++show maxpathlength++", please report a bug")+          traceOrLog ("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)

@@ -161,7 +161,7 @@     iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]}   liftIO $ requireJournalFileExists f   t <--    traceAt 6 ("readJournalFile: "++takeFileName f) $+    traceOrLogAt 6 ("readJournalFile: "++takeFileName f) $     liftIO $ readFileOrStdinPortably f     -- <- T.readFile f  -- or without line ending translation, for testing   j <- readJournal iopts' (Just f) t

@@ -76,8 +76,6 @@   -- ** amounts   spaceandamountormissingp,   amountp,-  amountp',-  mamountp',   amountpwithmultiplier,   commoditysymbolp,   priceamountp,@@ -86,6 +84,10 @@   numberp,   fromRawNumber,   rawnumberp,+  parseamount,+  parseamount',+  parsemixedamount,+  parsemixedamount',    -- ** comments   isLineCommentStart,@@ -141,7 +143,7 @@ import Text.Megaparsec.Char (char, char', digitChar, newline, string) import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Custom-  (FinalParseError, attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)+  (FinalParseError, attachSource, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)  import Hledger.Data import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery)@@ -244,7 +246,7 @@     foldM (\r -> fmap (\(c,a) -> M.insert c a r) . parseCommodity) mempty optList   where     optList = listofstringopt "commodity-style" rawOpts-    parseCommodity optStr = case amountp'' optStr of+    parseCommodity optStr = case parseamount optStr of         Left _ -> Left optStr         Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle) @@ -325,7 +327,7 @@       >>= journalBalanceTransactions balancingopts_                         -- Balance all transactions and maybe check balance assertions.       <&> (if infer_equity_ then journalAddInferredEquityPostings else id)  -- Add inferred equity postings, after balancing and generating auto postings       <&> journalInferMarketPricesFromTransactions       -- infer market prices from commodity-exchanging transactions-      <&> traceAt 6 ("journalFinalise: " <> takeFileName f)  -- debug logging+      <&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f)  -- debug logging       <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls           : ")       <&> journalRenumberAccountDeclarations       <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> "   acct decls renumbered: ")@@ -799,20 +801,24 @@                            uncurry parseErrorAtRegion posRegion errMsg           Right (q,p,d,g) -> pure (q, Precision p, d, g) --- | Try to parse an amount from a string-amountp'' :: String -> Either HledgerParseErrors Amount-amountp'' s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s)+-- | Try to parse a single-commodity amount from a string+parseamount :: String -> Either HledgerParseErrors Amount+parseamount s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) --- | Parse an amount from a string, or get an error.-amountp' :: String -> Amount-amountp' s =-  case amountp'' s of+-- | Parse a single-commodity amount from a string, or get an error.+parseamount' :: String -> Amount+parseamount' s =+  case parseamount s of     Right amt -> amt     Left err  -> error' $ show err  -- PARTIAL: XXX should throwError --- | Parse a mixed amount from a string, or get an error.-mamountp' :: String -> MixedAmount-mamountp' = mixedAmount . amountp'+-- | Like parseamount', but returns a MixedAmount.+parsemixedamount :: String -> Either HledgerParseErrors MixedAmount+parsemixedamount = fmap mixedAmount . parseamount++-- | Like parseamount', but returns a MixedAmount.+parsemixedamount' :: String -> MixedAmount+parsemixedamount' = mixedAmount . parseamount'  -- | Parse a minus or plus sign followed by zero or more spaces, -- or nothing, returning a function that negates or does nothing.

@@ -45,10 +45,10 @@ import Data.Char                  (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor             (first) import Data.Functor               ((<&>))-import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortBy)+import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortOn)+import Data.List.Extra (groupOn) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.MemoUgly (memo)-import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T@@ -56,8 +56,8 @@ 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.Calendar (Day)-import Data.Time.Format (parseTimeM, defaultTimeLocale)+import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime),+  defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC) import Safe (atMay, headMay, lastMay, readMay) import System.Directory (doesFileExist) import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)@@ -68,7 +68,7 @@ import Data.Foldable (asum, toList) import Text.Megaparsec hiding (match, parse) import Text.Megaparsec.Char (char, newline, string)-import Text.Megaparsec.Custom (customErrorBundlePretty, parseErrorAt)+import Text.Megaparsec.Custom (parseErrorAt) import Text.Printf (printf)  import Hledger.Data@@ -358,7 +358,7 @@  RULES: RULE* -RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | NEWEST-FIRST | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE+RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE  FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )* @@ -460,7 +460,9 @@   -- ,"default-account"   -- ,"default-currency"   ,"skip"+  ,"timezone"   ,"newest-first"+  ,"intra-day-reversed"   , "balance-type"   ] @@ -703,6 +705,13 @@                       Just "" -> return 1                       Just s  -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s +    mtzin <- case getDirective "timezone" rules of+              Nothing -> return Nothing+              Just s  ->+                maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $+                parseTimeM False defaultTimeLocale "%Z" $ T.unpack s+    tzout <- liftIO getCurrentTimeZone+     -- parse csv     let       -- parsec seems to fail if you pass it "-" here TODO: try again with megaparsec@@ -733,33 +742,44 @@                           line' = (mkPos . (+1) . unPos) line                           pos' = SourcePos name line' col                         in-                          (pos', transactionFromCsvRecord pos rules r)+                          (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r)                      )                      (initialPos parsecfilename) records--      -- Ensure transactions are ordered chronologically.-      -- First, if the CSV records seem to be most-recent-first (because-      -- there's an explicit "newest-first" directive, or there's more-      -- than one date and the first date is more recent than the last):-      -- reverse them to get same-date transactions ordered chronologically.-      txns' =-        (if newestfirst || mdataseemsnewestfirst == Just True-          then dbg7 "reversed csv txns" . reverse else id)-          txns         where-          newestfirst = dbg6 "newestfirst" $ isJust $ getDirective "newest-first" rules-          mdataseemsnewestfirst = dbg6 "mdataseemsnewestfirst" $-            case nub $ map tdate txns of-              ds | length ds > 1 -> Just $ head ds > last ds-              _                  -> Nothing-      -- Second, sort by date.-      txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns'+          timesarezoned =+            case csvRule rules "date-format" of+              Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True+              _ -> False +      -- Do our best to ensure transactions will be ordered chronologically,+      -- from oldest to newest. This is done in several steps:+      -- 1. Intra-day order: if there's an "intra-day-reversed" rule,+      -- assume each day's CSV records were ordered in reverse of the overall date order,+      -- so reverse each day's txns.+      intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules+      txns1 = dbg7 "txns1" $+        (if intradayreversed then concatMap reverse . groupOn tdate else id) txns+      -- 2. Overall date order: now if there's a "newest-first" rule,+      -- or if there's multiple dates and the first is more recent than the last,+      -- assume CSV records were ordered newest dates first,+      -- so reverse all txns.+      newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules+      mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $+        case nub $ map tdate txns of+          ds | length ds > 1 -> Just $ head ds > last ds+          _                  -> Nothing+      txns2 = dbg7 "txns2" $+        (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1+      -- 3. Disordered dates: in case the CSV records were ordered by chaos,+      -- do a final sort by date. If it was only a few records out of order,+      -- this will hopefully refine any good ordering done by steps 1 and 2.+      txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2+     liftIO $ unless rulesfileexists $ do       dbg1IO "creating conversion rules file" rulesfile       T.writeFile rulesfile rulestext -    return nulljournal{jtxns=txns''}+    return nulljournal{jtxns=txns3}  -- | Parse special separator names TAB and SPACE, or return the first -- character. Return Nothing on empty string@@ -856,8 +876,8 @@ hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record -transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction-transactionFromCsvRecord sourcepos rules record = t+transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction+transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t   where     ----------------------------------------------------------------------     -- 1. Define some helpers:@@ -866,7 +886,8 @@     -- ruleval  = csvRuleValue      rules record :: DirectiveName    -> Maybe String     field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text-    parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format")+    mdateformat = rule "date-format"+    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 "         <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat'@@ -887,7 +908,6 @@     -- field assignment rules using the CSV record's data, and parsing a bit     -- more where needed (dates, status). -    mdateformat = rule "date-format"     date        = fromMaybe "" $ fieldval "date"     -- PARTIAL:     date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date@@ -1173,7 +1193,7 @@ getAccount rules record mamount mbalance n =   let     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text-    maccount = fieldval ("account"<> T.pack (show n))+    maccount = T.strip <$> fieldval ("account"<> T.pack (show n))   in case maccount of     -- accountN is set to the empty string - no posting will be generated     Just "" -> Nothing@@ -1320,11 +1340,45 @@  -- | Parse the date string using the specified date-format, or if unspecified -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading--- zeroes optional).-parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day-parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith' formats+-- zeroes optional). If a timezone is provided, we assume the DateFormat+-- produces a zoned time and we localise that to the given timezone.+parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day+parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime+  -- this time code can probably be simpler, I'm just happy to get out alive   where-    parsewith' = flip (parseTimeM True defaultTimeLocale) (T.unpack s)+    localdate :: UTCTime -> Day =+      localDay .+      dbg7 ("time in output timezone "++show tzout) .+      utcToLocalTime tzout+    mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats++    parseWithFormat :: String -> Maybe UTCTime+    parseWithFormat fmt =+      if timesarezoned+      then+        dbg7 "zoned CSV time, expressed as UTC" $+        parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime+      else+        -- parse as a local day and time; then if an input timezone is provided,+        -- assume it's in that, otherwise assume it's in the output timezone;+        -- then convert to UTC like the above+        let+          mlocaltime =+            fmap (dbg7 "unzoned CSV time") $+            parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime+          localTimeAsZonedTime tz lt =  ZonedTime lt tz+        in+          case mtzin of+            Just tzin ->+              (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") . +              localTimeToUTC tzin)+              <$> mlocaltime+            Nothing ->+              (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") .+                zonedTimeToUTC .+                localTimeAsZonedTime tzout)+              <$> mlocaltime+     formats = map T.unpack $ maybe                ["%Y/%-m/%-d"                ,"%Y-%-m-%-d"

@@ -299,7 +299,7 @@         Fail.fail ("Cyclic include: " ++ filepath)        childInput <--        traceAt 6 ("parseChild: "++takeFileName filepath) $+        traceOrLogAt 6 ("parseChild: "++takeFileName filepath) $         lift $ readFilePortably filepath           `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)       let initChildj = newJournalWithParseStateFrom filepath parentj

@@ -121,16 +121,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 mixedAmountStripPrices)-        . ptraceAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns)+        . traceOrLogAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns)         -- maybe convert these transactions to cost or value         . journalApplyValuationFromOpts rspec-        . ptraceAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns)+        . traceOrLogAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns)         -- apply any cur:SYM 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)-        . traceAt 3 ("thisacctq: "++show thisacctq)-        $ ptraceAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns)+        . traceOrLogAt 3 ("thisacctq: "++show thisacctq)+        $ traceOrLogAtWith 5 (("ts1:\n"++).pshowTransactions.jtxns)           j{jtxns = filter (matchesTransaction thisacctq . relevantPostings) $ jtxns j}       where         relevantPostings@@ -155,7 +155,7 @@     items =         accountTransactionsReportItems reportq thisacctq startbal maNegate (journalAccountType j)       -- sort by the transaction's register date, then index, for accurate starting balance-      . ptraceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)+      . traceAtWith 5 (("ts4:\n"++).pshowTransactions.map snd)       . sortBy (comparing (Down . fst) <> comparing (Down . tindex . snd))       . map (\t -> (transactionRegisterDate wd reportq thisacctq t, t))       $ jtxns acctJournal

@@ -266,13 +266,14 @@           ,layout_           = layoutopt rawopts           } --- | The result of successfully parsing a ReportOpts on a particular--- Day. Any ambiguous dates are completed and Queries are parsed,--- ensuring that there are no regular expression errors. Values here--- should be used in preference to re-deriving them from ReportOpts.--- If you change the query_ in ReportOpts, you should call--- `reportOptsToSpec` to regenerate the ReportSpec with the new--- Query.+-- | A fully-determined set of report parameters +-- (report options with all partial values made total, eg the begin and end+-- dates are known, avoiding date/regex errors; plus the reporting date),+-- and the query successfully calculated from them.+--+-- If you change the report options or date in one of these, you should+-- use `reportOptsToSpec` to regenerate the whole thing, avoiding inconsistency.+-- data ReportSpec = ReportSpec   { _rsReportOpts :: ReportOpts  -- ^ The underlying ReportOpts used to generate this ReportSpec   , _rsDay        :: Day         -- ^ The Day this ReportSpec is generated for

@@ -1,92 +1,119 @@ {-|+Utilities used throughout hledger, or needed low in the module hierarchy.+These are the bottom of hledger's module graph.+-} -Standard imports and utilities which are useful everywhere, or needed low-in the module hierarchy. This is the bottom of hledger's module graph.+module Hledger.Utils ( --}-{-# LANGUAGE LambdaCase #-}+  -- * Functions+  applyN,+  mapM',+  sequence',+  curry2,+  uncurry2,+  curry3,+  uncurry3,+  curry4,+  uncurry4, -module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:-                          -- module Control.Monad,-                          -- module Data.List,-                          -- module Data.Maybe,-                          -- module Data.Time.Calendar,-                          -- module Data.Time.Clock,-                          -- module Data.Time.LocalTime,-                          -- module Data.Tree,-                          -- module Text.RegexPR,-                          -- module Text.Printf,-                          ---- all of this one:-                          module Hledger.Utils,-                          module Hledger.Utils.Debug,-                          module Hledger.Utils.Parse,-                          module Hledger.Utils.Regex,-                          module Hledger.Utils.String,-                          module Hledger.Utils.Text,-                          module Hledger.Utils.Test,-                          -- Debug.Trace.trace,-                          -- module Data.PPrint,-                          -- the rest need to be done in each module I think-                          )+  -- * Lists+  maximum',+  maximumStrict,+  minimumStrict,+  splitAtElement,+  sumStrict,++  -- * Trees+  treeLeaves,++  -- * Tuples+  first3,+  second3,+  third3,+  first4,+  second4,+  third4,+  fourth4,+  first5,+  second5,+  third5,+  fourth5,+  fifth5,+  first6,+  second6,+  third6,+  fourth6,+  fifth6,+  sixth6,++  -- * Misc+  numDigitsInt,+  makeHledgerClassyLenses,++  -- * Other+  module Hledger.Utils.Debug,+  module Hledger.Utils.Parse,+  module Hledger.Utils.IO,+  module Hledger.Utils.Regex,+  module Hledger.Utils.String,+  module Hledger.Utils.Text,++  -- * Tests+  tests_Utils,+  module Hledger.Utils.Test,++) where -import Control.Monad (when) import Data.Char (toLower)-import Data.FileEmbed (makeRelativeToProject, embedStringFile) import Data.List.Extra (foldl', foldl1', uncons, unsnoc) import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy.Builder as TB-import Data.Time.Clock (getCurrentTime)-import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone,-                            utcToLocalTime, utcToZonedTime)+import Data.Tree (foldTree, Tree (Node, subForest)) import Language.Haskell.TH (DecsQ, Name, mkName, nameBase)--- import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Language.Haskell.TH.Syntax (Q, Exp) import Lens.Micro ((&), (.~)) import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules)-import System.Console.ANSI (Color,ColorIntensity,ConsoleLayer(..), SGR(..), setSGRCode)-import System.Directory (getHomeDirectory)-import System.FilePath (isRelative, (</>))-import System.IO-  (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,-   openFile, stdin, universalNewlineMode, utf8_bom)  import Hledger.Utils.Debug import Hledger.Utils.Parse+import Hledger.Utils.IO import Hledger.Utils.Regex import Hledger.Utils.String import Hledger.Utils.Text import Hledger.Utils.Test-import Data.Tree (foldTree, Tree (Node, subForest))  --- tuples--first3  (x,_,_) = x-second3 (_,x,_) = x-third3  (_,_,x) = x--first4  (x,_,_,_) = x-second4 (_,x,_,_) = x-third4  (_,_,x,_) = x-fourth4 (_,_,_,x) = x+-- Functions -first5  (x,_,_,_,_) = x-second5 (_,x,_,_,_) = x-third5  (_,_,x,_,_) = x-fourth5 (_,_,_,x,_) = x-fifth5  (_,_,_,_,x) = x+-- | Apply a function the specified number of times,+-- which should be > 0 (otherwise does nothing).+-- Possibly uses O(n) stack ?+applyN :: Int -> (a -> a) -> a -> a+applyN n f | n < 1     = id+           | otherwise = (!! n) . iterate f+-- from protolude, compare+-- applyN :: Int -> (a -> a) -> a -> a+-- applyN n f = X.foldr (.) identity (X.replicate n f) -first6  (x,_,_,_,_,_) = x-second6 (_,x,_,_,_,_) = x-third6  (_,_,x,_,_,_) = x-fourth6 (_,_,_,x,_,_) = x-fifth6  (_,_,_,_,x,_) = x-sixth6  (_,_,_,_,_,x) = x+-- | Like mapM but uses sequence'.+{-# INLINABLE mapM' #-}+mapM' :: Monad f => (a -> f b) -> [a] -> f [b]+mapM' f = sequence' . map f --- currying+-- | This is a version of sequence based on difference lists. It is+-- slightly faster but we mostly use it because it uses the heap+-- instead of the stack. This has the advantage that Neil Mitchell’s+-- trick of limiting the stack size to discover space leaks doesn’t+-- show this as a false positive.+{-# INLINABLE sequence' #-}+sequence' :: Monad f => [f a] -> f [a]+sequence' ms = do+  h <- go id ms+  return (h [])+  where+    go h [] = return h+    go h (m:ms') = do+      x <- m+      go (h . (x :)) ms'  curry2 :: ((a, b) -> c) -> a -> b -> c curry2 f x y = f (x, y)@@ -106,8 +133,23 @@ uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (w, x, y, z) = f w x y z --- lists+-- Lists +-- | Total version of maximum, for integral types, giving 0 for an empty list.+maximum' :: Integral a => [a] -> a+maximum' [] = 0+maximum' xs = maximumStrict xs++-- | Strict version of maximum that doesn’t leak space+{-# INLINABLE maximumStrict #-}+maximumStrict :: Ord a => [a] -> a+maximumStrict = foldl1' max++-- | Strict version of minimum that doesn’t leak space+{-# INLINABLE minimumStrict #-}+minimumStrict :: Ord a => [a] -> a+minimumStrict = foldl1' min+ splitAtElement :: Eq a => a -> [a] -> [[a]] splitAtElement x l =   case l of@@ -118,123 +160,47 @@     split es = let (first,rest) = break (x==) es                in first : splitAtElement x rest --- trees+-- | Strict version of sum that doesn’t leak space+{-# INLINABLE sumStrict #-}+sumStrict :: Num a => [a] -> a+sumStrict = foldl' (+) 0 +-- Trees+ -- | Get the leaves of this tree as a list.  -- The topmost node ("root" in hledger account trees) is not counted as a leaf.-treeLeaves :: Show a => Tree a -> [a]+treeLeaves :: Tree a -> [a] treeLeaves Node{subForest=[]} = [] treeLeaves t = foldTree (\a bs -> (if null bs then (a:) else id) $ concat bs) t --- text---- time--getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t--getCurrentZonedTime :: IO ZonedTime-getCurrentZonedTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToZonedTime tz t---- misc---- | Apply a function the specified number of times,--- which should be > 0 (otherwise does nothing).--- Possibly uses O(n) stack ?-applyN :: Int -> (a -> a) -> a -> a-applyN n f | n < 1     = id-           | otherwise = (!! n) . iterate f--- from protolude, compare--- applyN :: Int -> (a -> a) -> a -> a--- applyN n f = X.foldr (.) identity (X.replicate n f)---- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,--- given the current directory. ~username is not supported. Leave "-" unchanged.--- Can raise an error.-expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers-expandPath _ "-" = return "-"-expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p--- PARTIAL:---- | Expand user home path indicated by tilde prefix-expandHomePath :: FilePath -> IO FilePath-expandHomePath = \case-    ('~':'/':p)  -> (</> p) <$> getHomeDirectory-    ('~':'\\':p) -> (</> p) <$> getHomeDirectory-    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"-    p            -> return p---- | Read text from a file,--- converting any \r\n line endings to \n,,--- using the system locale's text encoding,--- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.-readFilePortably :: FilePath -> IO Text-readFilePortably f =  openFile f ReadMode >>= readHandlePortably---- | Like readFilePortably, but read from standard input if the path is "-".-readFileOrStdinPortably :: String -> IO Text-readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably-  where-    openFileOrStdin :: String -> IOMode -> IO Handle-    openFileOrStdin "-" _ = return stdin-    openFileOrStdin f' m   = openFile f' m--readHandlePortably :: Handle -> IO Text-readHandlePortably h = do-  hSetNewlineMode h universalNewlineMode-  menc <- hGetEncoding h-  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show-    hSetEncoding h utf8_bom-  T.hGetContents h---- | Total version of maximum, for integral types, giving 0 for an empty list.-maximum' :: Integral a => [a] -> a-maximum' [] = 0-maximum' xs = maximumStrict xs+-- Tuples --- | Strict version of sum that doesn’t leak space-{-# INLINABLE sumStrict #-}-sumStrict :: Num a => [a] -> a-sumStrict = foldl' (+) 0+first3  (x,_,_) = x+second3 (_,x,_) = x+third3  (_,_,x) = x --- | Strict version of maximum that doesn’t leak space-{-# INLINABLE maximumStrict #-}-maximumStrict :: Ord a => [a] -> a-maximumStrict = foldl1' max+first4  (x,_,_,_) = x+second4 (_,x,_,_) = x+third4  (_,_,x,_) = x+fourth4 (_,_,_,x) = x --- | Strict version of minimum that doesn’t leak space-{-# INLINABLE minimumStrict #-}-minimumStrict :: Ord a => [a] -> a-minimumStrict = foldl1' min+first5  (x,_,_,_,_) = x+second5 (_,x,_,_,_) = x+third5  (_,_,x,_,_) = x+fourth5 (_,_,_,x,_) = x+fifth5  (_,_,_,_,x) = x --- | This is a version of sequence based on difference lists. It is--- slightly faster but we mostly use it because it uses the heap--- instead of the stack. This has the advantage that Neil Mitchell’s--- trick of limiting the stack size to discover space leaks doesn’t--- show this as a false positive.-{-# INLINABLE sequence' #-}-sequence' :: Monad f => [f a] -> f [a]-sequence' ms = do-  h <- go id ms-  return (h [])-  where-    go h [] = return h-    go h (m:ms') = do-      x <- m-      go (h . (x :)) ms'+first6  (x,_,_,_,_,_) = x+second6 (_,x,_,_,_,_) = x+third6  (_,_,x,_,_,_) = x+fourth6 (_,_,_,x,_,_) = x+fifth6  (_,_,_,_,x,_) = x+sixth6  (_,_,_,_,_,x) = x --- | Like mapM but uses sequence'.-{-# INLINABLE mapM' #-}-mapM' :: Monad f => (a -> f b) -> [a] -> f [b]-mapM' f = sequence' . map f+-- Misc  -- | Find the number of digits of an 'Int'.+{-# INLINE numDigitsInt #-} numDigitsInt :: Integral a => Int -> a numDigitsInt n     | n == minBound = 19  -- negate minBound is out of the range of Int@@ -248,46 +214,6 @@          | a >= 10000000000000000 = 16 + go (a `quot` 10000000000000000)          | a >= 100000000         = 8  + go (a `quot` 100000000)          | otherwise              = 4  + go (a `quot` 10000)-{-# INLINE numDigitsInt #-}---- | Simpler alias for errorWithoutStackTrace-error' :: String -> a-error' = errorWithoutStackTrace . ("Error: " <>)---- | A version of errorWithoutStackTrace that adds a usage hint.-usageError :: String -> a-usageError = error' . (++ " (use -h to see usage)")---- | Like embedFile, but takes a path relative to the package directory.--- Similar to embedFileRelative ?-embedFileRelative :: FilePath -> Q Exp-embedFileRelative f = makeRelativeToProject f >>= embedStringFile---- -- | Like hereFile, but takes a path relative to the package directory.--- -- Similar to embedFileRelative ?--- hereFileRelative :: FilePath -> Q Exp--- hereFileRelative f = makeRelativeToProject f >>= hereFileExp---   where---     QuasiQuoter{quoteExp=hereFileExp} = hereFile---- | Wrap a string in ANSI codes to set and reset foreground colour.-color :: ColorIntensity -> Color -> String -> String-color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []---- | Wrap a string in ANSI codes to set and reset background colour.-bgColor :: ColorIntensity -> Color -> String -> String-bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []---- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.-colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder-colorB int col (WideBuilder s w) =-    WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w---- | Wrap a WideBuilder in ANSI codes to set and reset background colour.-bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder-bgColorB int col (WideBuilder s w) =-    WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w-  -- | Make classy lenses for Hledger options fields. -- This is intended to be used with BalancingOpts, InputOpt, ReportOpts,

@@ -1,26 +1,59 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-} {- |  -Helpers for debug output and pretty-printing -(using pretty-simple, with which there may be some overlap).-This module also exports Debug.Trace.+Here are fancier versions of Debug.Trace, with these features: -@dbg0@-@dbg9@ will pretty-print values to stderr-if the program was run with a sufficiently high @--debug=N@ argument. -(@--debug@ with no argument means @--debug=1@; @dbg0@ always prints).+- 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 -The @debugLevel@ global is set once at startup using unsafePerformIO. -In GHCI, this happens only on the first run of :main, so if you want-to change the debug level without restarting GHCI,-save a dummy change in Debug.hs and do a :reload.-(Sometimes it's more convenient to temporarily add dbg0's and :reload.)+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. +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:++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 ...@.++The "OrLog" functions can either print to stderr or log to a file.++- By default, they print to stderr.++- 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.++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.++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.++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).+ In hledger, debug levels are used as follows: +@ Debug level:  What to show: ------------  --------------------------------------------------------- 0             normal command output only (no warnings, eg)-1 (--debug)   useful warnings, most common troubleshooting info, eg valuation+1             useful warnings, most common troubleshooting info, eg valuation 2             common troubleshooting info, more detail 3             report options selection 4             report generation@@ -29,34 +62,50 @@ 7             input file reading, more detail 8             command line parsing 9             any other rarely needed / more in-depth info+@  -} +-- Disabled until 0.1.2.0 is released with windows support+-- This module also exports Debug.Trace and the breakpoint package's Debug.Breakpoint.+ -- more: -- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html -- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html+-- https://hackage.haskell.org/package/debug  module Hledger.Utils.Debug (-  -- * Pretty printing-   pprint-  ,pprint'-  ,pshow-  ,pshow'-  ,useColorOnStdout-  ,useColorOnStderr-  -- * Tracing+ +   debugLevel++  -- * Tracing to stderr   ,traceWith-  -- * Pretty tracing-  ,ptrace-  -- ** Debug-level-aware tracing-  ,debugLevel   ,traceAt   ,traceAtWith+  ,ptrace   ,ptraceAt-  ,ptraceAtWith-  -- ** Easiest form (recommended)+  ,ptraceAtIO++  -- * Logging to PROGNAME.log+  ,traceLog+  ,traceLogAt+  ,traceLogIO+  ,traceLogAtIO+  ,traceLogWith+  ,traceLogAtWith+  ,ptraceLogAt+  ,ptraceLogAtIO++  -- * Tracing or logging based on shouldLog+  ,traceOrLog+  ,traceOrLogAt+  ,ptraceOrLogAt+  ,ptraceOrLogAtIO+  ,traceOrLogAtWith++  -- * Pretty tracing/logging in pure code   ,dbg0   ,dbg1   ,dbg2@@ -68,19 +117,8 @@   ,dbg8   ,dbg9   ,dbgExit-  -- ** More control-  ,dbg0With-  ,dbg1With-  ,dbg2With-  ,dbg3With-  ,dbg4With-  ,dbg5With-  ,dbg6With-  ,dbg7With-  ,dbg8With-  ,dbg9With-  -- ** For standalone lines in IO blocks-  ,ptraceAtIO++  -- * Pretty tracing/logging in IO   ,dbg0IO   ,dbg1IO   ,dbg2IO@@ -91,211 +129,76 @@   ,dbg7IO   ,dbg8IO   ,dbg9IO-  -- ** Trace the state of hledger parsers-  ,traceParse-  ,dbgparse-  -- ** Debug-logging to a file-  ,dlogTrace-  ,dlogTraceAt-  ,dlogAt-  ,dlog0-  ,dlog1-  ,dlog2-  ,dlog3-  ,dlog4-  ,dlog5-  ,dlog6-  ,dlog7-  ,dlog8-  ,dlog9-  -- ** Re-exports-  ,module Debug.Breakpoint++  -- * Tracing/logging with a show function+  ,dbg0With+  ,dbg1With+  ,dbg2With+  ,dbg3With+  ,dbg4With+  ,dbg5With+  ,dbg6With+  ,dbg7With+  ,dbg8With+  ,dbg9With++  -- * Re-exports+  -- ,module Debug.Breakpoint   ,module Debug.Trace+   ) where -import           Control.DeepSeq (force)-import           Control.Monad (when)-import           Control.Monad.IO.Class-import           Data.List hiding (uncons)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import           Debug.Breakpoint-import           Debug.Trace-import           Hledger.Utils.Parse-import           Safe (readDef)-import           System.Environment (getArgs, lookupEnv)-import           System.Exit-import           System.IO.Unsafe (unsafePerformIO)-import           Text.Megaparsec-import           Text.Printf-import           Text.Pretty.Simple  -- (defaultOutputOptionsDarkBg, OutputOptions(..), pShowOpt, pPrintOpt)-import Data.Maybe (isJust)-import System.Console.ANSI (hSupportsANSIColor)-import System.IO (stdout, Handle, stderr)+import Control.DeepSeq (force) import Control.Exception (evaluate)---- | pretty-simple options with colour enabled if allowed.-prettyopts = -  (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)-    { outputOptionsIndentAmount=2-    , outputOptionsCompact=True-    }---- | pretty-simple options with colour disabled.-prettyopts' =-  defaultOutputOptionsNoColor-    { outputOptionsIndentAmount=2-    , outputOptionsCompact=True-    }---- | Pretty print. Generic alias for pretty-simple's pPrint.-pprint :: Show a => a -> IO ()-pprint = pPrintOpt CheckColorTty prettyopts---- | Monochrome version of pprint.-pprint' :: Show a => a -> IO ()-pprint' = pPrintOpt CheckColorTty prettyopts'---- | Pretty show. Generic alias for pretty-simple's pShow.-pshow :: Show a => a -> String-pshow = TL.unpack . pShowOpt prettyopts---- | Monochrome version of pshow.-pshow' :: Show a => a -> String-pshow' = TL.unpack . pShowOpt prettyopts'+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List hiding (uncons)+-- import Debug.Breakpoint+import Debug.Trace (trace, traceIO, traceShowId)+import Safe (readDef)+import System.Environment (getProgName)+import System.Exit (exitFailure)+import System.IO.Unsafe (unsafePerformIO) --- XXX some of the below can be improved with pretty-simple, https://github.com/cdepillabout/pretty-simple#readme+import Hledger.Utils.IO (progArgs, pshow, pshow') --- | Pretty trace. Easier alias for traceShowId + pShow.-ptrace :: Show a => a -> a-ptrace = traceWith pshow+-- | The program name as returned by @getProgName@.+-- It's best to set this explicitly at program startup with @withProgName@,+-- otherwise when running in GHCI (eg) it will change to "<interactive>".+-- Setting it with a ".log" suffix causes some functions below+-- to log instead of trace.+{-# NOINLINE modifiedProgName #-}+modifiedProgName :: String+modifiedProgName = unsafePerformIO getProgName --- | Like traceShowId, but uses a custom show function to render the value.--- traceShowIdWith was too much of a mouthful.-traceWith :: Show a => (a -> String) -> a -> a-traceWith f a = trace (f a) a+-- | The progam name, with any ".log" suffix removed.+progName :: String+progName =+  if ".log" `isSuffixOf` modifiedProgName+  then reverse $ drop 4 $ reverse modifiedProgName+  else modifiedProgName --- | Global debug level, which controls the verbosity of debug errput--- on the console. The default is 0 meaning no debug errput. The--- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to--- a higher value (note: not @--debug N@ for some reason).  This uses--- unsafePerformIO and can be accessed from anywhere and before normal--- command-line processing. When running with :main in GHCI, you must--- touch and reload this module to see the effect of a new --debug option.--- {-# OPTIONS_GHC -fno-cse #-}-{-# NOINLINE debugLevel #-}--- Avoid using dbg* in this function (infinite loop).+-- | 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. +-- When running in GHCI, changing this requires reloading this module. debugLevel :: Int-debugLevel = case dropWhile (/="--debug") args of+debugLevel = case dropWhile (/="--debug") progArgs of                ["--debug"]   -> 1                "--debug":n:_ -> readDef 1 n                _             ->-                 case take 1 $ filter ("--debug" `isPrefixOf`) args of+                 case take 1 $ filter ("--debug" `isPrefixOf`) progArgs of                    ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v                    _                                   -> 0 -    where-      args = unsafePerformIO getArgs---- Avoid using dbg*, pshow etc. in this function (infinite loop).--- | Check the IO environment to see if ANSI colour codes should be used on stdout.--- This is done using unsafePerformIO so it can be used anywhere, eg in--- low-level debug utilities, which should be ok since we are just reading.--- The logic is: use color if--- the program was started with --color=yes|always--- or (---   the program was not started with --color=no|never---   and a NO_COLOR environment variable is not defined---   and stdout supports ANSI color and -o/--output-file was not used or is "-"--- ).--- Caveats:--- When running code in GHCI, this module must be reloaded to see a change.--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE useColorOnStdout #-}-useColorOnStdout :: Bool-useColorOnStdout = not hasOutputFile && useColorOnHandle stdout---- Avoid using dbg*, pshow etc. in this function (infinite loop).--- | Like useColorOnStdout, but checks for ANSI color support on stderr,--- and is not affected by -o/--output-file.--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE useColorOnStdout #-}-useColorOnStderr :: Bool-useColorOnStderr = useColorOnHandle stderr---- Avoid using dbg*, pshow etc. in this function (infinite loop).--- XXX sorry, I'm just cargo-culting these pragmas:--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE useColorOnHandle #-}-useColorOnHandle :: Handle -> Bool-useColorOnHandle h = unsafePerformIO $ do-  no_color       <- isJust <$> lookupEnv "NO_COLOR"-  supports_color <- hSupportsANSIColor h-  let coloroption = colorOption-  return $ coloroption `elem` ["always","yes"]-       || (coloroption `notElem` ["never","no"] && not no_color && supports_color)---- Keep synced with color/colour flag definition in hledger:CliOptions.--- Avoid using dbg*, pshow etc. in this function (infinite loop).--- | Read the value of the --color or --colour command line option provided at program startup--- using unsafePerformIO. If this option was not provided, returns the empty string.--- (When running code in GHCI, this module must be reloaded to see a change.)--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE colorOption #-}-colorOption :: String-colorOption = -  -- similar to debugLevel-  let args = unsafePerformIO getArgs in-  case dropWhile (/="--color") args of-    -- --color ARG-    "--color":v:_ -> v-    _ ->-      case take 1 $ filter ("--color=" `isPrefixOf`) args of-        -- --color=ARG-        ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v-        _ ->-          case dropWhile (/="--colour") args of-            -- --colour ARG-            "--colour":v:_ -> v-            _ ->-              case take 1 $ filter ("--colour=" `isPrefixOf`) args of-                -- --colour=ARG-                ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v-                _ -> ""---- Avoid using dbg*, pshow etc. in this function (infinite loop).--- | Check whether the -o/--output-file option has been used at program startup--- with an argument other than "-", using unsafePerformIO.--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE hasOutputFile #-}-hasOutputFile :: Bool-hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]+-- | Trace a value with the given show function before returning it.+traceWith :: (a -> String) -> a -> a+traceWith f a = trace (f a) a --- Keep synced with output-file flag definition in hledger:CliOptions.--- Avoid using dbg*, pshow etc. in this function (infinite loop).--- | Read the value of the -o/--output-file command line option provided at program startup,--- if any, using unsafePerformIO.--- (When running code in GHCI, this module must be reloaded to see a change.)--- {-# OPTIONS_GHC -fno-cse #-}--- {-# NOINLINE outputFileOption #-}-outputFileOption :: Maybe String-outputFileOption = -  let args = unsafePerformIO getArgs in-  case dropWhile (not . ("-o" `isPrefixOf`)) args of-    -- -oARG-    ('-':'o':v@(_:_)):_ -> Just v-    -- -o ARG-    "-o":v:_ -> Just v-    _ ->-      case dropWhile (/="--output-file") args of-        -- --output-file ARG-        "--output-file":v:_ -> Just v-        _ ->-          case take 1 $ filter ("--output-file=" `isPrefixOf`) args of-            -- --output=file=ARG-            ['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v-            _ -> Nothing+-- | 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 -- or above the specified level. At level 0, always prints. Otherwise,@@ -317,223 +220,216 @@ ptraceAt :: Show a => Int -> String -> a -> a ptraceAt level     | level > 0 && debugLevel < level = const id-    | otherwise = \s a -> let ls = lines $ pshow a-                              nlorspace | length ls > 1 = "\n"-                                        | otherwise     = replicate (max 1 $ 11 - length s) ' '-                              ls' | length ls > 1 = map (' ':) ls-                                  | otherwise     = ls-                          in trace (s++":"++nlorspace++intercalate "\n" ls') a+    | otherwise = \lbl a -> trace (labelledPretty True lbl a) a+    +-- Pretty-print a showable value with a label, with or without allowing ANSI color.+labelledPretty :: Show a => Bool -> String -> a -> String+labelledPretty allowcolour lbl a = lbl ++ ":" ++ nlorspace ++ intercalate "\n" ls'+  where+    ls = lines $ (if allowcolour then pshow else pshow') a+    nlorspace | length ls > 1 = "\n"+              | otherwise     = replicate (max 1 $ 11 - length lbl) ' '+    ls' | length ls > 1 = map (' ':) ls+        | otherwise     = ls --- | Like ptraceAt, but takes a custom show function instead of a label.-ptraceAtWith :: Show a => Int -> (a -> String) -> a -> a-ptraceAtWith level f-    | level > 0 && debugLevel < level = id-    | otherwise = \a -> let p = f a-                            -- ls = lines p-                            -- nlorspace | length ls > 1 = "\n"-                            --           | otherwise     = " " ++ take (10 - length s) (repeat ' ')-                            -- ls' | length ls > 1 = map (" "++) ls-                            --     | otherwise     = ls-                        -- in trace (s++":"++nlorspace++intercalate "\n" ls') a-                        in trace p a+-- | Like ptraceAt, but convenient to insert in an IO monad and+-- enforces monadic sequencing.+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) --- "dbg" would clash with megaparsec.--- | Pretty-print a label and the showable value to the console, then return it.-dbg0 :: Show a => String -> a -> a-dbg0 = ptraceAt 0+-- | 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 --- | Pretty-print a label and the showable value to the console when the global debug level is >= 1, then return it.+-- | The debug log file: PROGNAME.log in the current directory.+-- See modifiedProgName.+debugLogFile :: FilePath+debugLogFile = progName ++ ".log"++-- -- | 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.-dbg1 :: Show a => String -> a -> a-dbg1 = ptraceAt 1+traceLog :: String -> a -> a+traceLog s x = unsafePerformIO $ do+  evaluate (force s)  -- to complete any previous logging before we attempt more+  appendFile debugLogFile (s ++ "\n")+  return x -dbg2 :: Show a => String -> a -> a-dbg2 = ptraceAt 2+-- | Log a string to the debug log before returning the second argument,+-- if the global 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+  | level > 0 && debugLevel < level = id+  | otherwise = traceLog str -dbg3 :: Show a => String -> a -> a-dbg3 = ptraceAt 3+-- | Like traceLog but sequences properly in IO.+traceLogIO :: MonadIO m => String -> m ()+traceLogIO s = do+  liftIO $ evaluate (force s)  -- to complete any previous logging before we attempt more+  liftIO $ appendFile debugLogFile (s ++ "\n") -dbg4 :: Show a => String -> a -> a-dbg4 = ptraceAt 4+-- | Like traceLogAt, but convenient to use in IO.+traceLogAtIO :: MonadIO m => Int -> String -> m ()+traceLogAtIO level str+  | level > 0 && debugLevel < level = return ()+  | otherwise = traceLogIO str -dbg5 :: Show a => String -> a -> a-dbg5 = ptraceAt 5+-- | 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 -dbg6 :: Show a => String -> a -> a-dbg6 = ptraceAt 6+-- | Log a string to the debug log before returning the second argument,+-- if the global 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  -dbg7 :: Show a => String -> a -> a-dbg7 = ptraceAt 7+-- | Pretty-log a label and showable value to the debug log,+-- if the global 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+  | level > 0 && debugLevel < level = const id+  | otherwise = \lbl a -> traceLog (labelledPretty False lbl a) a -dbg8 :: Show a => String -> a -> a-dbg8 = ptraceAt 8+-- | 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 =+  if level > 0 && debugLevel < level+  then return ()+  else traceLogIO (labelledPretty False label a) -dbg9 :: Show a => String -> a -> a-dbg9 = ptraceAt 9+-- Trace or log a string depending on shouldLog,+-- before returning the second argument.+traceOrLog :: String -> a -> a+traceOrLog = if shouldLog then trace else traceLog --- | Like dbg0, but also exit the program. Uses unsafePerformIO.--- {-# NOINLINE dbgExit #-}-dbgExit :: Show a => String -> a -> a-dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg+-- 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 --- | Like dbg0, but takes a custom show function instead of a label.-dbg0With :: Show a => (a -> String) -> a -> a-dbg0With = ptraceAtWith 0+-- 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 -dbg1With :: Show a => (a -> String) -> a -> a-dbg1With = ptraceAtWith 1+-- Like ptraceOrLogAt, but convenient in IO.+ptraceOrLogAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()+ptraceOrLogAtIO = if shouldLog then ptraceLogAtIO else ptraceAtIO -dbg2With :: Show a => (a -> String) -> a -> a-dbg2With = ptraceAtWith 2+-- Trace or log, with a show function, depending on shouldLog.+traceOrLogAtWith :: Int -> (a -> String) -> a -> a+traceOrLogAtWith = if shouldLog then traceLogAtWith else traceAtWith -dbg3With :: Show a => (a -> String) -> a -> a-dbg3With = ptraceAtWith 3+-- | Pretty-trace to stderr (or log to debug log) a label and showable value,+-- then return it.+dbg0 :: Show a => String -> a -> a+dbg0 = ptraceOrLogAt 0 -dbg4With :: Show a => (a -> String) -> a -> a-dbg4With = ptraceAtWith 4+-- | 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 -dbg5With :: Show a => (a -> String) -> a -> a-dbg5With = ptraceAtWith 5+dbg2 :: Show a => String -> a -> a+dbg2 = ptraceOrLogAt 2 -dbg6With :: Show a => (a -> String) -> a -> a-dbg6With = ptraceAtWith 6+dbg3 :: Show a => String -> a -> a+dbg3 = ptraceOrLogAt 3 -dbg7With :: Show a => (a -> String) -> a -> a-dbg7With = ptraceAtWith 7+dbg4 :: Show a => String -> a -> a+dbg4 = ptraceOrLogAt 4 -dbg8With :: Show a => (a -> String) -> a -> a-dbg8With = ptraceAtWith 8+dbg5 :: Show a => String -> a -> a+dbg5 = ptraceOrLogAt 5 -dbg9With :: Show a => (a -> String) -> a -> a-dbg9With = ptraceAtWith 9+dbg6 :: Show a => String -> a -> a+dbg6 = ptraceOrLogAt 6 --- | Like ptraceAt, but convenient to insert in an IO monad and--- enforces monadic sequencing (plus convenience aliases).--- XXX These have a bug; they should use--- traceIO, not trace, otherwise GHC can occasionally over-optimise--- (cf lpaste a few days ago where it killed/blocked a child thread).-ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()-ptraceAtIO lvl lbl x = liftIO $ ptraceAt lvl lbl x `seq` return ()+dbg7 :: Show a => String -> a -> a+dbg7 = ptraceOrLogAt 7 --- XXX Could not deduce (a ~ ())--- ptraceAtM :: (Monad m, Show a) => Int -> String -> a -> m a--- ptraceAtM lvl lbl x = ptraceAt lvl lbl x `seq` return x+dbg8 :: Show a => String -> a -> a+dbg8 = ptraceOrLogAt 8 +dbg9 :: Show a => String -> a -> a+dbg9 = ptraceOrLogAt 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. dbg0IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg0IO = ptraceAtIO 0+dbg0IO = ptraceOrLogAtIO 0  dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg1IO = ptraceAtIO 1+dbg1IO = ptraceOrLogAtIO 1  dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg2IO = ptraceAtIO 2+dbg2IO = ptraceOrLogAtIO 2  dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg3IO = ptraceAtIO 3+dbg3IO = ptraceOrLogAtIO 3  dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg4IO = ptraceAtIO 4+dbg4IO = ptraceOrLogAtIO 4  dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg5IO = ptraceAtIO 5+dbg5IO = ptraceOrLogAtIO 5  dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg6IO = ptraceAtIO 6+dbg6IO = ptraceOrLogAtIO 6  dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg7IO = ptraceAtIO 7+dbg7IO = ptraceOrLogAtIO 7  dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg8IO = ptraceAtIO 8+dbg8IO = ptraceOrLogAtIO 8  dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()-dbg9IO = ptraceAtIO 9---- | Log a string to ./debug.log before returning the second argument.--- Uses unsafePerformIO.--- {-# NOINLINE dlogTrace #-}-dlogTrace :: String -> a -> a-dlogTrace s x = unsafePerformIO $ do-  evaluate (force s)  -- to complete any previous logging before we attempt more-  appendFile "debug.log" (s ++ "\n")-  return x---- | Log a string to ./debug.log before returning the second argument,--- if the global debug level is at or above the specified level.--- At level 0, always logs. Otherwise, uses unsafePerformIO.-dlogTraceAt :: Int -> String -> a -> a-dlogTraceAt level s-  | level > 0 && debugLevel < level = id-  | otherwise = dlogTrace s---- | Log a label and pretty-printed showable value to "./debug.log",--- if the global debug level is at or above the specified level.--- At level 0, always prints. Otherwise, uses unsafePerformIO.-dlogAt :: Show a => Int -> String -> a -> a-dlogAt level-  | level > 0 && debugLevel < level = const id-  | otherwise = \lbl a ->-    let -      ls = lines $ pshow' a-      nlorspace | length ls > 1 = "\n"-                | otherwise     = replicate (max 1 $ 11 - length lbl) ' '-      ls' | length ls > 1 = map (' ':) ls-          | otherwise     = ls-    in dlogTrace (lbl++":"++nlorspace++intercalate "\n" ls') a---- | Pretty-print a label and the showable value to ./debug.log if at or above--- a certain debug level, then return it.-dlog0 :: Show a => String -> a -> a-dlog0 = dlogAt 0--dlog1 :: Show a => String -> a -> a-dlog1 = dlogAt 1--dlog2 :: Show a => String -> a -> a-dlog2 = dlogAt 2+dbg9IO = ptraceOrLogAtIO 9 -dlog3 :: Show a => String -> a -> a-dlog3 = dlogAt 3+-- | Like dbgN, but taking a show function instead of a label.+dbg0With :: (a -> String) -> a -> a+dbg0With = traceOrLogAtWith 0 -dlog4 :: Show a => String -> a -> a-dlog4 = dlogAt 4+dbg1With :: Show a => (a -> String) -> a -> a+dbg1With = traceOrLogAtWith 1 -dlog5 :: Show a => String -> a -> a-dlog5 = dlogAt 5+dbg2With :: Show a => (a -> String) -> a -> a+dbg2With = traceOrLogAtWith 2 -dlog6 :: Show a => String -> a -> a-dlog6 = dlogAt 6+dbg3With :: Show a => (a -> String) -> a -> a+dbg3With = traceOrLogAtWith 3 -dlog7 :: Show a => String -> a -> a-dlog7 = dlogAt 7+dbg4With :: Show a => (a -> String) -> a -> a+dbg4With = traceOrLogAtWith 4 -dlog8 :: Show a => String -> a -> a-dlog8 = dlogAt 8+dbg5With :: Show a => (a -> String) -> a -> a+dbg5With = traceOrLogAtWith 5 -dlog9 :: Show a => String -> a -> a-dlog9 = dlogAt 9+dbg6With :: Show a => (a -> String) -> a -> a+dbg6With = traceOrLogAtWith 6 --- | Print the provided label (if non-null) and current parser state--- (position and next input) to the console. See also megaparsec's dbg.-traceParse :: String -> TextParser m ()-traceParse msg = do-  pos <- getSourcePos-  next <- (T.take peeklength) `fmap` getInput-  let (l,c) = (sourceLine pos, sourceColumn pos)-      s  = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String-      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg-  trace s' $ return ()-  where-    peeklength = 30+dbg7With :: Show a => (a -> String) -> a -> a+dbg7With = traceOrLogAtWith 7 --- | Print the provided label (if non-null) and current parser state--- (position and next input) to the console if the global debug level--- is at or above the specified level. Uses unsafePerformIO.--- (See also megaparsec's dbg.)-traceParseAt :: Int -> String -> TextParser m ()-traceParseAt level msg = when (level <= debugLevel) $ traceParse msg+dbg8With :: Show a => (a -> String) -> a -> a+dbg8With = traceOrLogAtWith 8 --- | Convenience alias for traceParseAt-dbgparse :: Int -> String -> TextParser m ()-dbgparse = traceParseAt+dbg9With :: Show a => (a -> String) -> a -> a+dbg9With = traceOrLogAtWith 9 

@@ -0,0 +1,298 @@+{- | +Helpers for pretty-printing haskell values, reading command line arguments,+working with ANSI colours, files, and time.+Uses unsafePerformIO.++Limitations:+When running in GHCI, this module must be reloaded to see environmental changes.+The colour scheme may be somewhat hard-coded.++-}++{-# LANGUAGE LambdaCase #-}++module Hledger.Utils.IO (++  -- * Pretty showing/printing+  pshow,+  pshow',+  pprint,+  pprint',++  -- * Command line arguments+  progArgs,+  outputFileOption,+  hasOutputFile,++  -- * ANSI color+  colorOption,+  useColorOnStdout,+  useColorOnStderr,+  color,+  bgColor,+  colorB,+  bgColorB,  ++  -- * Errors+  error',+  usageError,++  -- * Files+  embedFileRelative,+  expandHomePath,+  expandPath,+  readFileOrStdinPortably,+  readFilePortably,+  readHandlePortably,+  -- hereFileRelative,++  -- * Time+  getCurrentLocalTime,+  getCurrentZonedTime,++  )+where++import           Control.Monad (when)+import           Data.FileEmbed (makeRelativeToProject, embedStringFile)+import           Data.List hiding (uncons)+import           Data.Maybe (isJust)+import           Data.Text (Text)+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           Language.Haskell.TH.Syntax (Q, Exp)+import           System.Console.ANSI+  (Color,ColorIntensity,ConsoleLayer(..), SGR(..), hSupportsANSIColor, setSGRCode)+import           System.Directory (getHomeDirectory)+import           System.Environment (getArgs, lookupEnv)+import           System.FilePath (isRelative, (</>))+import           System.IO+  (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,+   openFile, stdin, stdout, stderr, universalNewlineMode, utf8_bom)+import           System.IO.Unsafe (unsafePerformIO)+import           Text.Pretty.Simple+  (CheckColorTty(CheckColorTty), OutputOptions(..), +  defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)++import Hledger.Utils.Text (WideBuilder(WideBuilder))++-- Pretty showing/printing with pretty-simple++-- | pretty-simple options with colour enabled if allowed.+prettyopts = +  (if useColorOnStderr then defaultOutputOptionsDarkBg else defaultOutputOptionsNoColor)+    { outputOptionsIndentAmount=2+    , outputOptionsCompact=True+    }++-- | pretty-simple options with colour disabled.+prettyopts' =+  defaultOutputOptionsNoColor+    { outputOptionsIndentAmount=2+    , outputOptionsCompact=True+    }++-- | Pretty show. Easier alias for pretty-simple's pShow.+pshow :: Show a => a -> String+pshow = TL.unpack . pShowOpt prettyopts++-- | Monochrome version of pshow.+pshow' :: Show a => a -> String+pshow' = TL.unpack . pShowOpt prettyopts'++-- | Pretty print. Easier alias for pretty-simple's pPrint.+pprint :: Show a => a -> IO ()+pprint = pPrintOpt CheckColorTty prettyopts++-- | Monochrome version of pprint.+pprint' :: Show a => a -> IO ()+pprint' = pPrintOpt CheckColorTty prettyopts'++-- "Avoid using pshow, pprint, dbg* in the code below to prevent infinite loops." (?)++-- Command line arguments++-- | The command line arguments that were used at program startup.+-- Uses unsafePerformIO.+{-# NOINLINE progArgs #-}+progArgs :: [String]+progArgs = unsafePerformIO getArgs++-- | Read the value of the -o/--output-file command line option provided at program startup,+-- if any, using unsafePerformIO.+outputFileOption :: Maybe String+outputFileOption = +  -- keep synced with output-file flag definition in hledger:CliOptions.+  let args = progArgs in+  case dropWhile (not . ("-o" `isPrefixOf`)) args of+    -- -oARG+    ('-':'o':v@(_:_)):_ -> Just v+    -- -o ARG+    "-o":v:_ -> Just v+    _ ->+      case dropWhile (/="--output-file") args of+        -- --output-file ARG+        "--output-file":v:_ -> Just v+        _ ->+          case take 1 $ filter ("--output-file=" `isPrefixOf`) args of+            -- --output=file=ARG+            ['-':'-':'o':'u':'t':'p':'u':'t':'-':'f':'i':'l':'e':'=':v] -> Just v+            _ -> Nothing++-- | Check whether the -o/--output-file option has been used at program startup+-- with an argument other than "-", using unsafePerformIO.+hasOutputFile :: Bool+hasOutputFile = outputFileOption `notElem` [Nothing, Just "-"]++-- ANSI colour++-- | Read the value of the --color or --colour command line option provided at program startup+-- using unsafePerformIO. If this option was not provided, returns the empty string.+colorOption :: String+colorOption = +  -- similar to debugLevel+  -- keep synced with color/colour flag definition in hledger:CliOptions+  let args = progArgs in+  case dropWhile (/="--color") args of+    -- --color ARG+    "--color":v:_ -> v+    _ ->+      case take 1 $ filter ("--color=" `isPrefixOf`) args of+        -- --color=ARG+        ['-':'-':'c':'o':'l':'o':'r':'=':v] -> v+        _ ->+          case dropWhile (/="--colour") args of+            -- --colour ARG+            "--colour":v:_ -> v+            _ ->+              case take 1 $ filter ("--colour=" `isPrefixOf`) args of+                -- --colour=ARG+                ['-':'-':'c':'o':'l':'o':'u':'r':'=':v] -> v+                _ -> ""++-- | Check the IO environment to see if ANSI colour codes should be used on stdout.+-- This is done using unsafePerformIO so it can be used anywhere, eg in+-- low-level debug utilities, which should be ok since we are just reading.+-- The logic is: use color if+-- the program was started with --color=yes|always+-- or (+--   the program was not started with --color=no|never+--   and a NO_COLOR environment variable is not defined+--   and stdout supports ANSI color+--   and -o/--output-file was not used, or its value is "-"+-- ).+useColorOnStdout :: Bool+useColorOnStdout = not hasOutputFile && useColorOnHandle stdout++-- | Like useColorOnStdout, but checks for ANSI color support on stderr,+-- and is not affected by -o/--output-file.+useColorOnStderr :: Bool+useColorOnStderr = useColorOnHandle stderr++useColorOnHandle :: Handle -> Bool+useColorOnHandle h = unsafePerformIO $ do+  no_color       <- isJust <$> lookupEnv "NO_COLOR"+  supports_color <- hSupportsANSIColor h+  let coloroption = colorOption+  return $ coloroption `elem` ["always","yes"]+       || (coloroption `notElem` ["never","no"] && not no_color && supports_color)++-- | Wrap a string in ANSI codes to set and reset foreground colour.+color :: ColorIntensity -> Color -> String -> String+color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []++-- | Wrap a string in ANSI codes to set and reset background colour.+bgColor :: ColorIntensity -> Color -> String -> String+bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []++-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.+colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder+colorB int col (WideBuilder s w) =+    WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w++-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.+bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder+bgColorB int col (WideBuilder s w) =+    WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w++-- Errors++-- | Simpler alias for errorWithoutStackTrace+error' :: String -> a+error' = errorWithoutStackTrace . ("Error: " <>)++-- | A version of errorWithoutStackTrace that adds a usage hint.+usageError :: String -> a+usageError = error' . (++ " (use -h to see usage)")++-- Files++-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,+-- given the current directory. ~username is not supported. Leave "-" unchanged.+-- Can raise an error.+expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers+expandPath _ "-" = return "-"+expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p+-- PARTIAL:++-- | Expand user home path indicated by tilde prefix+expandHomePath :: FilePath -> IO FilePath+expandHomePath = \case+    ('~':'/':p)  -> (</> p) <$> getHomeDirectory+    ('~':'\\':p) -> (</> p) <$> getHomeDirectory+    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"+    p            -> return p++-- | Read text from a file,+-- converting any \r\n line endings to \n,,+-- using the system locale's text encoding,+-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.+readFilePortably :: FilePath -> IO Text+readFilePortably f =  openFile f ReadMode >>= readHandlePortably++-- | Like readFilePortably, but read from standard input if the path is "-".+readFileOrStdinPortably :: String -> IO Text+readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably+  where+    openFileOrStdin :: String -> IOMode -> IO Handle+    openFileOrStdin "-" _ = return stdin+    openFileOrStdin f' m   = openFile f' m++readHandlePortably :: Handle -> IO Text+readHandlePortably h = do+  hSetNewlineMode h universalNewlineMode+  menc <- hGetEncoding h+  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show+    hSetEncoding h utf8_bom+  T.hGetContents h++-- | Like embedFile, but takes a path relative to the package directory.+-- Similar to embedFileRelative ?+embedFileRelative :: FilePath -> Q Exp+embedFileRelative f = makeRelativeToProject f >>= embedStringFile++-- -- | Like hereFile, but takes a path relative to the package directory.+-- -- Similar to embedFileRelative ?+-- hereFileRelative :: FilePath -> Q Exp+-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp+--   where+--     QuasiQuoter{quoteExp=hereFileExp} = hereFile++-- Time++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToLocalTime tz t++getCurrentZonedTime :: IO ZonedTime+getCurrentZonedTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToZonedTime tz t+

@@ -37,22 +37,30 @@   skipNonNewlineSpaces1,   skipNonNewlineSpaces', +  -- ** Trace the state of hledger parsers+  traceOrLogParse,+  dbgparse,+   -- * re-exports   HledgerParseErrors,-  HledgerParseErrorData+  HledgerParseErrorData,+  customErrorBundlePretty, ) where +import Control.Monad (when)+import qualified Data.Text as T+import Text.Megaparsec+import Text.Printf import Control.Monad.State.Strict (StateT, evalStateT) import Data.Char import Data.Functor (void) import Data.Functor.Identity (Identity(..)) import Data.List import Data.Text (Text)-import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Custom-import Text.Printf+import Hledger.Utils.Debug (debugLevel, traceOrLog)  -- | A parser of string to some type. type SimpleStringParser a = Parsec HledgerParseErrorData String a@@ -63,6 +71,31 @@ -- | A parser of text that runs in some monad. type TextParser m a = ParsecT HledgerParseErrorData Text m a +-- | 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.+traceOrLogParse :: String -> TextParser m ()+traceOrLogParse msg = do+  pos <- getSourcePos+  next <- (T.take peeklength) `fmap` getInput+  let (l,c) = (sourceLine pos, sourceColumn pos)+      s  = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String+      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg+  traceOrLog s' $ return ()+  where+    peeklength = 30++-- class (Stream s, MonadPlus m) => MonadParsec e s m +-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m ()++-- | Trace to stderr or log to debug log the provided label (if non-null)+-- and current parser state (position and next input),+-- if the global debug level is at or above the specified level.+-- Uses unsafePerformIO.+dbgparse :: Int -> String -> TextParser m ()+dbgparse level msg = when (level <= debugLevel) $ traceOrLogParse msg+ -- | Render a pair of source positions in human-readable form, only displaying the range of lines. sourcePosPairPretty :: (SourcePos, SourcePos) -> String sourcePosPairPretty (SourcePos fp l1 _, SourcePos _ l2 c2) =@@ -149,19 +182,18 @@  -- Skip many non-newline spaces. skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()-skipNonNewlineSpaces = () <$ takeWhileP Nothing isNonNewlineSpace+skipNonNewlineSpaces = void $ takeWhileP Nothing isNonNewlineSpace {-# INLINABLE skipNonNewlineSpaces #-}  -- Skip many non-newline spaces, failing if there are none. skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()-skipNonNewlineSpaces1 = () <$ takeWhile1P Nothing isNonNewlineSpace+skipNonNewlineSpaces1 = void $ takeWhile1P Nothing isNonNewlineSpace {-# INLINABLE skipNonNewlineSpaces1 #-}  -- Skip many non-newline spaces, returning True if any have been skipped. skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m Bool skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False {-# INLINABLE skipNonNewlineSpaces' #-}-  eolof :: TextParser m () eolof = void newline <|> eof

@@ -38,7 +38,7 @@     finalErrorBundlePretty,   ) -import Hledger.Utils.Debug (pshow)+import Hledger.Utils.IO (pshow)  -- * tasty helpers 

@@ -1,3 +1,6 @@+-- A bunch of megaparsec helpers for re-parsing etc.+-- I think these are generic apart from the HledgerParseError name.+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}@@ -59,6 +62,7 @@ --- * Custom parse error types  -- | Custom error data for hledger parsers. Specialised for a 'Text' parse stream.+-- ReparseableTextParseErrorData ? data HledgerParseErrorData   -- | Fail with a message at a specific source position interval. The   -- interval must be contained within a single line.

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.27.1+version:        1.28 synopsis:       A reusable library providing the core functionality of hledger description:    A reusable library containing hledger's core functionality.                 This is used by most hledger* packages so that they support the same@@ -83,6 +83,7 @@       Hledger.Reports.PostingsReport       Hledger.Utils       Hledger.Utils.Debug+      Hledger.Utils.IO       Hledger.Utils.Parse       Hledger.Utils.Regex       Hledger.Utils.String@@ -103,9 +104,8 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.17+    , base >=4.14 && <4.18     , blaze-markup >=0.5.1-    , breakpoint     , bytestring     , call-stack     , cassava@@ -120,7 +120,7 @@     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1-    , megaparsec >=7.0.0 && <9.3+    , megaparsec >=7.0.0 && <9.4     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1@@ -155,9 +155,8 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.17+    , base >=4.14 && <4.18     , blaze-markup >=0.5.1-    , breakpoint     , bytestring     , call-stack     , cassava@@ -173,7 +172,7 @@     , file-embed >=0.0.10     , filepath     , hashtables >=1.2.3.1-    , megaparsec >=7.0.0 && <9.3+    , megaparsec >=7.0.0 && <9.4     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1@@ -192,9 +191,9 @@     , uglymemo     , unordered-containers >=0.2     , utf8-string >=0.3.5+  default-language: Haskell2010   if impl(ghc >= 9.0) && impl(ghc < 9.2)     buildable: False-  default-language: Haskell2010  test-suite unittest   type: exitcode-stdio-1.0@@ -210,9 +209,8 @@     , aeson-pretty     , ansi-terminal >=0.9     , array-    , base >=4.14 && <4.17+    , base >=4.14 && <4.18     , blaze-markup >=0.5.1-    , breakpoint     , bytestring     , call-stack     , cassava@@ -228,7 +226,7 @@     , filepath     , hashtables >=1.2.3.1     , hledger-lib-    , megaparsec >=7.0.0 && <9.3+    , megaparsec >=7.0.0 && <9.4     , microlens >=0.4     , microlens-th >=0.4     , mtl >=2.2.1