hledger-lib 1.51.2 → 1.52

raw patch · 21 files changed

+613/−269 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +17/−11
• Hledger/Data/AccountName.hs +10/−0
• Hledger/Data/Amount.hs +35/−7
• Hledger/Data/Dates.hs +82/−13
• Hledger/Data/Journal.hs +25/−7
• Hledger/Data/Json.hs +2/−0
• Hledger/Data/Posting.hs +8/−2
• Hledger/Data/Types.hs +37/−9
• Hledger/Data/Valuation.hs +101/−46
• Hledger/Query.hs +14/−8
• Hledger/Read.hs +29/−6
• Hledger/Read/Common.hs +36/−24
• Hledger/Read/InputOptions.hs +2/−2
• Hledger/Read/JournalReader.hs +31/−25
• Hledger/Reports/MultiBalanceReport.hs +4/−4
• Hledger/Reports/ReportOptions.hs +15/−3
• Hledger/Utils.hs +7/−0
• Hledger/Utils/IO.hs +124/−92
• Hledger/Utils/Text.hs +6/−2
• Hledger/Write/Beancount.hs +23/−3
• hledger-lib.cabal +5/−5

@@ -17,14 +17,28 @@ For user-visible changes, see the hledger package changelog.  +# 1.52 2026-03-20++Breaking changes++- A cost basis field (`acostbasis`) has been added to Amount (to store Ledger/Beancount-style cost basis annotations).++Fixes++- invertAmount: with zero amounts, do nothing instead of failing.+  Previously `invertAmount` would raise a "Ratio has zero denominator"+  exception if the amount's quantity was zero. Now it's a no-op in that case.+  [#2476]++[#2476]: https://github.com/simonmichael/hledger/issues/2476++ # 1.51.2 2026-01-08  - Allow base 4.22 / ghc 9.14. - # 1.51.1 2025-12-08 - # 1.51 2025-12-05  Breaking changes@@ -40,16 +54,8 @@   quoteForCommandLine now quotes some additional problem characters, and no longer quotes "7".   [#2468] -API -- Hledger.Read:-  defaultExistingJournalPath-  defaultExistingJournalPathSafely-  readPossibleJournalFile--- Hledger.Utils.IO:-  expandPathOrGlob-+# 1.50.5 2025-12-08  # 1.50.4 2025-12-04 

@@ -30,6 +30,7 @@   ,equityAccountRegex   ,conversionAccountRegex   ,revenueAccountRegex+  ,gainAccountRegex   ,expenseAccountRegex   ,acctsep   ,acctsepchar@@ -99,6 +100,7 @@ equityAccountRegex     = toRegexCI' "^equity(:|$)" conversionAccountRegex = toRegexCI' "^equity:(trade|trades|trading|conversion)(:|$)" revenueAccountRegex    = toRegexCI' "^(income|revenue)s?(:|$)"+gainAccountRegex       = toRegexCI' "^(income|revenue)s?:(capital[- ]?)?(gains?|loss(es)?)(:|$)" expenseAccountRegex    = toRegexCI' "^expenses?(:|$)"  -- | Try to guess an account's type from its name,@@ -110,6 +112,7 @@   | regexMatchText liabilityAccountRegex  a = Just Liability   | regexMatchText conversionAccountRegex a = Just Conversion   | regexMatchText equityAccountRegex     a = Just Equity+  | regexMatchText gainAccountRegex       a = Just Gain   | regexMatchText revenueAccountRegex    a = Just Revenue   | regexMatchText expenseAccountRegex    a = Just Expense   | otherwise                               = Nothing@@ -447,6 +450,13 @@     accountNameInferType "revenues"          @?= Just Revenue     accountNameInferType "revenue"           @?= Just Revenue     accountNameInferType "income"            @?= Just Revenue+    accountNameInferType "income:gains"          @?= Just Gain+    accountNameInferType "revenue:gain"          @?= Just Gain+    accountNameInferType "revenues:capital-gains" @?= Just Gain+    accountNameInferType "income:capitalgain"    @?= Just Gain+    accountNameInferType "income:losses"         @?= Just Gain+    accountNameInferType "revenue:capital-loss"  @?= Just Gain+    accountNameInferType "income:gains:realized" @?= Just Gain   ,testCase "joinAccountNames" $ do     joinAccountNames "assets" "cash"     @?= "assets:cash"     joinAccountNames "assets:cash" "a"   @?= "assets:cash:a"

@@ -94,6 +94,8 @@   showAmountB,   showAmountCost,   showAmountCostB,+  showAmountCostBasis,+  showAmountCostBasisB,   cshowAmount,   showAmountWithZeroCommodity,   showAmountDebug,@@ -247,6 +249,7 @@   , displayMinWidth         :: Maybe Int  -- ^ Minimum width to pad to   , displayMaxWidth         :: Maybe Int  -- ^ Maximum width to clip to   , displayCost             :: Bool       -- ^ Whether to display Amounts' costs.+  , displayCostBasis        :: Bool       -- ^ Whether to display Amounts' cost basis (Ledger-style lot syntax).   , displayColour           :: Bool       -- ^ Whether to ansi-colourise negative Amounts.   , displayQuotes           :: Bool       -- ^ Whether to enclose complex symbols in quotes (normally true)   } deriving (Show)@@ -266,6 +269,7 @@   , displayMinWidth         = Just 0   , displayMaxWidth         = Nothing   , displayCost             = True+  , displayCostBasis        = True   , displayColour           = False   , displayQuotes           = True   }@@ -274,9 +278,9 @@ fullZeroFmt :: AmountFormat fullZeroFmt = defaultFmt{displayZeroCommodity=True} --- | Like defaultFmt but don't show costs.+-- | Like defaultFmt but don't show costs or cost basis. noCostFmt :: AmountFormat-noCostFmt = defaultFmt{displayCost=False}+noCostFmt = defaultFmt{displayCost=False, displayCostBasis=False}  -- | Like defaultFmt but display all amounts on one line. oneLineFmt :: AmountFormat@@ -305,7 +309,7 @@ -- | The empty simple amount - a zero with no commodity symbol or cost -- and the default amount display style. nullamt :: Amount-nullamt = Amount{acommodity="", aquantity=0, acost=Nothing, astyle=amountstyle}+nullamt = Amount{acommodity="", aquantity=0, astyle=amountstyle, acost=Nothing, acostbasis=Nothing}  -- | A special amount used as a marker, meaning -- "no explicit amount provided here, infer it when needed".@@ -381,8 +385,10 @@ multiplyAmount n = transformAmount (*n)  -- | Invert an amount (replace its quantity q with 1/q).--- (Its cost if any is not changed, currently.)+-- The amount's transacted price, if any, is not changed.+-- An amount with zero quantity is left unchanged. invertAmount :: Amount -> Amount+invertAmount a@Amount{aquantity=0} = a invertAmount a@Amount{aquantity=q} = a{aquantity=1/q}  -- | Is this amount negative ? The cost is ignored.@@ -716,11 +722,11 @@ showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB   afmt@AmountFormat{displayCommodity, displayZeroCommodity, displayDigitGroups-                   ,displayForceDecimalMark, displayCost, displayColour, displayQuotes}+                   ,displayForceDecimalMark, displayCost, displayCostBasis, displayColour, displayQuotes}   a@Amount{astyle=style} =     color $ case ascommodityside style of-      L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> cost-      R -> quantity' <> (if displayCommodity then space <> wbFromText comm else mempty) <> cost+      L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> cost <> costbasis+      R -> quantity' <> (if displayCommodity then space <> wbFromText comm else mempty) <> cost <> costbasis   where     color = if displayColour && isNegativeAmount a then colorB Dull Red else id     quantity = showAmountQuantity displayForceDecimalMark $@@ -730,6 +736,7 @@       | otherwise = (quantity, (if displayQuotes then quoteCommoditySymbolIfNeeded else id) $ acommodity a)     space = if not (T.null comm) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty     cost = if displayCost then showAmountCostB afmt a else mempty+    costbasis = if displayCostBasis then showAmountCostBasisB afmt a else mempty  -- Show an amount's cost as @ UNITCOST or @@ TOTALCOST, plus a leading space, or "" if there's no cost. showAmountCost :: Amount -> String@@ -747,6 +754,27 @@ showAmountCostDebug Nothing                = "" showAmountCostDebug (Just (UnitCost pa))  = "@ "  ++ showAmountDebug pa showAmountCostDebug (Just (TotalCost pa)) = "@@ " ++ showAmountDebug pa++-- | Show an amount's cost basis as Ledger-style lot syntax: {LOTCOST} [LOTDATE] (LOTNOTE).+showAmountCostBasis :: Amount -> String+showAmountCostBasis = wbUnpack . showAmountCostBasisB defaultFmt++-- showAmountCostBasis, efficient builder version.+showAmountCostBasisB :: AmountFormat -> Amount -> WideBuilder+showAmountCostBasisB afmt amt = case acostbasis amt of+  Nothing -> mempty+  Just CostBasis{cbCost, cbDate, cbLabel} ->+    lotcost <> lotdate <> lotnote+    where+      lotcost = case cbCost of+        Nothing -> mempty+        Just a  -> WideBuilder (TB.fromString " {") 2 <> showAmountB afmt a <> WideBuilder (TB.singleton '}') 1+      lotdate = case cbDate of+        Nothing -> mempty+        Just d  -> WideBuilder (TB.fromString " [") 2 <> wbFromText (T.pack $ show d) <> WideBuilder (TB.singleton ']') 1+      lotnote = case cbLabel of+        Nothing -> mempty+        Just l  -> WideBuilder (TB.fromString " (") 2 <> wbFromText l <> WideBuilder (TB.singleton ')') 1  -- | Colour version. For a negative amount, adds ANSI codes to change the colour, -- currently to hard-coded red.

