; refactor: centralise valuation logic #131

hledger-lib/Hledger/Data/Amount.hs

@@ -62,7 +62,8 @@ module Hledger.Data.Amount (
   multiplyAmount,
   divideAmountAndPrice,
   multiplyAmountAndPrice,
-  amountValue,
+  amountValueAtDate,
+  amountApplyValuation,
   amountTotalPriceToUnitPrice,
   -- ** rendering
   amountstyle,
@@ -107,7 +108,8 @@ module Hledger.Data.Amount (
   isZeroMixedAmount,
   isReallyZeroMixedAmount,
   isReallyZeroMixedAmountCost,
-  mixedAmountValue,
+  mixedAmountValueAtDate,
+  mixedAmountApplyValuation,
   mixedAmountTotalPriceToUnitPrice,
   -- ** rendering
   styleMixedAmount,
@@ -223,6 +225,35 @@ costOfAmount a@Amount{aquantity=q, aprice=price} =
 amountToCost :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount
 amountToCost styles = styleAmount styles . costOfAmount
 
+-- | Find the market value of this amount on the given valuation date
+-- in its default valuation commodity (that of the latest applicable 
+-- market price before the valuation date).
+-- The given market prices are expected to be in parse order.
+-- If no default valuation commodity can be found, the amount is left
+-- unchanged.
+amountValueAtDate :: Prices -> Day -> Amount -> Amount
+amountValueAtDate prices d a =
+  case priceLookup prices d (acommodity a) of
+    Just v  -> v{aquantity=aquantity v * aquantity a}
+    Nothing -> a
+
+-- | Alternate implementation.
+-- Apply a specified valuation to this amount, using the provided
+-- prices db, commodity styles, period-end/current dates, 
+-- and whether this is for a multiperiod report or not.
+-- Currently ignores the specified valuation commodity and always uses
+-- the default valuation commodity.
+amountApplyValuation :: Prices -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
+amountApplyValuation prices styles periodend today ismultiperiod v a =
+  -- will use _mc later
+  case v of
+    AtCost    _mc                 -> amountToCost styles a
+    AtEnd     _mc                 -> amountValueAtDate prices periodend a
+    AtNow     _mc                 -> amountValueAtDate prices today     a
+    AtDefault _mc | ismultiperiod -> amountValueAtDate prices periodend a
+    AtDefault _mc                 -> amountValueAtDate prices today     a
+    AtDate d  _mc                 -> amountValueAtDate prices d         a
+
 -- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice.
 -- Has no effect on amounts without one.
 -- Also increases the unit price's display precision to show one extra decimal place,
@@ -451,18 +482,6 @@ canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}
     where
       s' = findWithDefault s c styles
 
--- | Find the market value of this amount on the given valuation date
--- in its default valuation commodity (that of the latest applicable 
--- market price before the valuation date).
--- The given market prices are expected to be in parse order.
--- If no default valuation commodity can be found, the amount is left
--- unchanged.
-amountValue :: Prices -> Day -> Amount -> Amount
-amountValue prices d a =
-  case priceLookup prices d (acommodity a) of
-    Just v  -> v{aquantity=aquantity v * aquantity a}
-    Nothing -> a
-
 -------------------------------------------------------------------------------
 -- MixedAmount
 
@@ -724,8 +743,17 @@ canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styl
 -- in its default valuation commodity, using the given market prices
 -- which are expected to be in parse order. When no default valuation
 -- commodity can be found, amounts are left unchanged.
-mixedAmountValue :: Prices -> Day -> MixedAmount -> MixedAmount
+mixedAmountValueAtDate :: Prices -> Day -> MixedAmount -> MixedAmount
-mixedAmountValue prices d (Mixed as) = Mixed $ map (amountValue prices d) as
+mixedAmountValueAtDate prices d (Mixed as) = Mixed $ map (amountValueAtDate prices d) as
+
+-- Apply a specified valuation to this mixed amount, using the provided
+-- prices db, commodity styles, period-end/current dates, 
+-- and whether this is for a multiperiod report or not.
+-- Currently ignores the specified valuation commodity and always uses
+-- the default valuation commodity.
+mixedAmountApplyValuation :: Prices -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
+mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed as) =
+  Mixed $ map (amountApplyValuation prices styles periodend today ismultiperiod v) as
 
 -- | Replace each component amount's TotalPrice, if it has one, with an equivalent UnitPrice.
 -- Has no effect on amounts without one. 

