From 77aeb18bbd75f2f0ee359ceaea6d65c09218d35e Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 31 Aug 2023 04:11:14 +0100 Subject: [PATCH] fix:print:style balance assertion costs; more styling api; HasAmounts class --- hledger-lib/Hledger/Data/Amount.hs | 44 ++++++++++++------- hledger-lib/Hledger/Data/Journal.hs | 2 +- hledger-lib/Hledger/Data/Posting.hs | 26 +++++++++-- hledger-lib/Hledger/Data/Transaction.hs | 3 ++ hledger-lib/Hledger/Data/Types.hs | 18 ++++++++ .../Reports/AccountTransactionsReport.hs | 4 ++ hledger-lib/Hledger/Reports/BalanceReport.hs | 3 ++ hledger-lib/Hledger/Reports/PostingsReport.hs | 3 ++ hledger-lib/Hledger/Reports/ReportTypes.hs | 23 ++++++++++ 9 files changed, 106 insertions(+), 20 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 4723e2f00..e1e117929 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -75,10 +75,11 @@ module Hledger.Data.Amount ( amountstyle, canonicaliseAmount, styleAmount, - styleAmountExceptPrecision, amountSetStyles, + amountSetStylesExceptPrecision, amountSetMainStyle, amountSetCostStyle, + amountStyleUnsetPrecision, amountUnstyled, showAmountB, showAmount, @@ -131,6 +132,7 @@ module Hledger.Data.Amount ( canonicaliseMixedAmount, styleMixedAmount, mixedAmountSetStyles, + mixedAmountSetStylesExceptPrecision, mixedAmountUnstyled, showMixedAmount, showMixedAmountOneLine, @@ -251,6 +253,8 @@ amountstyle = AmountStyle L False Nothing (Just '.') (Just $ Precision 0) ------------------------------------------------------------------------------- -- Amount +instance HasAmounts Amount where styleAmounts = amountSetStyles + instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} @@ -446,26 +450,31 @@ styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount styleAmount = amountSetStyles {-# DEPRECATED styleAmount "please use amountSetStyles instead" #-} --- | Like styleAmount, but leave the display precision unchanged. -styleAmountExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -styleAmountExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = - case M.lookup (acommodity a) styles of - Just s -> a{astyle=s{asprecision=origp}} - Nothing -> a - -- v3 -- | Given some commodity display styles, find and apply the appropriate -- display style to this amount, and do the same for its cost amount if any -- (and then stop; we assume costs don't have costs). --- The main amount's display precision may or may not be changed, as specified by the style. --- the cost amount's display precision is left unchanged, ignoring what the style says. - -- If no style is found for an amount, it is left unchanged. +-- The main amount's display precision is set or not, according to its style; +-- the cost amount's display precision is left unchanged, regardless of its style. +-- If no style is found for an amount, it is left unchanged. amountSetStyles :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount amountSetStyles styles = amountSetMainStyle styles <&> amountSetCostStyle styles +-- | Like amountSetStyles, but leave the display precision unchanged +-- in both main and cost amounts. +amountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetStylesExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = + case M.lookup (acommodity a) styles' of + Just s -> a{astyle=s{asprecision=origp}} + Nothing -> a + where styles' = M.map amountStyleUnsetPrecision styles + +amountStyleUnsetPrecision :: AmountStyle -> AmountStyle +amountStyleUnsetPrecision as = as{asprecision=Nothing} + -- | Find and apply the appropriate display style, if any, to this amount. --- The display precision may or may not be changed, as specified by the style. +-- The display precision is set or not, according to the style. amountSetMainStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount amountSetMainStyle styles a@Amount{acommodity=comm, astyle=AmountStyle{asprecision=morigp}} = case M.lookup comm styles of @@ -477,13 +486,13 @@ amountSetMainStyle styles a@Amount{acommodity=comm, astyle=AmountStyle{asprecisi _ -> s -- | Find and apply the appropriate display style, if any, to this amount's cost, if any. --- The display precision is left unchanged, ignoring what the style says. +-- The display precision is left unchanged, regardless of the style. amountSetCostStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount amountSetCostStyle styles a@Amount{aprice=mcost} = case mcost of Nothing -> a - Just (UnitPrice a2) -> a{aprice=Just $ UnitPrice $ styleAmountExceptPrecision styles a2} - Just (TotalPrice a2) -> a{aprice=Just $ TotalPrice $ styleAmountExceptPrecision styles a2} + Just (UnitPrice a2) -> a{aprice=Just $ UnitPrice $ amountSetStylesExceptPrecision styles a2} + Just (TotalPrice a2) -> a{aprice=Just $ TotalPrice $ amountSetStylesExceptPrecision styles a2} -- | Reset this amount's display style to the default. @@ -589,6 +598,8 @@ applyDigitGroupStyle (Just (DigitGroups c (g0:gs0))) l0 s0 = addseps (g0:|gs0) ( ------------------------------------------------------------------------------- -- MixedAmount +instance HasAmounts MixedAmount where styleAmounts = mixedAmountSetStyles + instance Semigroup MixedAmount where (<>) = maPlus sconcat = maSum @@ -869,6 +880,9 @@ styleMixedAmount = mixedAmountSetStyles mixedAmountSetStyles :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount mixedAmountSetStyles styles = mapMixedAmountUnsafe (amountSetStyles styles) +mixedAmountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount +mixedAmountSetStylesExceptPrecision styles = mapMixedAmountUnsafe (amountSetStylesExceptPrecision styles) + -- | Reset each individual amount's display style to the default. mixedAmountUnstyled :: MixedAmount -> MixedAmount mixedAmountUnstyled = mapMixedAmountUnsafe amountUnstyled diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 0ab383d4f..40b894ae2 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -802,7 +802,7 @@ journalApplyCommodityStyles = fmap fixjournal . journalInferCommodityStyles journalMapPostings (postingApplyCommodityStyles styles) j{jpricedirectives=map fixpricedirective pds} where styles = journalCommodityStyles j - fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmountExceptPrecision styles a} + fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=amountSetStylesExceptPrecision styles a} -- | Get the canonical amount styles for this journal, whether (in order of precedence): -- set globally in InputOpts, diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 11b236131..356c77aaa 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -39,6 +39,7 @@ module Hledger.Data.Posting ( postingStripPrices, postingApplyAliases, postingApplyCommodityStyles, + postingApplyCommodityStylesExceptPrecision, postingAddTags, -- * date operations postingDate, @@ -97,6 +98,14 @@ import Hledger.Data.Dates (nulldate, spanContainsDate) import Hledger.Data.Valuation +instance HasAmounts BalanceAssertion where + styleAmounts styles ba@BalanceAssertion{baamount} = ba{baamount=styleAmounts styles baamount} + +instance HasAmounts Posting where + styleAmounts styles p@Posting{pamount, pbalanceassertion} = + p{ pamount=styleAmounts styles pamount + ,pbalanceassertion=styleAmounts styles pbalanceassertion + } nullposting, posting :: Posting nullposting = Posting @@ -410,13 +419,22 @@ postingApplyAliases aliases p@Posting{paccount} = err = "problem while applying account aliases:\n" ++ pshow aliases ++ "\n to account name: "++T.unpack paccount++"\n "++e --- | Choose and apply a consistent display style to the posting --- amounts in each commodity (see journalCommodityStyles). +-- | Find and apply the appropriate display style to the posting amounts +-- in each commodity (see journalCommodityStyles). +-- Main amount precisions may be set or not according to the styles, but cost precisions are not set. postingApplyCommodityStyles :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting postingApplyCommodityStyles styles p = p{pamount=mixedAmountSetStyles styles $ pamount p - ,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p} + ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} where - fixbalanceassertion ba = ba{baamount=styleAmountExceptPrecision styles $ baamount ba} + balanceassertionsetstyles ba = ba{baamount=amountSetStyles styles $ baamount ba} + +-- | Like postingApplyCommodityStyles, but neither +-- main amount precisions or cost precisions are set. +postingApplyCommodityStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting +postingApplyCommodityStylesExceptPrecision styles p = p{pamount=mixedAmountSetStylesExceptPrecision styles $ pamount p + ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} + where + balanceassertionsetstyles ba = ba{baamount=amountSetStylesExceptPrecision styles $ baamount ba} -- | Add tags to a posting, discarding any for which the posting already has a value. postingAddTags :: Posting -> [Tag] -> Posting diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 9c8670dfe..aebddef8d 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -74,6 +74,9 @@ import Data.Decimal (normalizeDecimal, decimalPlaces) import Data.Functor ((<&>)) +instance HasAmounts Transaction where + styleAmounts styles t = t{tpostings=styleAmounts styles $ tpostings t} + nulltransaction :: Transaction nulltransaction = Transaction { tindex=0, diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 1629a0a1c..04a57e2eb 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -301,6 +301,24 @@ data Amount = Amount { aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any } deriving (Eq,Ord,Generic,Show) +-- | Types with this class have one or more amounts, +-- which can have display styles applied to them. +class HasAmounts a where + styleAmounts :: M.Map CommoditySymbol AmountStyle -> a -> a + +instance HasAmounts a => + HasAmounts [a] + where styleAmounts styles = map (styleAmounts styles) + +instance (HasAmounts a, HasAmounts b) => + HasAmounts (a,b) + where styleAmounts styles (aa,bb) = (styleAmounts styles aa, styleAmounts styles bb) + +instance HasAmounts a => + HasAmounts (Maybe a) + where styleAmounts styles = fmap (styleAmounts styles) + + newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Generic,Show) instance Eq MixedAmount where a == b = maCompare a b == EQ diff --git a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs index 6a0352318..20a782c09 100644 --- a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs @@ -85,6 +85,10 @@ type AccountTransactionsReportItem = ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction ) +instance HasAmounts AccountTransactionsReportItem where + styleAmounts styles (torig,tacct,b,c,a1,a2) = + (styleAmounts styles torig,styleAmounts styles tacct,b,c,styleAmounts styles a1,styleAmounts styles a2) + triOrigTransaction (torig,_,_,_,_,_) = torig triDate (_,tacct,_,_,_,_) = tdate tacct triAmount (_,_,_,_,a,_) = a diff --git a/hledger-lib/Hledger/Reports/BalanceReport.hs b/hledger-lib/Hledger/Reports/BalanceReport.hs index a23bc96af..4cef9ab08 100644 --- a/hledger-lib/Hledger/Reports/BalanceReport.hs +++ b/hledger-lib/Hledger/Reports/BalanceReport.hs @@ -49,6 +49,9 @@ import Hledger.Reports.ReportTypes type BalanceReport = ([BalanceReportItem], MixedAmount) type BalanceReportItem = (AccountName, AccountName, Int, MixedAmount) +instance HasAmounts BalanceReportItem where + styleAmounts styles (a,b,c,d) = (a,b,c,styleAmounts styles d) + -- | When true (the default), this makes balance --flat reports and their implementation clearer. -- Single/multi-col balance reports currently aren't all correct if this is false. flatShowsExclusiveBalance = True diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index cb8c01afe..7f734e49a 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -52,6 +52,9 @@ type PostingsReportItem = (Maybe Day -- The posting date, if this is the fir -- the running total/average. ) +instance HasAmounts PostingsReportItem where + styleAmounts styles (a,b,c,d,e) = (a,b,c,styleAmounts styles d,styleAmounts styles e) + -- | A summary posting summarises the activity in one account within a report -- interval. It is by a regular Posting with no description, the interval's -- start date stored as the posting date, and the interval's Period attached diff --git a/hledger-lib/Hledger/Reports/ReportTypes.hs b/hledger-lib/Hledger/Reports/ReportTypes.hs index 965bc8935..a426665ac 100644 --- a/hledger-lib/Hledger/Reports/ReportTypes.hs +++ b/hledger-lib/Hledger/Reports/ReportTypes.hs @@ -4,6 +4,8 @@ New common report types, used by the BudgetReport for now, perhaps all reports l {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} module Hledger.Reports.ReportTypes ( PeriodicReport(..) @@ -91,6 +93,10 @@ data PeriodicReport a b = instance Bifunctor PeriodicReport where bimap f g pr = pr{prRows = map (bimap f g) $ prRows pr, prTotals = g <$> prTotals pr} +instance HasAmounts b => HasAmounts (PeriodicReport a b) where + styleAmounts styles r@PeriodicReport{prRows,prTotals} = + r{prRows=styleAmounts styles prRows, prTotals=styleAmounts styles prTotals} + data PeriodicReportRow a b = PeriodicReportRow { prrName :: a -- An account name. @@ -106,6 +112,13 @@ instance Bifunctor PeriodicReportRow where instance Semigroup b => Semigroup (PeriodicReportRow a b) where (<>) = prrAdd +instance HasAmounts b => HasAmounts (PeriodicReportRow a b) where + styleAmounts styles r = + r{prrAmounts=styleAmounts styles $ prrAmounts r + ,prrTotal =styleAmounts styles $ prrTotal r + ,prrAverage=styleAmounts styles $ prrAverage r + } + -- | Add two 'PeriodicReportRows', preserving the name of the first. prrAdd :: Semigroup b => PeriodicReportRow a b -> PeriodicReportRow a b -> PeriodicReportRow a b prrAdd (PeriodicReportRow n1 amts1 t1 a1) (PeriodicReportRow _ amts2 t2 a2) = @@ -162,6 +175,16 @@ data CompoundPeriodicReport a b = CompoundPeriodicReport , cbrTotals :: PeriodicReportRow () b } deriving (Show, Functor, Generic, ToJSON) +instance HasAmounts b => HasAmounts (CompoundPeriodicReport a b) where + styleAmounts styles cpr@CompoundPeriodicReport{cbrSubreports, cbrTotals} = + cpr{ + cbrSubreports = styleAmounts styles cbrSubreports + , cbrTotals = styleAmounts styles cbrTotals + } + +instance HasAmounts b => HasAmounts (Text, PeriodicReport a b, Bool) where + styleAmounts styles (a,b,c) = (a,styleAmounts styles b,c) + -- | Description of one subreport within a compound balance report. -- Part of a "CompoundBalanceCommandSpec", but also used in hledger-lib. data CBCSubreportSpec a = CBCSubreportSpec