@@ -436,6 +436,12 @@           span' (SmartRelative n Month)       = (Flex $ addGregorianMonthsClip n d, Flex $ addGregorianMonthsClip (n+1) d) where d = thismonth refdate           span' (SmartRelative n Quarter)     = (Flex $ addGregorianMonthsClip (3*n) d, Flex $ addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate           span' (SmartRelative n Year)        = (Flex $ addGregorianYearsClip n d, Flex $ addGregorianYearsClip (n+1) d) where d = thisyear refdate+          span' (SmartRelativeMonth   LT m)   = (Flex d, Flex $ nextmonth d) where d = prevnamedmonth m refdate+          span' (SmartRelativeMonth   EQ m)   = (Flex d, Flex $ nextmonth d) where d = thisnamedmonth m refdate+          span' (SmartRelativeMonth   GT m)   = (Flex d, Flex $ nextmonth d) where d = nextnamedmonth m refdate+          span' (SmartRelativeWeekDay LT wd)  = (Exact d, Exact $ nextday d) where d = prevnamedweekday wd refdate+          span' (SmartRelativeWeekDay EQ wd)  = (Exact d, Exact $ nextday d) where d = thisnamedweekday wd refdate+          span' (SmartRelativeWeekDay GT wd)  = (Exact d, Exact $ nextday d) where d = nextnamedweekday wd refdate  -- showDay :: Day -> String -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day@@ -524,12 +530,25 @@ -- >>> t "next year" -- "2009-01-01" ----- t "last wed"+-- refdate is Wednesday, 2008-11-26+-- >>> t "last wednesday" -- "2008-11-19"--- t "next friday"--- "2008-11-28"--- t "next january"+-- >>> t "this wednesday"+-- "2008-12-03"+-- >>> t "next wednesday"+-- "2008-12-03"+-- >>> t "last january"+-- "2008-01-01"+-- >>> t "this january" -- "2009-01-01"+-- >>> t "next january"+-- "2009-01-01"+-- >>> t "last november"+-- "2007-11-01"+-- >>> t "this november"+-- "2009-11-01"+-- >>> t "next november"+-- "2009-11-01" -- -- >>> t "in 5 days" -- "2008-12-01"@@ -554,6 +573,12 @@     fix (SmartRelative n Month)   = Flex  $ addGregorianMonthsClip n $ thismonth refdate     fix (SmartRelative n Quarter) = Flex  $ addGregorianMonthsClip (3*n) $ thisquarter refdate     fix (SmartRelative n Year)    = Flex  $ addGregorianYearsClip n $ thisyear refdate+    fix (SmartRelativeMonth LT m)    = Flex $ prevnamedmonth m refdate+    fix (SmartRelativeMonth EQ m)    = Flex $ thisnamedmonth m refdate+    fix (SmartRelativeMonth GT m)    = Flex $ nextnamedmonth m refdate+    fix (SmartRelativeWeekDay LT wd) = Exact $ prevnamedweekday wd refdate+    fix (SmartRelativeWeekDay EQ wd) = Exact $ thisnamedweekday wd refdate+    fix (SmartRelativeWeekDay GT wd) = Exact $ nextnamedweekday wd refdate     (ry, rm, _) = toGregorian refdate  prevday :: Day -> Day@@ -574,6 +599,36 @@ startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day nthdayofmonth d day = fromGregorian y m d where (y,m,_) = toGregorian day +prevnamedmonth :: Month -> Day -> Day+prevnamedmonth targetmonth refdate = fromGregorian y' targetmonth 1+  where+    (y, m, _) = toGregorian refdate+    y' = if targetmonth < m then y else y - 1++nextnamedmonth :: Month -> Day -> Day+nextnamedmonth targetmonth refdate = fromGregorian y' targetmonth 1+  where+    (y, m, _) = toGregorian refdate+    y' = if targetmonth > m then y else y + 1++thisnamedmonth :: Month -> Day -> Day+thisnamedmonth = nextnamedmonth  -- "this" and "next" both mean next occurrence after current month++prevnamedweekday :: WeekDay -> Day -> Day+prevnamedweekday targetwd refdate = addDays (negate $ fromIntegral daysback) refdate+  where+    (_, curwd) = mondayStartWeek refdate+    daysback = 1 + (curwd - targetwd - 1) `mod` 7++nextnamedweekday :: WeekDay -> Day -> Day+nextnamedweekday targetwd refdate = addDays (fromIntegral daysforward) refdate+  where+    (_, curwd) = mondayStartWeek refdate+    daysforward = 1 + (targetwd - curwd - 1) `mod` 7++thisnamedweekday :: WeekDay -> Day -> Day+thisnamedweekday = nextnamedweekday  -- "this" and "next" both mean next occurrence after today+ thisquarter = startofquarter startofquarter day = fromGregorian y (firstmonthofquarter m) 1     where@@ -780,6 +835,8 @@ > october, oct                                (start of month in current year) > yesterday, today, tomorrow                  (-1, 0, 1 days from today) > last/this/next day/week/month/quarter/year  (-1, 0, 1 periods from the current period)+> last/this/next monday/mon                   (the previous or next named weekday; this=next)+> last/next january/jan                       (previous or next start of named month; this disallowed to avoid confusion) > in n days/weeks/months/quarters/years       (n periods from the current period) > n days/weeks/months/quarters/years ago      (-n periods from the current period) > 20181201                                    (8 digit YYYYMMDD with valid year month and day)@@ -819,27 +876,39 @@ smartdate :: TextParser m SmartDate smartdate = choice'   -- XXX maybe obscures date errors ? see ledgerdate-    [ relativeP+    [ relativeinterval+    , relativemonth+    , relativeweekday     , yyyymmdd     , ymd     , (\(m,d) -> SmartFromReference (Just m) d) <$> md     , failIfInvalidDate . SmartFromReference Nothing =<< decimal     , SmartMonth <$> (month <|> mon)-    , SmartRelative 0    Day <$ string' "today"     , SmartRelative (-1) Day <$ string' "yesterday"+    , SmartRelative 0    Day <$ string' "today"     , SmartRelative 1    Day <$ string' "tomorrow"     ]   where-    relativeP = do+    relativeinterval = do         optional $ string' "in" <* skipNonNewlineSpaces-        num      <- seqP <* skipNonNewlineSpaces-        interval <- intervalP <* skipNonNewlineSpaces+        num      <- relativenump <* skipNonNewlineSpaces+        interval <- intervalp <* skipNonNewlineSpaces         sign     <- choice [negate <$ string' "ago", id <$ string' "ahead", pure id]         return $ SmartRelative (sign num) interval--    seqP = choice [ 0 <$ string' "this", -1 <$ string' "last", 1 <$ string' "next", signed skipNonNewlineSpaces decimal ]-    intervalP = choice [ Day <$ string' "day", Week <$ string' "week", Month <$ string' "month"-                       , Quarter <$ string' "quarter", Year <$ string' "year" ] <* optional (char' 's')+        where+          relativenump = choice [ 0 <$ string' "this", -1 <$ string' "last", 1 <$ string' "next", signed skipNonNewlineSpaces decimal ]+          intervalp    = choice [ Day <$ string' "day", Week <$ string' "week", Month <$ string' "month"+                                , Quarter <$ string' "quarter", Year <$ string' "year" ] <* optional (char' 's')+    relativemonth = do+      dir <- choice [LT <$ string' "last", EQ <$ string' "this", GT <$ string' "next"]+      skipNonNewlineSpaces+      m <- (month <|> mon)+      return $ SmartRelativeMonth dir m+    relativeweekday = do+      dir <- choice [LT <$ string' "last", EQ <$ string' "this", GT <$ string' "next"]+      skipNonNewlineSpaces+      w <- weekday+      return $ SmartRelativeWeekDay dir w  -- | Like smartdate, but there must be nothing other than whitespace after the date. smartdateonly :: TextParser m SmartDate

@@ -35,7 +35,10 @@   journalSetLastReadTime,   journalRenumberAccountDeclarations,   journalPivot,-  -- * Filtering+  journalPostingsAddAccountTags,+  journalPostingsKeepAccountTagsOnly,+  journalPostingsAddCommodityTags,+-- * Filtering   filterJournalTransactions,   filterJournalPostings,   filterJournalRelatedPostings,@@ -59,6 +62,7 @@   journalLeafAccountNames,   journalAccountNameTree,   journalAccountTags,+  journalCommodityTags,   journalInheritedAccountTags,   -- journalAmountAndPriceCommodities,   -- journalAmountStyles,@@ -97,10 +101,8 @@   journalAccountType,   journalAccountTypes,   journalAddAccountTypes,-  journalPostingsAddAccountTags,-  journalPostingsKeepAccountTagsOnly,+  -- * Conversion accounts   defaultBaseConversionAccount,-  -- journalPrices,   journalBaseConversionAccount,   journalConversionAccounts,   -- * Misc@@ -284,6 +286,9 @@     -- ,jdeclaredcommodities           :: M.Map CommoditySymbol Commodity     ,jdeclaredcommodities               = (<>) (jdeclaredcommodities j1) (jdeclaredcommodities j2)     --+    -- ,jdeclaredcommoditytags     :: M.Map CommoditySymbol [Tag]+    ,jdeclaredcommoditytags     = M.unionWith (<>) (jdeclaredcommoditytags j1) (jdeclaredcommoditytags j2)+    --     -- ,jinferredcommoditystyles   :: M.Map CommoditySymbol AmountStyle     ,jinferredcommoditystyles       = (<>) (jinferredcommoditystyles j1) (jinferredcommoditystyles j2)     --@@ -345,8 +350,9 @@   ,jdeclaredaccounttypes      = M.empty   ,jaccounttypes              = M.empty   ,jglobalcommoditystyles     = M.empty-  ,jdeclaredcommodities               = M.empty-  ,jinferredcommoditystyles       = M.empty+  ,jdeclaredcommodities       = M.empty+  ,jdeclaredcommoditytags     = M.empty+  ,jinferredcommoditystyles   = M.empty   ,jpricedirectives           = []   ,jinferredmarketprices      = []   ,jtxnmodifiers              = []@@ -638,10 +644,22 @@  -- | To all postings in the journal, add any tags from their account -- (including those inherited from parent accounts).--- If the same tag exists on posting and account, the latter is ignored.+-- If a tag already exists on the posting, it is not changed (the account tag will be ignored). journalPostingsAddAccountTags :: Journal -> Journal journalPostingsAddAccountTags j = journalMapPostings addtags j   where addtags p = p `postingAddTags` (journalInheritedAccountTags j $ paccount p)++-- | Get any tags declared for this commodity.+journalCommodityTags :: Journal -> CommoditySymbol -> [Tag]+journalCommodityTags Journal{jdeclaredcommoditytags} c =+  M.findWithDefault [] c jdeclaredcommoditytags++-- | To all postings in the journal, add any tags from their amount's commodities.+-- If a tag already exists on the posting, it is not changed (the commodity tag will be ignored).+journalPostingsAddCommodityTags :: Journal -> Journal+journalPostingsAddCommodityTags j = journalMapPostings addtags j+  where+    addtags p = p `postingAddTags` concatMap (journalCommodityTags j) (postingCommodities p)  -- | Remove all tags from the journal's postings except those provided by their account. -- This is useful for the accounts report.

@@ -83,6 +83,7 @@     , "floatingPoint"   .= (realToFrac d' :: Double)     ] +instance ToJSON CostBasis instance ToJSON Amount instance ToJSON Rounding instance ToJSON AmountStyle@@ -200,6 +201,7 @@ instance FromJSON Pos where   parseJSON = fmap mkPos . parseJSON +instance FromJSON CostBasis instance FromJSON Amount instance FromJSON Rounding instance FromJSON AmountStyle

@@ -78,6 +78,7 @@   postingToCost,   postingAddInferredEquityPostings,   postingPriceDirectivesFromCost,+  postingCommodities,   tests_Posting ) where@@ -429,6 +430,11 @@     Unmarked -> maybe Unmarked tstatus mt     _ -> s +-- | Get the commodity symbols used in a posting's amounts (not including costs).+postingCommodities :: Posting -> [CommoditySymbol]+postingCommodities = map acommodity . filter (not . isMissingAmount) . amountsRaw . pamount+  where isMissingAmount a = acommodity a == "AUTO"+ -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] postingAllTags p = ptags p ++ maybe [] ttags (ptransaction p)@@ -466,7 +472,7 @@ -- If the posting already has these tags (with any value), do nothing. postingAddHiddenAndMaybeVisibleTag :: Bool -> HiddenTag -> Posting -> Posting postingAddHiddenAndMaybeVisibleTag verbosetags ht p@Posting{pcomment=c, ptags} =-  (p `postingAddTags` ([ht] <> [vt|verbosetags]))+  (p `postingAddTags` ([ht] <> [vt |verbosetags]))   {pcomment=if verbosetags && not hadtag then c `commentAddTag` vt else c}   where     vt@(vname,_) = toVisibleTag ht@@ -516,7 +522,7 @@         cost = amountCost amt         amtCommodity  = commodity amt         costCommodity = commodity cost-        convp = p{pbalanceassertion=Nothing, poriginal=Nothing}+        convp = nullposting{pdate=pdate p, pdate2=pdate2 p, pstatus=pstatus p, ptransaction=ptransaction p}           & postingAddHiddenAndMaybeVisibleTag verbosetags (conversionPostingTagName,"")           & postingAddHiddenAndMaybeVisibleTag verbosetags (generatedPostingTagName, "")         accountPrefix = mconcat [ equityAcct, ":", T.intercalate "-" $ sort [amtCommodity, costCommodity], ":"]

@@ -84,15 +84,23 @@ -- wildcard (so it would mean all days of that month). See the `smartdate` -- parser for more examples. ----- Or, one of the standard periods and an offset relative to the reference date:+-- Or, one of the standard periods and a numeric offset relative to the reference date: -- (last|this|next) (day|week|month|quarter|year), where "this" means the period -- containing the reference date.+--+-- Or, (last|this|next) weekdayname, where "this" "next".+--+-- Or, (last|this|next) monthname, where "this" means the previous 1st if in that month,+-- otherwise the start of the next occurrence of that month.+-- data SmartDate   = SmartCompleteDate Day   | SmartAssumeStart Year (Maybe Month)         -- XXX improve these constructor names   | SmartFromReference (Maybe Month) MonthDay   --   | SmartMonth Month   | SmartRelative Integer SmartInterval+  | SmartRelativeMonth Ordering Month           -- ^ EQ will be treated like GT+  | SmartRelativeWeekDay Ordering WeekDay   deriving (Show)  data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show)@@ -181,6 +189,7 @@   | Expense   | Cash  -- ^ a subtype of Asset - liquid assets to show in cashflow report   | Conversion -- ^ a subtype of Equity - account with which to balance commodity conversions+  | Gain      -- ^ a subtype of Revenue - capital gains/losses   deriving (Eq,Ord,Generic)  instance Show AccountType where@@ -191,6 +200,7 @@   show Expense    = "X"   show Cash       = "C"   show Conversion = "V"+  show Gain       = "G"  isBalanceSheetAccountType :: AccountType -> Bool isBalanceSheetAccountType t = t `elem` [@@ -204,7 +214,8 @@ isIncomeStatementAccountType :: AccountType -> Bool isIncomeStatementAccountType t = t `elem` [   Revenue,-  Expense+  Expense,+  Gain   ]  -- | Check whether the first argument is a subtype of the second: either equal@@ -219,6 +230,8 @@ isAccountSubtypeOf Cash       Asset      = True isAccountSubtypeOf Conversion Conversion = True isAccountSubtypeOf Conversion Equity     = True+isAccountSubtypeOf Gain       Gain       = True+isAccountSubtypeOf Gain       Revenue    = True isAccountSubtypeOf _          _          = False  -- not worth the trouble, letters defined in accountdirectivep for now@@ -321,16 +334,29 @@ type CommoditySymbol = Text  data Commodity = Commodity {-  csymbol :: CommoditySymbol,-  cformat :: Maybe AmountStyle+  csymbol  :: CommoditySymbol,+  cformat  :: Maybe AmountStyle,+  ccomment :: Text,              -- ^ any comment lines following the commodity directive+  ctags    :: [Tag]              -- ^ tags extracted from the comment, if any   } deriving (Show,Eq,Generic) --,Ord) +-- | The cost basis of an individual lot - some quantity of an asset acquired at a given date and time.+-- This can represent a definite cost basis, which must have a cost and date; the label is optional.+-- Or it can represent a cost basis matcher for selecting lots.+-- Note: cost is always stored as a per-unit cost, even if the user specified total cost with {{}}.+data CostBasis = CostBasis {+  cbCost  :: !(Maybe Amount),    -- ^ nominal acquisition cost (per-unit)+  cbDate  :: !(Maybe Day),       -- ^ nominal acquisition date+  cbLabel :: !(Maybe Text)       -- ^ a short label to ensure uniqueness, correct intra-day order, or memorability, if needed+} deriving (Show,Eq,Generic,Ord)+ data Amount = Amount {-      acommodity  :: !CommoditySymbol,     -- commodity symbol, or special value "AUTO"-      aquantity   :: !Quantity,            -- numeric quantity, or zero in case of "AUTO"-      astyle      :: !AmountStyle,-      acost       :: !(Maybe AmountCost)  -- ^ the (fixed, transaction-specific) cost in another commodity of this amount, if any-    } deriving (Eq,Ord,Generic,Show)+  acommodity  :: !CommoditySymbol,     -- commodity symbol, or special value "AUTO"+  aquantity   :: !Quantity,            -- numeric quantity, or zero in case of "AUTO"+  astyle      :: !AmountStyle,+  acost       :: !(Maybe AmountCost),    -- ^ transacted exchange rate - the unit or total cost, in another commodity, used for this amount within its transaction+  acostbasis  :: !(Maybe CostBasis)    -- ^ the cost basis of an investment lot represented by this amount. Or, a matcher to select such a lot from the available lots.+} deriving (Eq,Ord,Generic,Show)  -- | Types with this class have one or more amounts, -- which can have display styles applied to them.@@ -642,6 +668,7 @@   ,jdeclaredaccounttypes    :: M.Map AccountType [AccountName]        -- ^ Accounts which were declared with a type: tag, grouped by the type.   ,jaccounttypes            :: M.Map AccountName AccountType          -- ^ All the account types known, from account declarations or account names or parent accounts.   ,jdeclaredcommodities     :: M.Map CommoditySymbol Commodity        -- ^ Commodities (and their display styles) declared by commodity directives, in parse order.+  ,jdeclaredcommoditytags   :: M.Map CommoditySymbol [Tag]            -- ^ Commodities which were declared with tags, and those tags.   ,jinferredcommoditystyles :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles inferred from amounts in the journal.   ,jglobalcommoditystyles   :: M.Map CommoditySymbol AmountStyle      -- ^ Commodity display styles declared by command line options (sometimes augmented, see the import command).   ,jpricedirectives         :: [PriceDirective]                       -- ^ P (market price) directives in the journal, in parse order.@@ -794,6 +821,7 @@ instance NFData AmountStyle instance NFData BalanceAssertion instance NFData Commodity+instance NFData CostBasis instance NFData DateSpan instance NFData DigitGroupStyle instance NFData EFDay

