diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs index 59a15164c..978564b90 100644 --- a/Ledger/Amount.hs +++ b/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 diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 8ea27233f..5dcf19c58 100644 --- a/Ledger/Parse.hs +++ b/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)) diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs index d80028eb1..3eb6f76ee 100644 --- a/Ledger/RawLedger.hs +++ b/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. - rawLedgerHistoricalPriceFor :: RawLedger -> Commodity -> Day -> Maybe MixedAmount - rawLedgerHistoricalPriceFor rl Commodity{symbol=s} d = do - let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol1) $ sortBy (comparing hdate) $ historical_prices rl - case ps of (HistoricalPrice {hsymbol2=s, hprice=q}:_) -> Just $ Mixed [Amount{commodity=canonicalcommoditymap ! s,quantity=q,price=Nothing}] + -- | Get the price for a commodity on the specified day from the price database, if known. + -- Does only one lookup step, ie will not look up the price of a price. + rawLedgerHistoricalPriceFor :: RawLedger -> Day -> Commodity -> Maybe MixedAmount + rawLedgerHistoricalPriceFor rl d Commodity{symbol=s} = do + 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] diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 0ceabc3fa..66a87def2 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -101,10 +101,9 @@ data TimeLogEntry = TimeLogEntry { data HistoricalPrice = HistoricalPrice { hdate :: Day, - hsymbol1 :: String, - hsymbol2 :: String, - hprice :: Double - } deriving (Eq,Show) + hsymbol :: String, + hamount :: MixedAmount + } deriving (Eq) -- & Show (in Amount.hs) data RawLedger = RawLedger { modifier_txns :: [ModifierTransaction], diff --git a/Tests.hs b/Tests.hs index 91d7af93f..446071f05 100644 --- a/Tests.hs +++ b/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 = HistoricalPrice (parsedate "2004/05/01") "XYZ" "$" 55 +price1_str = "P 2004/05/01 XYZ $55.00\n" +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]}] diff --git a/tests/price-history.test b/tests/price-history.test new file mode 100644 index 000000000..a62cffd4f --- /dev/null +++ b/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