hledger-lib/Hledger/Data/Posting.hs

@@ -65,7 +65,7 @@ module Hledger.Data.Posting (
   -- * misc.
   showComment,
   postingTransformAmount,
-  postingValue,
+  postingApplyValuation,
   postingToCost,
   tests_Posting
 )
@@ -347,20 +347,36 @@ aliasReplace (BasicAlias old new) a
   | otherwise = a
 aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX
 
--- | Apply a transform function to this posting's amount.
+-- Apply a specified valuation to this posting's amount, using the provided
-postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting
+-- prices db, commodity styles, period-end/current dates, and whether
-postingTransformAmount f p@Posting{pamount=a} = p{pamount=f a}
+-- this is for a multiperiod report or not.
+-- Currently ignores the specified valuation commodity and always uses
+-- the default valuation commodity.
+postingApplyValuation :: Prices -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
+postingApplyValuation prices styles periodend today ismultiperiod p v =
+  -- will use _mc later
+  case v of
+    AtCost    _mc                 -> postingToCost styles p
+    AtEnd     _mc                 -> postingValueAtDate prices periodend p
+    AtNow     _mc                 -> postingValueAtDate prices today     p
+    AtDefault _mc | ismultiperiod -> postingValueAtDate prices periodend p
+    AtDefault _mc                 -> postingValueAtDate prices today     p
+    AtDate d  _mc                 -> postingValueAtDate prices d         p
+
+-- | Convert this posting's amount to cost, and apply the appropriate amount styles.
+postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
+postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a}
 
 -- | Convert this posting's amount to market value in its default
 -- valuation commodity on the given date using the given market prices.
 -- If no default valuation commodity can be found, amounts are left unchanged.
 -- The prices are expected to be in parse order. 
-postingValue :: Prices -> Day -> Posting -> Posting
+postingValueAtDate :: Prices -> Day -> Posting -> Posting
-postingValue prices d p = postingTransformAmount (mixedAmountValue prices d) p
+postingValueAtDate prices d p = postingTransformAmount (mixedAmountValueAtDate prices d) p
 
--- | Convert this posting's amount to cost, and apply the appropriate amount styles.
+-- | Apply a transform function to this posting's amount.
-postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
+postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting
-postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a}
+postingTransformAmount f p@Posting{pamount=a} = p{pamount=f a}
 
 
 -- tests

hledger-lib/Hledger/Data/Types.hs