@@ -32,13 +32,13 @@ where  import Control.Applicative ((<|>))-import Data.Function ((&), on)+import Data.Function ((&)) import Data.List (partition, intercalate, sortBy)-import Data.List.Extra (nubSortBy) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T import Data.Time.Calendar (Day, fromGregorian)+import Data.Maybe (fromMaybe, mapMaybe) import Data.MemoUgly (memo) import GHC.Generics (Generic) import Safe (headMay, lastMay)@@ -84,6 +84,92 @@ -- given date. type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity) +-- | An index of market prices for efficient lookup by commodity pair and date.+-- Maps each (from, to) commodity pair to a Map from date to the effective price,+-- where declared prices take precedence over inferred prices on the same day.+-- This allows O(log n) lookup per pair via M.lookupLE.+type PriceIndex = M.Map (CommoditySymbol, CommoditySymbol) (M.Map Day MarketPrice)++-- | Build a price index from declared and inferred market prices.+-- This is O(n log n) but done only once, enabling fast lookups later.+buildPriceIndex :: [MarketPrice] -> [MarketPrice] -> PriceIndex+buildPriceIndex declaredprices inferredprices =+  let+    -- Label each price with precedence (declared=True > inferred=False) and parse order+    declaredprices' = [(mpdate p, True, i, p) | (i, p) <- zip [1..] declaredprices]+    inferredprices' = [(mpdate p, False, i, p) | (i, p) <- zip [1..] inferredprices]+    allprices = declaredprices' ++ inferredprices'+    -- Group by commodity pair+    grouped = M.fromListWith (++)+      [((mpfrom p, mpto p), [(d, prec, order, p)]) | (d, prec, order, p) <- allprices]+    -- Build inner Map: sort ascending by (date, prec, order), then M.fromList+    -- keeps the last entry per date (highest precedence/parseorder wins)+    buildInnerMap prices =+      prices+      & sortBy compare+      & map (\(d, _, _, p) -> (d, p))+      & M.fromList+  in+    M.map buildInnerMap grouped++-- | Look up effective prices for all commodity pairs at a given date using the index.+-- Returns at most one price per commodity pair: the latest price on or before the date.+-- O(pairs × log n) where n is the number of prices per pair.+lookupEffectivePricesFromIndex :: Day -> PriceIndex -> [MarketPrice]+lookupEffectivePricesFromIndex d idx =+  mapMaybe (fmap snd . M.lookupLE d) (M.elems idx)++-- | Index for default valuation commodity lookup.+-- Maps source commodity to a map of (date -> destination), supporting O(log n) lookup+-- of the latest destination commodity on or before any given date.+type DefaultValuationIndex = M.Map CommoditySymbol (M.Map Day CommoditySymbol)++-- | Build an index for default valuation commodity lookup from a list of market prices.+buildDefaultValuationIndex :: [MarketPrice] -> DefaultValuationIndex+buildDefaultValuationIndex prices =+  let+    -- Label with parse order+    labeled = [(mpfrom p, mpdate p, i, mpto p) | (i, p) <- zip [1..] prices]+    -- Group by source commodity+    grouped = M.fromListWith (++) [(from, [(d, ord, to)]) | (from, d, ord, to) <- labeled]+    -- Build inner Map: sort by (date, parseorder), then M.fromList keeps last (highest parseorder per date)+    buildInnerMap entries = M.fromList [(d, to) | (d, _, to) <- sortBy compare entries]+  in+    M.map buildInnerMap grouped++-- | Combined indexes for efficient price lookup.+data PriceIndexes = PriceIndexes+  { piForward :: !PriceIndex                    -- ^ Index for forward prices (declared + inferred)+  , piDeclaredDefault :: !DefaultValuationIndex -- ^ Index for declared prices (for default valuation)+  , piInferredDefault :: !DefaultValuationIndex -- ^ Index for inferred prices (fallback for default valuation)+  }++-- | Build all price indexes from declared and inferred market prices.+-- This is O(n log n) but done only once.+buildPriceIndexes :: [MarketPrice] -> [MarketPrice] -> PriceIndexes+buildPriceIndexes declaredprices inferredprices = PriceIndexes+  { piForward = buildPriceIndex declaredprices inferredprices+  , piDeclaredDefault = buildDefaultValuationIndex declaredprices+  , piInferredDefault = buildDefaultValuationIndex inferredprices+  }++-- | Look up default valuation commodities for all source commodities at a given date.+-- Fallback logic: declared at date d, then declared at any date, then inferred at date d.+lookupDefaultValuations :: Day -> PriceIndexes -> M.Map CommoditySymbol CommoditySymbol+lookupDefaultValuations d PriceIndexes{..} =+    fromMaybe fallback (tryDeclaredAtDate <|> tryDeclaredLatest)+  where+    nonEmpty m = if M.null m then Nothing else Just m++    tryDeclaredAtDate = nonEmpty $ lookupDefaults (Just d) piDeclaredDefault+    tryDeclaredLatest = nonEmpty $ lookupDefaults Nothing  piDeclaredDefault+    fallback          = lookupDefaults (Just d) piInferredDefault++    lookupDefaults mdate = M.mapMaybe $ \innerMap ->+      case mdate of+        Nothing -> snd <$> M.lookupMax innerMap+        Just dt -> snd <$> M.lookupLE dt innerMap+ -- | Generate a price oracle (memoising price lookup function) from a -- journal's directive-declared and transaction-inferred market -- prices. For best performance, generate this only once per journal,@@ -98,7 +184,9 @@     inferredprices =       (if infer then jinferredmarketprices else [])       & dbg2Msg ("use prices inferred from costs? " <> if infer then "yes" else "no")-    makepricegraph = memo $ makePriceGraph declaredprices inferredprices+    -- Build indexes once for all lookups+    indexes = buildPriceIndexes declaredprices inferredprices+    makepricegraph = memo $ makePriceGraph indexes   in     memo $ uncurry3 $ priceLookup makepricegraph @@ -318,7 +406,7 @@       ,p 2000 01 01 "E"  2 "D"       ,p 2001 01 01 "A" 11 "B"       ]-    makepricegraph = makePriceGraph ps1 []+    makepricegraph = makePriceGraph (buildPriceIndexes ps1 [])   in testCase "priceLookup" $ do     priceLookup makepricegraph (fromGregorian 1999 01 01) "A" Nothing    @?= Nothing     priceLookup makepricegraph (fromGregorian 2000 01 01) "A" Nothing    @?= Just ("B",10)@@ -466,8 +554,9 @@ --    the `--infer-market-prices` flag is used, then the price commodity from --    the latest transaction price for A on or before valuation date." ---makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph-makePriceGraph alldeclaredprices allinferredprices d =+-- | Build the price graph using pre-built indexes for O(pairs × log n) lookup.+makePriceGraph :: PriceIndexes -> Day -> PriceGraph+makePriceGraph indexes d =   dbg9 ("makePriceGraph "++show d) $   PriceGraph{      pgDate = d@@ -478,10 +567,9 @@   where     -- XXX logic duplicated in Hledger.Cli.Commands.Prices.prices, keep synced -    -- prices in effect on date d, either declared or inferred-    visibledeclaredprices = dbg9 "visibledeclaredprices" $ filter ((<=d).mpdate) alldeclaredprices-    visibleinferredprices = dbg9 "visibleinferredprices" $ filter ((<=d).mpdate) allinferredprices-    forwardprices = effectiveMarketPrices visibledeclaredprices visibleinferredprices+    -- get the latest effective price for each commodity pair on or before date d+    forwardprices = dbg9 "effective forward prices" $+      lookupEffectivePricesFromIndex d (piForward indexes)      -- infer any additional reverse prices not already declared or inferred     reverseprices = dbg9 "additional reverse prices" $@@ -492,42 +580,9 @@         forwardpairs = S.fromList [(mpfrom,mpto) | MarketPrice{..} <- forwardprices]     allprices = forwardprices ++ reverseprices -    -- determine a default valuation commodity for each source commodity-    -- somewhat but not quite like effectiveMarketPrices-    defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- pricesfordefaultcomms]-      where-        pricesfordefaultcomms = dbg9 "prices for choosing default valuation commodities, by date then parse order" $-          ps-          & zip [1..]  -- label items with their parse order-          & sortBy (compare `on` (\(parseorder,MarketPrice{..})->(mpdate,parseorder)))  -- sort by increasing date then increasing parse order-          & map snd    -- discard labels-          where-            ps | not $ null visibledeclaredprices = visibledeclaredprices-               | not $ null alldeclaredprices     = alldeclaredprices-               | otherwise                        = visibleinferredprices  -- will be null without --infer-market-prices---- | Given a list of P-declared market prices in parse order and a--- list of transaction-inferred market prices in parse order, select--- just the latest prices that are in effect for each commodity pair.--- That is, for each commodity pair, the latest price by date then--- parse order, with declared prices having precedence over inferred--- prices on the same day.-effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice]-effectiveMarketPrices declaredprices inferredprices =-  let-    -- label each item with its same-day precedence, then parse order-    declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices]-    inferredprices' = [(0, i, p) | (i,p) <- zip [1..] inferredprices]-  in-    dbg9 "effective forward prices" $-    -- combine-    declaredprices' ++ inferredprices'-    -- sort by decreasing date then decreasing precedence then decreasing parse order-    & sortBy (flip compare `on` (\(precedence,parseorder,mp)->(mpdate mp,precedence,parseorder)))-    -- discard the sorting labels-    & map third3-    -- keep only the first (ie the newest, highest precedence, latest parsed) price for each pair-    & nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto)))+    -- use indexed lookup for default valuation commodities+    defaultdests = dbg9 "default valuation commodities" $+      lookupDefaultValuations d indexes  marketPriceReverse :: MarketPrice -> MarketPrice marketPriceReverse mp@MarketPrice{..} = 

