diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -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" diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -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. diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -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 diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -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. diff --git a/Hledger/Data/Json.hs b/Hledger/Data/Json.hs --- a/Hledger/Data/Json.hs +++ b/Hledger/Data/Json.hs @@ -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 diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -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], ":"] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -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 diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -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{..} = diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -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 diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -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 diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -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. diff --git a/Hledger/Read/InputOptions.hs b/Hledger/Read/InputOptions.hs --- a/Hledger/Read/InputOptions.hs +++ b/Hledger/Read/InputOptions.hs @@ -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 diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -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 >>) diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -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 diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -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 } diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -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 diff --git a/Hledger/Utils/IO.hs b/Hledger/Utils/IO.hs --- a/Hledger/Utils/IO.hs +++ b/Hledger/Utils/IO.hs @@ -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 diff --git a/Hledger/Utils/Text.hs b/Hledger/Utils/Text.hs --- a/Hledger/Utils/Text.hs +++ b/Hledger/Utils/Text.hs @@ -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.." ] diff --git a/Hledger/Write/Beancount.hs b/Hledger/Write/Beancount.hs --- a/Hledger/Write/Beancount.hs +++ b/Hledger/Write/Beancount.hs @@ -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 diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -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