@@ -431,6 +431,16 @@ data MarketPrice = MarketPrice {
 
 instance NFData MarketPrice
 
+-- | What kind of value conversion should be done on amounts ?
+-- UI: --value=cost|end|now|DATE[,COMM]
+data ValuationType =
+    AtCost     (Maybe CommoditySymbol)  -- ^ convert to cost commodity using transaction prices, then optionally to given commodity using market prices at posting date
+  | AtEnd      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices at period end(s)
+  | AtNow      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using current market prices
+  | AtDate Day (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices on some date
+  | AtDefault  (Maybe CommoditySymbol)  -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports
+  deriving (Show,Data,Eq) -- Typeable
+
 -- | A Journal, containing transactions and various other things.
 -- The basic data model for hledger.
 --

hledger-lib/Hledger/Reports/BalanceReport.hs

@@ -74,6 +74,7 @@ balanceReport ropts@ReportOpts{..} q j =
       today = fromMaybe (error' "balanceReport: ReportOpts today_ is unset so could not satisfy --value=now") today_
       multiperiod = interval_ /= NoInterval
       prices = journalPrices j
+      styles = journalCommodityStyles j
 
       -- Get all the summed accounts & balances, according to the query, as an account tree.
       -- If doing cost valuation, amounts will be converted to cost first.
@@ -84,14 +85,7 @@ balanceReport ropts@ReportOpts{..} q j =
         where
           valueaccount a@Account{..} = a{aebalance=val aebalance, aibalance=val aibalance}
             where
-              val = case value_ of
+              val = maybe id (mixedAmountApplyValuation prices styles periodlastday today multiperiod) value_
-                      Nothing                            -> id
-                      Just (AtCost _mc)                  -> id
-                      Just (AtEnd _mc)                   -> mixedAmountValue prices periodlastday
-                      Just (AtNow _mc)                   -> mixedAmountValue prices today
-                      Just (AtDefault _mc) | multiperiod -> mixedAmountValue prices periodlastday
-                      Just (AtDefault _mc)               -> mixedAmountValue prices today
-                      Just (AtDate d _mc)                -> mixedAmountValue prices d
                 where
                   periodlastday =
                     fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen

hledger-lib/Hledger/Reports/EntriesReport.hs

@@ -41,33 +41,22 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
     prices = journalPrices j
     styles = journalCommodityStyles j
     tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings}
-    pvalue p@Posting{..} = case value_ of
+    pvalue p = maybe p (postingApplyValuation prices styles end today False p) value_
-      Nothing              -> p
-      Just (AtCost _mc)    -> postingToCost styles p
-      Just (AtEnd _mc)     -> valueend p
-      Just (AtNow _mc)     -> valuenow p
-      Just (AtDefault _mc) -> valuenow p
-      Just (AtDate d _mc)  -> postingValue prices d p
       where
-        valueend p = postingValue prices (
+        today  = fromMaybe (error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now") today_
-          fromMaybe (postingDate p)  -- XXX shouldn't happen
+        end    = fromMaybe (postingDate p) mperiodorjournallastday
-            mperiodorjournallastday
-          ) p
-        valuenow p = postingValue prices (
-          case today_ of Just d  -> d
-                         Nothing -> error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now"
-          ) p
-        mperiodorjournallastday = mperiodlastday <|> journalEndDate False j
           where
-            -- The last day of the report period.
+            mperiodorjournallastday = mperiodlastday <|> journalEndDate False j
-            -- Will be Nothing if no report period is specified, or also
+              where
-            -- if ReportOpts does not have today_ set, since we need that
+                -- The last day of the report period.
-            -- to get the report period robustly.
+                -- Will be Nothing if no report period is specified, or also
-            mperiodlastday :: Maybe Day = do
+                -- if ReportOpts does not have today_ set, since we need that
-              t <- today_
+                -- to get the report period robustly.
-              let q = queryFromOpts t ropts
+                mperiodlastday :: Maybe Day = do
-              qend <- queryEndDate False q
+                  t <- today_
-              return $ addDays (-1) qend
+                  let q = queryFromOpts t ropts
+                  qend <- queryEndDate False q
+                  return $ addDays (-1) qend
 
 tests_EntriesReport = tests "EntriesReport" [
   tests "entriesReport" [

hledger-lib/Hledger/Reports/MultiBalanceReports.hs

@@ -157,8 +157,9 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
       --   end:  summed/averaged row amounts
       --   date: summed/averaged row amounts
       today = fromMaybe (error' "postingsReport: ReportOpts today_ is unset so could not satisfy --value=now") today_
-      -- Market prices.
+      -- Market prices, commodity display styles.
       prices = journalPrices j
+      styles = journalCommodityStyles j
       -- The last day of each column subperiod.
       lastdays :: [Day] =
         map ((maybe
@@ -273,17 +274,8 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
                    CumulativeChange  -> drop 1 $ scanl (+) 0                      changes
                    HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
              -- The row amounts valued according to --value if needed.
-           , let rowbalsendvalue    = [mixedAmountValue prices periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
+           , let val end = maybe id (mixedAmountApplyValuation prices styles end today multiperiod) value_
-           , let rowbalsdatevalue d = [mixedAmountValue prices d amt             | amt <- rowbals]
+           , let valuedrowbals = dbg1 "valuedrowbals" $ [val periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
-           , let valuedrowbals = dbg1 "valuedrowbals" $ case value_ of
-                   Nothing                            -> rowbals
-                   Just (AtCost _mc)                  -> rowbals   -- cost valuation was handled earlier
-                   Just (AtEnd _mc)                   -> rowbalsendvalue
-                   Just (AtNow _mc)                   -> rowbalsdatevalue today
-                   Just (AtDefault _mc) | multiperiod -> rowbalsendvalue
-                   Just (AtDefault _mc)               -> rowbalsdatevalue today
-                   Just (AtDate d _mc)                -> rowbalsdatevalue d
-
              -- The total and average for the row, and their values.
              -- Total for a cumulative/historical report is always zero.
            , let rowtot = if balancetype_==PeriodChange then sum valuedrowbals else 0

hledger-lib/Hledger/Reports/PostingsReport.hs

@@ -74,6 +74,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
       whichdate = whichDateFromOpts ropts
       depth = queryDepth q
       prices = journalPrices j
+      styles = journalCommodityStyles j
 
       -- postings to be included in the report, and similarly-matched postings before the report start date
       (precedingps, reportps) = matchedPostingsBeforeAndDuring ropts q j reportspan
@@ -91,49 +92,26 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
       --
       --  In all cases, the running total/average is calculated from the above numbers.
       --  "Day before report start" is a bit arbitrary.
-
+      today =
-      today = fromMaybe (error' "postingsReport: ReportOpts today_ is unset so could not satisfy --value=now") today_
+        fromMaybe (error' "postingsReport: ReportOpts today_ is unset so could not satisfy --value=now")
-
+        today_
+      reportperiodlastday =
+        fromMaybe (error' "postingsReport: expected a non-empty journal") $ -- XXX shouldn't happen
+        reportPeriodOrJournalLastDay ropts j
       multiperiod = interval_ /= NoInterval
+      showempty = empty_ || average_
+      pvalue p end = maybe p (postingApplyValuation prices styles end today multiperiod p) value_
 
-      -- Postings, or summary postings along with their subperiod's end date, to be displayed.
+      -- Postings, or summary postings with their subperiod's end date, to be displayed.
-      displayps :: [(Posting, Maybe Day)] =
+      displayps :: [(Posting, Maybe Day)]
-        if multiperiod then
+        | multiperiod = 
-          let
+            let summaryps = summarisePostingsByInterval interval_ whichdate depth showempty reportspan reportps
-            showempty = empty_ || average_
+            in [(pvalue p lastday, Just periodend) | (p, periodend) <- summaryps, let lastday = addDays (-1) periodend]
-            summaryps = summarisePostingsByInterval interval_ whichdate depth showempty reportspan reportps
+        | otherwise =
-            summaryps' = [(p, Just e) | (p,e) <- summaryps]
+            [(pvalue p reportperiodlastday, Nothing) | p <- reportps]
-            summarypsendvalue    = [ (postingValue prices periodlastday p, Just periodend)
-                                   | (p,periodend) <- summaryps
-                                   , let periodlastday = addDays (-1) periodend
-                                   ]
-            summarypsdatevalue d = [(postingValue prices d p, Just periodend) | (p,periodend) <- summaryps]
-          in case value_ of
-            Nothing                            -> summaryps'
-            Just (AtCost _mc)                  -> summaryps'  -- conversion to cost was done earlier
-            Just (AtEnd _mc)                   -> summarypsendvalue
-            Just (AtNow _mc)                   -> summarypsdatevalue today
-            Just (AtDefault _mc) | multiperiod -> summarypsendvalue
-            Just (AtDefault _mc)               -> summarypsdatevalue today
-            Just (AtDate d _mc)                -> summarypsdatevalue d
-        else
-          let
-            reportperiodlastday =
-              fromMaybe (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen
-              $ reportPeriodOrJournalLastDay ropts j
-            reportpsdatevalue d = [(postingValue prices d p, Nothing) | p <- reportps]
-            reportpsnovalue = [(p, Nothing) | p <- reportps]
-          in case value_ of
-            Nothing                            -> reportpsnovalue
-            Just (AtCost _mc)                  -> reportpsnovalue  -- conversion to cost was done earlier
-            Just (AtEnd _mc)                   -> reportpsdatevalue reportperiodlastday
-            Just (AtNow _mc)                   -> reportpsdatevalue today
-            Just (AtDefault _mc) | multiperiod -> reportpsdatevalue reportperiodlastday
-            Just (AtDefault _mc)               -> reportpsdatevalue today
-            Just (AtDate d _mc)                -> reportpsdatevalue d
 
       -- posting report items ready for display
-      items = dbg1 "postingsReport items" $ postingsReportItems displayps (nullposting,Nothing) whichdate depth valuedstartbal runningcalc startnum
+      items = dbg1 "postingsReport items" $ postingsReportItems displayps (nullposting,Nothing) whichdate depth startbalvalued runningcalc startnum
         where
           historical = balancetype_ == HistoricalBalance
           precedingsum = sumPostings precedingps
@@ -142,20 +120,14 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
           startbal | average_  = if historical then precedingavg else 0
                    | otherwise = if historical then precedingsum else 0
           -- For --value=end/now/DATE, convert the initial running total/average to value.
-          startbaldatevalue d = mixedAmountValue prices d startbal
+          startbalvalued = val startbal
-          valuedstartbal = case value_ of
-            Nothing                             -> startbal
-            Just (AtCost _mc)                   -> startbal  -- conversion to cost was done earlier
-            Just (AtEnd  _mc)                   -> startbaldatevalue daybeforereportstart
-            Just (AtNow  _mc)                   -> startbaldatevalue today
-            Just (AtDefault  _mc) | multiperiod -> startbaldatevalue daybeforereportstart
-            Just (AtDefault  _mc)               -> startbaldatevalue today
-            Just (AtDate d _mc)                 -> startbaldatevalue d
             where
-              daybeforereportstart = maybe
+              val = maybe id (mixedAmountApplyValuation prices styles daybeforereportstart today multiperiod) value_
-                                     (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen
+                where
-                                     (addDays (-1))
+                  daybeforereportstart = maybe
-                                     $ reportPeriodOrJournalStart ropts j
+                                         (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen
+                                         (addDays (-1))
+                                         $ reportPeriodOrJournalStart ropts j
 
           startnum = if historical then length precedingps + 1 else 1
           runningcalc = registerRunningCalculationFn ropts

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -78,18 +78,6 @@ data AccountListMode = ALDefault | ALTree | ALFlat deriving (Eq, Show, Data, Typ
 
 instance Default AccountListMode where def = ALDefault
 
--- | What kind of value conversion should be done on amounts ?
--- UI: --value=cost|end|now|DATE[,COMM]
-data ValuationType =
-    AtCost     (Maybe CommoditySymbol)  -- ^ convert to cost commodity using transaction prices, then optionally to given commodity using market prices at posting date
-  | AtEnd      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices at period end(s)
-  | AtNow      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using current market prices
-  | AtDate Day (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices on some date
-  | AtDefault  (Maybe CommoditySymbol)  -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports
-  deriving (Show,Data,Eq) -- Typeable
-
--- instance Default ValuationType where def = AtNow Nothing
-
 -- | Standard options for customising report filtering and output.
 -- Most of these correspond to standard hledger command-line options
 -- or query arguments, but not all. Some are used only by certain