@@ -152,6 +152,7 @@ -- | A query option changes a query's/report's behaviour and output in some way. data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account               | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register+              | QueryOptInterval Interval       -- ^ report interval extracted from a date: query            -- | QueryOptCostBasis      -- ^ show amounts converted to cost where possible            -- | QueryOptDate2  -- ^ show secondary dates instead of primary dates     deriving (Show, Eq)@@ -302,11 +303,12 @@ parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = (,[]) <$> noteTag (Just s) parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = (,[]) . Acct <$> toRegexCI s parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =-        case parsePeriodExpr d s of Left e         -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,spn) -> Right (Date2 spn, [])+        case parsePeriodExpr d s of Left e                   -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e+                                    Right (_         , spn)  -> Right (Date2 spn, []) parseQueryTerm d (T.stripPrefix "date:" -> Just s) =-        case parsePeriodExpr d s of Left e         -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e-                                    Right (_,spn) -> Right (Date spn, [])+        case parsePeriodExpr d s of Left e                   -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e+                                    Right (NoInterval, spn)  -> Right (Date spn, [])+                                    Right (interval  , spn)  -> Right (Date spn, [QueryOptInterval interval]) parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =         case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e                               Right st -> Right (StatusQ st, [])@@ -514,11 +516,11 @@     help = "type:'s argument should be one or more of " ++ accountTypeChoices False  accountTypeChoices :: Bool -> String-accountTypeChoices allowlongform = -  intercalate ", " +accountTypeChoices allowlongform =+  intercalate ", "     -- keep synced with parseAccountType-    $ ["A","L","E","R","X","C","V"]-    ++ if allowlongform then ["Asset","Liability","Equity","Revenue","Expense","Cash","Conversion"] else []+    $ ["A","L","E","R","X","C","V","G"]+    ++ if allowlongform then ["Asset","Liability","Equity","Revenue","Expense","Cash","Conversion","Gain"] else []  -- | Case-insensitively parse one single-letter code, or one long-form word if permitted, to an account type. -- On failure, returns the unparseable text.@@ -533,6 +535,7 @@     "x"                          -> Right Expense     "c"                          -> Right Cash     "v"                          -> Right Conversion+    "g"                          -> Right Gain     "asset"      | allowlongform -> Right Asset     "liability"  | allowlongform -> Right Liability     "equity"     | allowlongform -> Right Equity@@ -540,6 +543,7 @@     "expense"    | allowlongform -> Right Expense     "cash"       | allowlongform -> Right Cash     "conversion" | allowlongform -> Right Conversion+    "gains"      | allowlongform -> Right Gain     _                            -> Left $ T.unpack s  -- | Parse the value part of a "status:" query, or return an error.@@ -799,6 +803,7 @@ inAccount [] = Nothing inAccount (QueryOptInAcctOnly a:_) = Just (a,False) inAccount (QueryOptInAcct a:_) = Just (a,True)+inAccount (QueryOptInterval _:rest) = inAccount rest  -- | A query for the account(s) we are currently focussed on, if any. -- Just looks at the first query option.@@ -806,6 +811,7 @@ inAccountQuery [] = Nothing inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a inAccountQuery (QueryOptInAcct a     : _) = Just . Acct $ accountNameToAccountRegex a+inAccountQuery (QueryOptInterval _   : rest) = inAccountQuery rest  -- -- | Convert a query to its inverse. -- negateQuery :: Query -> Query

