make historical prices more robust, fix a runtime Map.find error

Ledger/Amount.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
 {-|
 An 'Amount' is some quantity of money, shares, or anything else.
 
@@ -46,6 +47,7 @@ import Ledger.Commodity
 
 instance Show Amount where show = showAmount
 instance Show MixedAmount where show = showMixedAmount
+deriving instance Show HistoricalPrice
 
 instance Num Amount where
     abs (Amount c q p) = Amount c (abs q) p

Ledger/Parse.hs

@@ -291,11 +291,11 @@ ledgerHistoricalPrice = do
   many spacenonewline
   date <- ledgerdate
   many1 spacenonewline
-  symbol1 <- commoditysymbol
+  symbol <- commoditysymbol
   many spacenonewline
-  (Mixed [Amount c q _]) <- someamount
+  price <- someamount
   restofline
-  return $ HistoricalPrice date symbol1 (symbol c) q
+  return $ HistoricalPrice date symbol price
 
 -- like ledgerAccountBegin, updates the LedgerFileCtx
 ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))

Ledger/RawLedger.hs

@@ -8,7 +8,7 @@ the cached 'Ledger'.
 module Ledger.RawLedger
 where
 import qualified Data.Map as Map
-import Data.Map ((!))
+import Data.Map (findWithDefault, (!))
 import System.Time (ClockTime(TOD))
 import Ledger.Utils
 import Ledger.Types
@@ -135,6 +135,7 @@ rawLedgerSelectingDate EffectiveDate rl =
 -- detected.
 -- Also, missing unit prices are added if known from the price history.
 -- Also, amounts are converted to cost basis if that flag is active.
+-- XXX refactor
 canonicaliseAmounts :: Bool -> RawLedger -> RawLedger
 canonicaliseAmounts costbasis rl@(RawLedger ms ps ts tls hs f fp ft) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp ft
     where
@@ -153,16 +154,23 @@ canonicaliseAmounts costbasis rl@(RawLedger ms ps ts tls hs f fp ft) = RawLedger
             commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]
             commoditieswithsymbol s = filter ((s==) . symbol) commodities
             commoditysymbols = nub $ map symbol commodities
-            commodities = map commodity $ concatMap (amounts . tamount) $ rawLedgerTransactions rl
+            commodities = map commodity (concatMap (amounts . tamount) (rawLedgerTransactions rl)
+                                         ++ concatMap (amounts . hamount) (historical_prices rl))
+            fixprice :: Amount -> Amount
             fixprice a@Amount{price=Just _} = a
-            fixprice a@Amount{commodity=c} = a{price=rawLedgerHistoricalPriceFor rl c d}
+            fixprice a@Amount{commodity=c} = a{price=rawLedgerHistoricalPriceFor rl d c}
 
-            -- | Get the price for commodity on the specified day from the price database, if known.
+            -- | Get the price for a commodity on the specified day from the price database, if known.
-            rawLedgerHistoricalPriceFor :: RawLedger -> Commodity -> Day -> Maybe MixedAmount
+            -- Does only one lookup step, ie will not look up the price of a price.
-            rawLedgerHistoricalPriceFor rl Commodity{symbol=s} d = do
+            rawLedgerHistoricalPriceFor :: RawLedger -> Day -> Commodity -> Maybe MixedAmount
-              let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol1) $ sortBy (comparing hdate) $ historical_prices rl
+            rawLedgerHistoricalPriceFor rl d Commodity{symbol=s} = do
-              case ps of (HistoricalPrice {hsymbol2=s, hprice=q}:_) -> Just $ Mixed [Amount{commodity=canonicalcommoditymap ! s,quantity=q,price=Nothing}]
+              let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices rl
+              case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a
                          _ -> Nothing
+                  where
+                    canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as
+                        where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} =
+                                  a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap}
 
 -- | Get just the amounts from a ledger, in the order parsed.
 rawLedgerAmounts :: RawLedger -> [MixedAmount]

Ledger/Types.hs

@@ -101,10 +101,9 @@ data TimeLogEntry = TimeLogEntry {
 
 data HistoricalPrice = HistoricalPrice {
       hdate :: Day,
-      hsymbol1 :: String,
+      hsymbol :: String,
-      hsymbol2 :: String,
+      hamount :: MixedAmount
-      hprice :: Double
+    } deriving (Eq) -- & Show (in Amount.hs)
-    } deriving (Eq,Show)
 
 data RawLedger = RawLedger {
       modifier_txns :: [ModifierTransaction],

Tests.hs

@@ -1387,8 +1387,8 @@ timelogentry1 = TimeLogEntry In (parsedatetime "2007/03/11 16:19:00") "hledger"
 timelogentry2_str  = "o 2007/03/11 16:30:00\n"
 timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""
 
-price1_str = "P 2004/05/01 XYZ $55\n"
+price1_str = "P 2004/05/01 XYZ $55.00\n"
-price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" "$" 55
+price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]
 
 a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}]
 a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]

tests/price-history.test

@@ -0,0 +1,14 @@
+-f - print
+<<<
+P 2009/1/1 p 0.5h
+
+2009/1/1 t
+ a    1p
+ b
+
+>>>
+2009/01/01 t
+    a     1p @ 0.5h
+    b    -1p @ 0.5h
+
+>>>2