@@ -106,6 +106,7 @@   readJournal,   readJournalFile,   readPossibleJournalFile,+  readPossibleJournalFiles,   readJournalFiles,   readJournalFilesAndLatestDates, @@ -142,7 +143,7 @@ import Data.Default (def) import Data.Foldable (asum) import Data.List (group, sort, sortBy)-import Data.List.NonEmpty (nonEmpty)+import Data.List.NonEmpty (nonEmpty, NonEmpty((:|))) import Data.Maybe (catMaybes, fromMaybe) import Data.Ord (comparing) import Data.Semigroup (sconcat)@@ -151,9 +152,9 @@ import Data.Text.IO qualified as T import Data.Time (Day) import Safe (headDef)-import System.Directory (doesFileExist)+import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Environment (getEnv)-import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeFileName)+import System.FilePath ((<.>), (</>), splitDirectories, splitFileName, takeDirectory, takeFileName) import System.Info (os) import System.IO (Handle, hPutStrLn, stderr) import Text.Printf (printf)@@ -341,11 +342,29 @@ readPossibleJournalFile :: InputOpts -> PrefixedFilePath -> ExceptT String IO Journal readPossibleJournalFile iopts prefixedfile = do   let (_, f) = splitReaderPrefix prefixedfile-  exists <- liftIO $ doesFileExist f-  if exists+  if f == "-"     then readJournalFile iopts prefixedfile-    else return $ nulljournal{jfiles = [(f, "")]}+    else do+      exists <- liftIO $ doesFileExist f+      if exists+        then readJournalFile iopts prefixedfile+        else return $ nulljournal{jfiles = [(f, "")]} +-- | Like readJournalFiles, but if the first file does not exist, provides an empty+-- journal with that file path set. Other files must exist as normal.+-- This is useful for commands like add and import that write to the first file,+-- which might not exist yet, while also reading other files for completions etc.+readPossibleJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal+readPossibleJournalFiles iopts pfs = case pfs of+  []     -> return nulljournal+  (f:fs) -> do+    let iopts' = iopts{_defer=True}+    j1 <- readPossibleJournalFile iopts' f+    js <- mapM (readJournalFile iopts') fs+    let combined = journalNumberTransactions $ sconcat (j1 :| js)+    when (strict_ iopts) $ liftEither $ journalStrictChecks combined+    return combined+ -- | Read a Journal from each specified file path (using @readJournalFile@) -- and combine them into one; or return the first error message. --@@ -428,6 +447,10 @@   exists <- doesFileExist f   unless exists $ do     hPutStrLn stderr $ "Creating hledger journal file " <> show f+    -- Create parent directories if they don't exist+    let dir = takeDirectory f+    unless (null dir || dir == ".") $+      createDirectoryIfMissing True dir     -- note Hledger.Utils.UTF8.* do no line ending conversion on windows,     -- we currently require unix line endings on all platforms.     newJournalContent >>= T.writeFile f

@@ -128,7 +128,7 @@  --- ** imports import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)-import Control.Monad (foldM, liftM2, when, unless, (>=>), (<=<))+import Control.Monad (foldM, join, liftM2, when, unless, (>=>), (<=<)) import Control.Monad.Fail qualified as Fail (fail) import Control.Monad.Except (ExceptT(..), liftEither, withExceptT) import Control.Monad.IO.Class (MonadIO, liftIO)@@ -209,7 +209,7 @@ -- | Parse an InputOpts from a RawOpts and a provided date. -- This will fail with a usage error if the forecast period expression cannot be parsed. rawOptsToInputOpts :: Day -> Bool -> Bool -> RawOpts -> InputOpts-rawOptsToInputOpts day usecoloronstdout postingaccttags rawopts =+rawOptsToInputOpts day usecoloronstdout autopostingtags rawopts =      let         -- Allow/disallow implicit-cost conversion transactions, according to policy in Check.md.@@ -244,7 +244,7 @@       ,new_save_          = True       ,pivot_             = stringopt "pivot" rawopts       ,forecast_          = forecastPeriodFromRawOpts day rawopts-      ,posting_account_tags_ = postingaccttags+      ,auto_posting_tags_ = autopostingtags       ,verbose_tags_      = boolopt "verbose-tags" rawopts       ,reportspan_        = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> queryEndDate False datequery)       ,auto_              = boolopt "auto" rawopts@@ -290,7 +290,7 @@     optList = listofstringopt "commodity-style" rawOpts     parseCommodity optStr = case parseamount optStr of       Left _ -> Left optStr-      Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle)+      Right (Amount acommodity _ astyle _ _) -> Right (acommodity, astyle)  transactionBalancingPrecisionFromOpts :: RawOpts -> Either String TransactionBalancingPrecision transactionBalancingPrecisionFromOpts rawopts =@@ -370,7 +370,7 @@ -- Others (commodities, accounts..) are done later by journalStrictChecks. -- journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal-journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_,strict_,posting_account_tags_,verbose_tags_,_ioDay} f txt pj = do+journalFinalise iopts@InputOpts{auto_,balancingopts_,infer_costs_,infer_equity_,strict_,auto_posting_tags_,verbose_tags_,_ioDay} f txt pj = do   let     BalancingOpts{commodity_styles_, ignore_assertions_} = balancingopts_     fname = "journalFinalise " <> takeFileName f@@ -394,7 +394,7 @@             -- XXX does not see conversion accounts generated by journalInferEquityFromCosts below, requiring a workaround in journalCheckAccounts. Do it later ?       &   journalStyleAmounts                            -- Infer and apply commodity styles (but don't round) - should be done early       <&> journalAddForecast verbose_tags_ (forecastPeriod iopts pj)   -- Add forecast transactions if enabled-      <&> (if posting_account_tags_ then journalPostingsAddAccountTags else id)     -- Propagate account tags to postings - unless printing a beancount journal+      <&> (if auto_posting_tags_ then journalPostingsAddAccountTags else id)     -- Maybe propagate account tags to postings       >>= journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ False   -- Tag equity conversion postings and redundant costs, to help journalBalanceTransactions ignore them.       >>= (if auto_ && not (null $ jtxnmodifiers pj)             then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_  -- Add auto postings if enabled, and account tags if needed. Does preliminary transaction balancing.@@ -409,6 +409,7 @@       -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalPostingAmountsDebug)       >>= journalInferCommodityStyles                    -- infer commodity styles once more now that all posting amounts are present       -- >>= Right . dbg0With (pshow.journalCommodityStyles)+      <&> (if auto_posting_tags_ then journalPostingsAddCommodityTags else id)  -- Maybe propagate commodity tags to postings (after amounts are inferred)       >>= (if infer_costs_  then journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ True else pure)  -- With --infer-costs, infer costs from equity postings where possible       <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)          -- With --infer-equity, infer equity postings from costs where possible       <&> dbg9With (lbl "amounts after equity-inferring".showJournalPostingAmountsDebug)@@ -833,18 +834,22 @@ -- if not, a commodity-less amount will have the default commodity applied to it. amountp' :: Bool -> JournalParser m Amount amountp' mult =-  -- dbg "amountp'" $ +  -- dbg "amountp'" $   label "amount" $ do   let spaces = lift $ skipNonNewlineSpaces   amt <- simpleamountp mult <* spaces-  (mcost, _valuationexpr, _mlotcost, _mlotdate, _mlotnote) <- runPermutation $+  (mcost, _valuationexpr, mlotcost, mlotdate, mlotnote) <- runPermutation $     -- costp, valuationexprp, lotnotep all parse things beginning with parenthesis, try needed     (,,,,) <$> toPermutationWithDefault Nothing (Just <$> try (costp amt) <* spaces)           <*> toPermutationWithDefault Nothing (Just <$> valuationexprp <* spaces)  -- XXX no try needed here ?-          <*> toPermutationWithDefault Nothing (Just <$> lotcostp <* spaces)+          <*> toPermutationWithDefault Nothing (Just <$> lotcostp (aquantity amt) <* spaces)           <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)           <*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces)-  pure $ amt { acost = mcost }+  let mcostbasis =+        case (mlotcost, mlotdate, mlotnote) of+          (Nothing, Nothing, Nothing) -> Nothing+          _ -> Just $ CostBasis { cbCost = join mlotcost, cbDate = mlotdate, cbLabel = mlotnote }+  pure $ amt { acost = mcost, acostbasis = mcostbasis }  -- An amount with optional cost, but no cost basis. amountnobasisp :: JournalParser m Amount@@ -1026,11 +1031,11 @@     , baposition  = sourcepos     } --- Parse a Ledger-style lot cost,--- {UNITCOST} or {{TOTALCOST}} or {=FIXEDUNITCOST} or {{=FIXEDTOTALCOST}} or {},--- and discard it.-lotcostp :: JournalParser m ()-lotcostp =+-- Parse a Ledger-style lot cost:+-- {UNITCOST} or {{TOTALCOST}} or {=FIXEDUNITCOST} or {{=FIXEDTOTALCOST}} or {}.+-- If total cost syntax {{}} is used, converts it to unit cost by dividing by the posting quantity.+lotcostp :: Quantity -> JournalParser m (Maybe Amount)+lotcostp postingqty =   -- dbg "lotcostp" $   label "ledger-style lot cost" $ do   char '{'@@ -1038,33 +1043,40 @@   lift skipNonNewlineSpaces   _fixed <- fmap isJust $ optional $ char '='   lift skipNonNewlineSpaces-  _a <- option 0 $ simpleamountp False+  ma <- optional $ simpleamountp False   lift skipNonNewlineSpaces   char '}'   when (doublebrace) $ void $ char '}'+  pure $ fmap (convertToUnitCost doublebrace) ma+  where+    -- Convert {{TOTALCOST}} to {UNITCOST} by dividing by posting quantity+    convertToUnitCost isTotal lotamt =+      if isTotal && postingqty /= 0+      then lotamt { aquantity = aquantity lotamt / postingqty }+      else lotamt --- Parse a Ledger-style [LOTDATE], and discard it.-lotdatep :: JournalParser m ()+-- Parse a Ledger-style [LOTDATE].+lotdatep :: JournalParser m Day lotdatep =   -- dbg "lotdatep" $   label "ledger-style lot date" $ do   char '['   lift skipNonNewlineSpaces-  _d <- datep+  d <- datep   lift skipNonNewlineSpaces   char ']'-  return ()+  return d --- Parse a Ledger-style (LOT NOTE), and discard it.-lotnotep :: JournalParser m ()+-- Parse a Ledger-style (LOT NOTE).+lotnotep :: JournalParser m Text lotnotep =   -- dbg "lotnotep" $   label "ledger-style lot note" $ do   char '('   lift skipNonNewlineSpaces-  _note <- stripEnd . T.pack <$> (many $ noneOf [')','\n'])  -- XXX other line endings ?+  note <- stripEnd . T.pack <$> (many $ noneOf [')','\n'])  -- XXX other line endings ?   char ')'-  return ()+  return note  -- | Parse a string representation of a number for its value and display -- attributes.

@@ -34,7 +34,7 @@     ,new_save_          :: Bool                 -- ^ save latest new transactions state for next time ?     ,pivot_             :: String               -- ^ use the given field's value as the account name     ,forecast_          :: Maybe DateSpan       -- ^ span in which to generate forecast transactions-    ,posting_account_tags_  :: Bool             -- ^ propagate account tags to postings ?+    ,auto_posting_tags_ :: Bool                 -- ^ propagate commodity and account tags to postings ? Can be disabled (for beancount export).     ,verbose_tags_      :: Bool                 -- ^ add user-visible tags when generating/modifying transactions & postings ?     ,reportspan_        :: DateSpan             -- ^ a dirty hack keeping the query dates in InputOpts. This rightfully lives in ReportSpec, but is duplicated here.     ,auto_              :: Bool                 -- ^ generate extra postings according to auto posting rules ?@@ -57,7 +57,7 @@     , new_save_          = True     , pivot_             = ""     , forecast_          = Nothing-    , posting_account_tags_ = False+    , auto_posting_tags_ = False     , verbose_tags_      = False     , reportspan_        = nulldatespan     , auto_              = False

@@ -318,12 +318,12 @@     return prefixedglob     ) <|> errorNoArg -  let (mprefix,glb) = splitReaderPrefix prefixedglob+  let (mprefix,path) = splitReaderPrefix prefixedglob   parentf <- sourcePosFilePath pos-  when (null $ dbg6 (parentf <> " include: glob pattern") glb) errorNoArg+  when (null $ dbg6 (parentf <> " include: path ") path) errorNoArg    -- Find the file or glob-matched files (just the ones from this include directive), with some IO error checking.-  paths <- findMatchedFiles eoff parentf glb+  paths <- findMatchedFiles eoff parentf path   -- Also report whether a glob pattern was used, and not just a literal file path.   -- (paths, isglob) <- findMatchedFiles off pos glb @@ -359,7 +359,7 @@     -- but ** will implicitly search non-top-level dot directories (see #2498, Glob#49).      findMatchedFiles :: (MonadIO m) => Int -> FilePath -> FilePath -> JournalParser m [FilePath]-    findMatchedFiles off parentf globpattern = do+    findMatchedFiles off parentf path = do        -- Some notes about the Glob library that we use (related: https://github.com/Deewiant/glob/issues/49):       -- It does not expand tilde.@@ -374,39 +374,39 @@       -- A **/ component matches any number of directory parts.       -- A **/ does not implicitly search top-level dot directories or implicitly match do files,       -- but it does search non-top-level dot directories. Eg ** will find the c file in a/.b/c.+      -- It tends to get attributes of all files in a directory.        -- expand a tilde at the start of the glob pattern, or throw an error-      expandedglob <- lift $ expandHomePath globpattern & handleIOError off "failed to expand ~"+      expandedpath <- lift $ expandHomePath path & handleIOError off "failed to expand ~"        -- get the directory of the including file       -- need to canonicalise a symlink parentf so takeDirectory works correctly [#2503]       cwd <- fmap takeDirectory <$> liftIO $ canonicalizePath parentf        -- Don't allow 3 or more stars.-      when ("***" `isInfixOf` expandedglob) $+      when ("***" `isInfixOf` expandedpath) $         customFailure $ parseErrorAt off $ "Invalid glob pattern: too many stars, use * or **"        -- Make ** also match file name parts like zsh's GLOB_STAR_SHORT.       let-        finalglob =+        finalpath =           -- ** without a slash is equivalent to **/*-          case regexReplace (toRegex' $ T.pack "\\*\\*([^/\\])") "**/*\\1" expandedglob of+          case regexReplace (toRegex' $ T.pack "\\*\\*([^/\\])") "**/*\\1" expandedpath of             Right s -> s-            Left  _ -> expandedglob   -- ignore any error, there should be none+            Left  _ -> expandedpath   -- ignore any error, there should be none        -- Compile as a Pattern. Can throw an error.-      pat <- case tryCompileWith compDefault{errorRecovery=False} finalglob of+      pat <- case tryCompileWith compDefault{errorRecovery=False} finalpath of         Left e  -> customFailure $ parseErrorAt off $ "Invalid glob pattern: " ++ e         Right x -> pure x -      -- Find all matched paths. These might include directories or the current file.-      -- Glob seems to get attributes of all files in a directory, which disturbs build systems-      -- which detect dependencies based on filesystem operations (eg tup).-      -- So avoid using it if not needed.-      paths <- liftIO $+      -- Find all paths matched by the glob pattern.+      -- If it is a literal (non-glob) path, don't use the Glob lib, because it gets attributes+      -- of all files in the directory, which confuses build systems like tup.+      paths <-         if isLiteral pat-        then return $ if isAbsolute finalglob then [finalglob] else [cwd </> finalglob]-        else globDir1 pat cwd+        then return $ if isAbsolute finalpath then [finalpath] else [cwd </> finalpath]+        else liftIO $ globDir1 pat cwd        -- Exclude any directories or symlinks to directories, and canonicalise, and sort.       files <- liftIO $@@ -429,7 +429,7 @@           | otherwise -> return f        -- Throw an error if no files were matched.-      when (null files2) $ customFailure $ parseErrorAt off $ "No files were matched by: " ++ globpattern+      when (null files2) $ customFailure $ parseErrorAt off $ "No files were matched by: " ++ path        -- If the current file got included, ignore it (last, to avoid triggering the error above).       let@@ -563,10 +563,12 @@     "c"          -> Right Cash     "conversion" -> Right Conversion     "v"          -> Right Conversion+    "gains"      -> Right Gain+    "g"          -> Right Gain     _            -> Left err   where     err = T.unpack $ "invalid account type code "<>s<>", should be one of " <>-            T.intercalate ", " ["A","L","E","R","X","C","V","Asset","Liability","Equity","Revenue","Expense","Cash","Conversion"]+            T.intercalate ", " ["A","L","E","R","X","C","V","G","Asset","Liability","Equity","Revenue","Expense","Cash","Conversion","Gain"]  -- Add an account declaration to the journal, auto-numbering it. addAccountDeclaration :: (AccountName,Text,[Tag],SourcePos) -> JournalParser m ()@@ -626,11 +628,13 @@     amt <- amountp     pure $ (off, amt)   lift skipNonNewlineSpaces-  _ <- lift followingcommentp-  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg7 "style from commodity directive" astyle}+  (comment, tags) <- lift transactioncommentp+  let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg7 "style from commodity directive" astyle, ccomment=comment, ctags=tags}   if isNothing $ asdecimalmark astyle   then customFailure $ parseErrorAt off pleaseincludedecimalpoint-  else modify' (\j -> j{jdeclaredcommodities=M.insert acommodity comm $ jdeclaredcommodities j})+  else modify' (\j -> j{jdeclaredcommodities=M.insert acommodity comm $ jdeclaredcommodities j+                       ,jdeclaredcommoditytags=if null tags then jdeclaredcommoditytags j+                                               else M.insert acommodity tags $ jdeclaredcommoditytags j})  pleaseincludedecimalpoint :: String pleaseincludedecimalpoint = chomp $ unlines [@@ -651,12 +655,14 @@   string "commodity"   lift skipNonNewlineSpaces1   sym <- lift commoditysymbolp-  _ <- lift followingcommentp+  (comment, tags) <- lift transactioncommentp   -- read all subdirectives, saving format subdirectives as Lefts   subdirectives <- many $ indented (eitherP (formatdirectivep sym) (lift restofline))   let mfmt = lastMay $ lefts subdirectives-  let comm = Commodity{csymbol=sym, cformat=mfmt}-  modify' (\j -> j{jdeclaredcommodities=M.insert sym comm $ jdeclaredcommodities j})+  let comm = Commodity{csymbol=sym, cformat=mfmt, ccomment=comment, ctags=tags}+  modify' (\j -> j{jdeclaredcommodities=M.insert sym comm $ jdeclaredcommodities j+                  ,jdeclaredcommoditytags=if null tags then jdeclaredcommoditytags j+                                          else M.insert sym tags $ jdeclaredcommoditytags j})   where     indented = (lift skipNonNewlineSpaces1 >>) 

@@ -218,14 +218,14 @@ -- of 'Posting's. generateMultiBalanceAccount :: ReportSpec -> Journal -> PriceOracle -> Maybe DayPartition -> [Posting] -> Account BalanceData generateMultiBalanceAccount rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle colspans =+    -- Set account declaration info (for sorting purposes)+    mapAccounts (accountSetDeclarationInfo j)     -- Add declared accounts if called with --declared and --empty-    (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id)+    . (if (declared_ ropts && empty_ ropts) then addDeclaredAccounts rspec j else id)     -- Negate amounts if applicable     . (if invert_ ropts then fmap (mapBalanceData maNegate) else id)     -- Mark which accounts are boring and which are interesting     . markAccountBoring rspec-    -- Set account declaration info (for sorting purposes)-    . mapAccounts (accountSetDeclarationInfo j)     -- Process changes into normal, cumulative, or historical amounts, plus value them     . calculateReportAccount rspec j priceoracle colspans     -- Clip account names@@ -505,7 +505,7 @@ tests_MultiBalanceReport = testGroup "MultiBalanceReport" [    let-    amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing,+    amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing, acostbasis=Nothing,       astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing,       asdecimalmark = Just '.', asprecision = Precision 2, asrounding = NoRounding}}     (rspec,journal) `gives` r = do

@@ -78,7 +78,7 @@ import Data.Functor.Identity (Identity(..)) import Data.List (partition) import Data.List.Extra (find, isPrefixOf, nubSort, stripPrefix)-import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Text qualified as T import Data.Time.Calendar (Day, addDays) import Data.Default (Default(..))@@ -467,6 +467,14 @@ extractIntervalOrNothing (NoInterval, _) = Nothing extractIntervalOrNothing (interval, _) = Just interval +-- | Get the last interval specified in query opts, if any.+-- date: queries can specify a reporting interval.+intervalFromQueryOpts :: [QueryOpt] -> Maybe Interval+intervalFromQueryOpts = lastMay . mapMaybe getInterval+  where+    getInterval (QueryOptInterval i) = Just i+    getInterval _ = Nothing+ -- | Get any statuses to be matched, as specified by -U/--unmarked, -- -P/--pending, -C/--cleared flags. -UPC is equivalent to no flags, -- so this returns a list of 0-2 unique statuses.@@ -990,10 +998,14 @@ reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec reportOptsToSpec day ropts = do     (argsquery, queryopts) <- parseQueryList day $ querystring_ ropts+    -- If there's an interval in the query opts, it overrides the interval from -p/--period/etc+    let ropts' = case intervalFromQueryOpts queryopts of+                   Just i  -> ropts{interval_=i}+                   Nothing -> ropts     return ReportSpec-      { _rsReportOpts = ropts+      { _rsReportOpts = ropts'       , _rsDay        = day-      , _rsQuery      = simplifyQuery $ And [queryFromFlags ropts, argsquery]+      , _rsQuery      = simplifyQuery $ And [queryFromFlags ropts', argsquery]       , _rsQueryOpts  = queryopts       } 

@@ -18,6 +18,8 @@   curry4,   uncurry4, +  divideSafe,+   -- * Lists   maximum',   maximumStrict,@@ -145,6 +147,11 @@  uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (w, x, y, z) = f w x y z++-- | Division, returning 0 when the denominator is 0.+divideSafe :: (Eq a, Fractional a) => a -> a -> a+divideSafe _ 0 = 0+divideSafe a b = a / b  -- Lists 

@@ -67,9 +67,10 @@   getTerminalWidth,    -- * Pager output-  setupPager,   findPager,   runPager,+  lessVarValue,+  lessIsWorking,    -- * ANSI colour/styles @@ -149,15 +150,16 @@ 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, getProgName)-import           System.Exit (exitFailure)-import           System.FilePath (isRelative, (</>))+import           System.Environment (getArgs, getEnvironment, lookupEnv, getProgName)+import           System.Exit (ExitCode(ExitSuccess), exitFailure)+import           System.FilePath (isRelative, (</>), takeBaseName) import "Glob"    System.FilePath.Glob (glob) import           System.Info (os) import           System.IO (Handle, IOMode (..), hClose, hGetEncoding, hIsTerminalDevice, hPutStr, hPutStrLn, hSetNewlineMode, hSetEncoding, openFile, stderr, stdin, stdout, universalNewlineMode, utf8_bom, utf8) import System.IO.Encoding qualified as Enc import           System.IO.Unsafe (unsafePerformIO)-import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, shell, waitForProcess, withCreateProcess)+import           System.Process (CreateProcess(..), StdStream(CreatePipe), createPipe, proc, readCreateProcessWithExitCode, shell, waitForProcess, withCreateProcess)+import           System.Timeout (timeout) import           Text.Pretty.Simple (CheckColorTty(..), OutputOptions(..), defaultOutputOptionsDarkBg, defaultOutputOptionsNoColor, pShowOpt, pPrintOpt)  import Hledger.Utils.Text (WideBuilder(WideBuilder))@@ -398,10 +400,11 @@ 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.+-- | Expand a single tilde (representing home directory) at the start of a file path.+-- ~username is not supported. This can raise an IO error. expandHomePath :: FilePath -> IO FilePath expandHomePath = \case+    "~"          -> getHomeDirectory     ('~':'/':p)  -> (</> p) <$> getHomeDirectory     ('~':'\\':p) -> (</> p) <$> getHomeDirectory     ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"@@ -409,12 +412,14 @@  -- | Given a current directory, convert a possibly relative, possibly tilde-prefixed -- file path to an absolute one.--- ~username is not supported. Leaves "-" unchanged. Can raise an error.+-- ~username is not supported.+-- If the file path is "-", it is left as-is.+-- This can an raise an IO error. expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" expandPath curdir p = (if isRelative p then (curdir </>) else id) <$> expandHomePath p  -- PARTIAL: --- | Like expandPath, but treats the expanded path as a glob, and returns+-- | Like @expandPath@, but treats the expanded path as a glob, and returns -- zero or more matched absolute file paths, alphabetically sorted. -- Can raise an error. -- For a more elaborate glob expander, see 'findMatchedFiles' (used by the include directive).@@ -636,79 +641,16 @@ -- Pager output -- somewhat hledger-specific --- Configure some preferred options for the `less` pager,--- by modifying the LESS environment variable in this program's environment.--- If you are using some other pager, this will have no effect.--- By default, this sets the following options, appending them to LESS's current value:------   --chop-long-lines---   --hilite-unread---   --ignore-case---   --no-init---   --quit-at-eof---   --quit-if-one-screen---   --RAW-CONTROL-CHARS---   --shift=8---   --squeeze-blank-lines---   --use-backslash------ You can choose different options by setting the HLEDGER_LESS variable;--- if set, its value will be used instead of LESS.--- Or you can force hledger to use your exact LESS settings,--- by setting HLEDGER_LESS equal to LESS.----setupPager :: IO ()-setupPager = do-  let-    -- keep synced with doc above-    deflessopts = unwords [-       "--chop-long-lines"-      ,"--hilite-unread"-      ,"--ignore-case"-      ,"--no-init"-      ,"--quit-at-eof"-      ,"--quit-if-one-screen"-      ,"--RAW-CONTROL-CHARS"-      ,"--shift=8"-      ,"--squeeze-blank-lines"-      ,"--use-backslash"-      -- ,"--use-color"  #2335 rejected by older less versions (eg 551)-      ]-  mhledgerless <- lookupEnv "HLEDGER_LESS"-  mless        <- lookupEnv "LESS"-  setEnv "LESS" $-    case (mhledgerless, mless) of-      (Just hledgerless, _) -> hledgerless-      (_, 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)--- when appropriate, otherwise printing to standard output. Uses maybePagerFor.------ hledger's output may contain ANSI style/color codes--- (if the terminal supports them and they are not disabled by --color=no or NO_COLOR),--- so the pager should be configured to handle these.--- setupPager tries to configure that automatically when using the `less` pager.----runPager :: String -> IO ()-runPager s = do-  mpager <- maybePagerFor s-  case mpager of-    Nothing -> putStr s-    Just pager -> do-      withCreateProcess (shell pager){std_in=CreatePipe} $-        \mhin _ _ p -> do-          -- Pipe in the text on stdin.-          case mhin of-            Nothing  -> return ()  -- shouldn't happen-            Just hin -> void $ forkIO $   -- Write from another thread to avoid deadlock ? Maybe unneeded, but just in case.-              (hPutStr hin s >> hClose hin)  -- Be sure to close the pipe so the pager knows we're done.-                -- If the pager quits early, we'll receive an EPIPE error; hide that.-                `catch` \(e::IOException) -> case e of-                  IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe, ioe_handle=Just hdl} | Errno ioe==ePIPE, hdl==hin-                    -> return ()-                  _ -> throwIO e-          void $ waitForProcess p+-- | Try to find a pager executable robustly, safely handling various error conditions+-- like an unset PATH var or the specified pager not being found as an executable.+-- The pager can be specified by a path or program name in the PAGER environment variable.+-- If that is unset or has a problem, "less" is tried, then "more".+-- If successful, the pager's path or program name is returned.+findPager :: IO (Maybe String)  -- XXX probably a ByteString in fact ?+findPager = do+  mpagervar <- lookupEnv "PAGER"+  let pagers = [p | Just p <- [mpagervar]] <> ["less", "more"]+  headMay . catMaybes <$> mapM findExecutable pagers  -- | Should a pager be used for displaying the given text on stdout, and if so, which one ? -- Uses a pager if findPager finds one and none of the following conditions are true:@@ -737,17 +679,107 @@     guard $ oh > th || ow > tw     mpager --- | Try to find a pager executable robustly, safely handling various error conditions--- like an unset PATH var or the specified pager not being found as an executable.--- The pager can be specified by a path or program name in the PAGER environment variable.--- If that is unset or has a problem, "less" is tried, then "more".--- If successful, the pager's path or program name is returned.-findPager :: IO (Maybe String)  -- XXX probably a ByteString in fact ?-findPager = do-  mpagervar <- lookupEnv "PAGER"-  let pagers = [p | Just p <- [mpagervar]] <> ["less", "more"]-  headMay . catMaybes <$> mapM findExecutable pagers+-- | Display the given text on the terminal, trying to use a pager ($PAGER, less, or more)+-- when appropriate (see maybePagerFor), otherwise printing to standard output.+-- Also, if the pager is less, we modify the LESS environment variable (see lessVarValue)+-- and check for problems which could cause confusing output (see lessIsWorking).+runPager :: String -> IO ()+runPager s = do+  mpager <- maybePagerFor s+  case mpager of+    Nothing -> putStr s+    Just pager -> do +      -- If using less, customise the LESS environment variable and check if it works+      let pagerIsLess = map toLower (takeBaseName pager) == "less"+      (mCustomEnv, shouldUsePager) <- if not pagerIsLess+        then return (Nothing, True)+        else do+          mHLEDGER_LESS <- lookupEnv "HLEDGER_LESS"+          mLESS         <- lookupEnv "LESS"+          usecolor      <- useColorOnStdout+          let newlessvar = lessVarValue mHLEDGER_LESS mLESS usecolor+          env <- getEnvironment+          let customEnv = ("LESS", newlessvar) : filter ((/= "LESS") . fst) env+          -- Check that less --version is working (using our custom LESS) (#2544)+          lessHasError <- lessIsWorking (Just customEnv) `catch` \(_::IOException) -> return True+          when lessHasError $ warnIO $+            "less --version fails with current LESS settings; disabling. Check 'hledger setup' for details.\n"+          return (Just customEnv, not lessHasError)++      -- Run the pager, providing the text as input. Or if we found a problem already, just print.+      if not shouldUsePager+        then putStr s+        else (withCreateProcess (shell pager){std_in=CreatePipe, env=mCustomEnv} $+          \mhin _ _ p -> do+            case mhin of+              Nothing  -> fail "Failed to create pipe to pager"+              Just hin -> void $ forkIO $   -- Write from another thread to avoid deadlock ? Maybe unneeded, but just in case.+                (hPutStr hin s >> hClose hin)  -- Be sure to close the pipe so the pager knows we're done.+                  -- If the pager quits early, we'll receive an EPIPE error; hide that.+                  `catch` \(e::IOException) -> case e of+                    IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe, ioe_handle=Just hdl} | Errno ioe==ePIPE, hdl==hin -> return ()+                    _ -> throwIO e+            void $ waitForProcess p)+          `catch` \(_::IOException) -> putStr s++-- | Test @less@, by running less --version and looking for a nonzero exit, timeout, or stderr output.+-- Uses the provided environment, containing a LESS variable, if any.+-- We do this because various LESS settings can cause some less versions to fail or cause confusing output without failing.+lessIsWorking :: Maybe [(String, String)] -> IO Bool+lessIsWorking mCustomEnv = do+  result <- timeout 300000 $ readCreateProcessWithExitCode (proc "less" ["--version"]){env=mCustomEnv} ""+  return $ case result of+    Nothing -> True  -- Timeout+    Just (exitCode, _, stderrOut) -> exitCode /= ExitSuccess || not (null stderrOut)++-- | Compute the LESS environment variable value that hledger will use for the less pager.+-- This used in runPager when invoking less, and also in the setup command for display.+-- It takes the current HLEDGER_LESS and LESS env var values, and whether we are showing colour on stdout,+-- and returns the adjusted LESS value that should be used. Specifically:+--+-- - If HLEDGER_LESS is defined, we use it in place of the LESS environment variable.+--+-- - Otherwise, if LESS is defined, append some preferred options (lessOptions and maybe lessColourOptions) to it.+--+-- - Otherwise, we set LESS to just use those preferred options.+--+lessVarValue :: Maybe String -> Maybe String -> Bool -> String+lessVarValue mHLEDGER_LESS mLESS usecolor =+  let extralessopts = unwords $ [lessOptions] <> [lessColourOptions | usecolor]+  in case (mHLEDGER_LESS, mLESS) of+       (Just hledgerlessvar, _) -> hledgerlessvar+       (_, Just lessvar) -> if extralessopts `isInfixOf` lessvar then lessvar else unwords [lessvar, extralessopts]+       _ -> extralessopts++-- keep synced: hledger.m4.md > Paging+-- | hledger's preferred less options, which it will append to the user's LESS environment variable.+-- The thinking here is: "Many people don't have their LESS optimised to get the best experience from modern less, as I didn't.+-- Also as they use hledger on different machines, LESS is likely not consistent. +-- So let's add some settings that I have found reasonably robust, compatible, and good for usability.+-- That will help provide a consistent good experience when viewing hledger's long outputs.+-- And power users can prevent this by setting exactly the options they want in HLEDGER_LESS."+-- Here's what they mean: https://manned.org/man/less#head5+--+-- Flags that might break older less versions (causing hledger to fall back to unpaged output) are avoided here.+-- Such as --mouse and --wheel-lines (less >=530, 2018) and --use-color (less >=551, 2019).+-- --hilite-unread (less >=443, 2011) is useful and considered old enough.+--+lessOptions = unwords [+   "--chop-long-lines"+  ,"--hilite-unread"+  ,"--ignore-case"+  ,"--no-init"+  ,"--quit-if-one-screen"+  ,"--shift=8"+  ,"--squeeze-blank-lines"+  ,"--use-backslash"+  ] ++-- | Additional less options to use if we are showing colour on stdout.+lessColourOptions = unwords [+   "--RAW-CONTROL-CHARS"+  ]   -- ANSI colour/styles

@@ -211,7 +211,7 @@     clip s =       case mmaxwidth of         Just w-          | realLength s > w ->+          | realLength s > max 0 w ->             if rightside               then textTakeWidth (w - T.length ellipsis) s <> ellipsis               else ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s)@@ -287,5 +287,9 @@      textUnbracket "[([]())]" @?= "[]()"      textUnbracket "[([[[()]]])]" @?= ""      textUnbracket "[([[[(]]])]" @?= "("-     textUnbracket "[([[[)]]])]" @?= ")"+     textUnbracket "[([[[)]]])]" @?= ")",+   testCase "fitText" $ do+     fitText Nothing (Just (-2)) True True "" @?= ""+     fitText Nothing (Just 0) True True "" @?= ""+     fitText Nothing (Just 6) True True "Test Text" @?= "Test.."   ]

@@ -43,7 +43,8 @@ import Data.Function ((&)) import Data.List.Extra (groupOnKey) import Data.Bifunctor (first)-import Data.List (sort)+import Data.List (intersperse, sort)+import Data.Maybe (catMaybes)  --- ** doctest setup -- $setup@@ -199,10 +200,11 @@     -- amtwidth at all.     shownAmounts       | elideamount = [mempty]-      | otherwise   = showMixedAmountLinesB displayopts a'+      | otherwise   = map addCostBasis $ showMixedAmountLinesPartsB displayopts a'         where-          displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayQuotes=False }+          displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayQuotes=False, displayCostBasis=False }           a' = mapMixedAmount amountToBeancount $ pamount p+          addCostBasis (builder, amt) = builder <> showAmountCostBasisBeancountB displayopts amt     thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts      -- when there is a balance assertion, show it only on the last posting line@@ -314,6 +316,24 @@       where         costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt         costToBeancount (UnitCost  amt) = UnitCost  $ amountToBeancount amt++-- | Show an amount's cost basis in Beancount lot syntax: {cost, date, label}+-- Returns a WideBuilder with the formatted cost basis, or mempty if there's no cost basis.+showAmountCostBasisBeancountB :: AmountFormat -> Amount -> WideBuilder+showAmountCostBasisBeancountB afmt amt = case acostbasis amt of+  Nothing -> mempty+  Just CostBasis{cbCost, cbDate, cbLabel} ->+    case parts of+      [] -> mempty+      _  -> WideBuilder (TB.fromString " {") 2 <> contents <> WideBuilder (TB.singleton '}') 1+    where+      parts = catMaybes+        [ fmap (showAmountB afmt . amountToBeancount) cbCost+        , fmap (wbFromText . T.pack . show) cbDate+        , fmap (wbFromText . quote) cbLabel+        ]+      contents = mconcat $ Data.List.intersperse (WideBuilder (TB.fromString ", ") 2) parts+      quote t = "\"" <> t <> "\""  type BeancountCommoditySymbol = CommoditySymbol 

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.1.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           hledger-lib-version:        1.51.2+version:        1.52 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@@ -124,7 +124,7 @@   hs-source-dirs:       ./   ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind-  cpp-options: -DVERSION="1.51.2"+  cpp-options: -DVERSION="1.52"   build-depends:       Decimal >=0.5.1     , Glob >=0.9@@ -184,7 +184,7 @@   hs-source-dirs:       test   ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind-  cpp-options: -DVERSION="1.51.2"+  cpp-options: -DVERSION="1.52"   build-depends:       Decimal >=0.5.1     , Glob >=0.7@@ -245,7 +245,7 @@   hs-source-dirs:       test   ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind-  cpp-options: -DVERSION="1.51.2"+  cpp-options: -DVERSION="1.52"   build-depends:       Decimal >=0.5.1     , Glob >=0.9