slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: clarify price types (#131)

Browse Source 
dropped journalPrices

renamed Price to AmountPrice,  AKA "transaction price"

renamed MarketPrice to PriceDirective.

added new MarketPrice (more pure form of PriceDirective without the amount style information)

Prices is now a more efficient data structure, but not used yet.
This commit is contained in:
Simon Michael 2019-06-03 17:26:27 -07:00
parent e24c6292d0
commit adb6ee40eb
17 changed files with 203 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CONTRIBUTING.md
View File

@ -414,7 +414,7 @@ Posting -- MixedAmount
MixedAmount *-- "*" Amount MixedAmount *-- "*" Amount
Amount -- CommoditySymbol Amount -- CommoditySymbol
Amount -- Quantity Amount -- Quantity
Amount -- Price Amount -- AmountPrice
Amount -- AmountStyle Amount -- AmountStyle
</uml> </uml>
--> -->

8
hledger-api/hledger-api.hs
View File

@ -152,7 +152,7 @@ hledgerApiApp staticdir j = Servant.serve api server
where where
accountnamesH = return $ journalAccountNames j accountnamesH = return $ journalAccountNames j
transactionsH = return $ jtxns j transactionsH = return $ jtxns j
pricesH = return $ jmarketprices j pricesH = return $ jpricedirectives j
commoditiesH = return $ (M.keys . jinferredcommodities) j commoditiesH = return $ (M.keys . jinferredcommodities) j
accountsH = return $ ledgerTopAccounts $ ledgerFromJournal Hledger.Query.Any j accountsH = return $ ledgerTopAccounts $ ledgerFromJournal Hledger.Query.Any j
accounttransactionsH (a::AccountName) = do accounttransactionsH (a::AccountName) = do
@ -176,7 +176,7 @@ hledgerApiApp staticdir j = Servant.serve api server
--instance ToJSON DigitGroupStyle where toJSON = genericToJSON defaultOptions --instance ToJSON DigitGroupStyle where toJSON = genericToJSON defaultOptions
--instance ToJSON MixedAmount where toJSON = genericToJSON defaultOptions --instance ToJSON MixedAmount where toJSON = genericToJSON defaultOptions
--instance ToJSON BalanceAssertion where toJSON = genericToJSON defaultOptions --instance ToJSON BalanceAssertion where toJSON = genericToJSON defaultOptions
--instance ToJSON Price where toJSON = genericToJSON defaultOptions --instance ToJSON AmountPrice where toJSON = genericToJSON defaultOptions
--instance ToJSON MarketPrice where toJSON = genericToJSON defaultOptions --instance ToJSON MarketPrice where toJSON = genericToJSON defaultOptions
--instance ToJSON PostingType where toJSON = genericToJSON defaultOptions --instance ToJSON PostingType where toJSON = genericToJSON defaultOptions
--instance ToJSON Posting where --instance ToJSON Posting where
@ -216,7 +216,7 @@ instance ToJSON Side
instance ToJSON DigitGroupStyle instance ToJSON DigitGroupStyle
instance ToJSON MixedAmount instance ToJSON MixedAmount
instance ToJSON BalanceAssertion instance ToJSON BalanceAssertion
instance ToJSON Price instance ToJSON AmountPrice
instance ToJSON MarketPrice instance ToJSON MarketPrice
instance ToJSON PostingType instance ToJSON PostingType
instance ToJSON Posting where instance ToJSON Posting where
@ -262,7 +262,7 @@ instance ToSchema Side
instance ToSchema DigitGroupStyle instance ToSchema DigitGroupStyle
instance ToSchema MixedAmount instance ToSchema MixedAmount
instance ToSchema BalanceAssertion instance ToSchema BalanceAssertion
instance ToSchema Price instance ToSchema AmountPrice
#if MIN_VERSION_swagger2(2,1,5) #if MIN_VERSION_swagger2(2,1,5)
where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
#endif #endif

20
hledger-lib/Hledger/Data/Amount.hs
View File

@ -302,7 +302,7 @@ setMinimalPrecision a = setAmountPrecision normalprecision a
-- appropriate to the current debug level. 9 shows maximum detail. -- appropriate to the current debug level. 9 shows maximum detail.
showAmountDebug :: Amount -> String showAmountDebug :: Amount -> String
showAmountDebug Amount{acommodity="AUTO"} = "(missing)" showAmountDebug Amount{acommodity="AUTO"} = "(missing)"
showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showAmountPriceDebug aprice) (show astyle)
-- | Get the string representation of an amount, without any \@ price. -- | Get the string representation of an amount, without any \@ price.
showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice :: Amount -> String
@ -341,15 +341,15 @@ cshowAmountWithoutPrice a = cshowAmount a{aprice=NoPrice}
showAmountWithoutPriceOrCommodity :: Amount -> String showAmountWithoutPriceOrCommodity :: Amount -> String
showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=NoPrice} showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=NoPrice}
showPrice :: Price -> String showAmountPrice :: AmountPrice -> String
showPrice NoPrice = "" showAmountPrice NoPrice = ""
showPrice (UnitPrice pa) = " @ " ++ showAmount pa showAmountPrice (UnitPrice pa) = " @ " ++ showAmount pa
showPrice (TotalPrice pa) = " @@ " ++ showAmount pa showAmountPrice (TotalPrice pa) = " @@ " ++ showAmount pa
showPriceDebug :: Price -> String showAmountPriceDebug :: AmountPrice -> String
showPriceDebug NoPrice = "" showAmountPriceDebug NoPrice = ""
showPriceDebug (UnitPrice pa) = " @ " ++ showAmountDebug pa showAmountPriceDebug (UnitPrice pa) = " @ " ++ showAmountDebug pa
showPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa showAmountPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa
-- | Given a map of standard amount display styles, apply the appropriate one to this amount. -- | Given a map of standard amount display styles, apply the appropriate one to this amount.
-- If there's no standard style for this amount's commodity, return the amount unchanged. -- If there's no standard style for this amount's commodity, return the amount unchanged.
@ -385,7 +385,7 @@ showAmountHelper showzerocommodity a@Amount{acommodity=c, aprice=p, astyle=Amoun
(quantity',c') | displayingzero && not showzerocommodity = ("0","") (quantity',c') | displayingzero && not showzerocommodity = ("0","")
| otherwise = (quantity, quoteCommoditySymbolIfNeeded c) | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)
space = if not (T.null c') && ascommodityspaced then " " else "" :: String space = if not (T.null c') && ascommodityspaced then " " else "" :: String
price = showPrice p price = showAmountPrice p
-- | Like showAmount, but show a zero amount's commodity if it has one. -- | Like showAmount, but show a zero amount's commodity if it has one.
showAmountWithZeroCommodity :: Amount -> String showAmountWithZeroCommodity :: Amount -> String

62
hledger-lib/Hledger/Data/Journal.hs
View File

@ -16,7 +16,7 @@ other data format (see "Hledger.Read").
module Hledger.Data.Journal ( module Hledger.Data.Journal (
-- * Parsing helpers -- * Parsing helpers
addMarketPrice, addPriceDirective,
addTransactionModifier, addTransactionModifier,
addPeriodicTransaction, addPeriodicTransaction,
addTransaction, addTransaction,
@ -61,7 +61,7 @@ module Hledger.Data.Journal (
journalNextTransaction, journalNextTransaction,
journalPrevTransaction, journalPrevTransaction,
journalPostings, journalPostings,
journalPrices, -- journalPrices,
-- * Standard account types -- * Standard account types
journalBalanceSheetAccountQuery, journalBalanceSheetAccountQuery,
journalProfitAndLossAccountQuery, journalProfitAndLossAccountQuery,
@ -116,7 +116,7 @@ import Hledger.Data.Types
import Hledger.Data.AccountName import Hledger.Data.AccountName
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.Dates import Hledger.Data.Dates
import Hledger.Data.Prices -- import Hledger.Data.Prices
import Hledger.Data.Transaction import Hledger.Data.Transaction
import Hledger.Data.TransactionModifier import Hledger.Data.TransactionModifier
import Hledger.Data.Posting import Hledger.Data.Posting
@ -154,7 +154,7 @@ instance Show Journal where
-- ,show (jtxnmodifiers j) -- ,show (jtxnmodifiers j)
-- ,show (jperiodictxns j) -- ,show (jperiodictxns j)
-- ,show $ jparsetimeclockentries j -- ,show $ jparsetimeclockentries j
-- ,show $ jmarketprices j -- ,show $ jpricedirectives j
-- ,show $ jfinalcommentlines j -- ,show $ jfinalcommentlines j
-- ,show $ jparsestate j -- ,show $ jparsestate j
-- ,show $ map fst $ jfiles j -- ,show $ map fst $ jfiles j
@ -184,7 +184,7 @@ instance Sem.Semigroup Journal where
,jdeclaredaccounttypes = jdeclaredaccounttypes j1 <> jdeclaredaccounttypes j2 ,jdeclaredaccounttypes = jdeclaredaccounttypes j1 <> jdeclaredaccounttypes j2
,jcommodities = jcommodities j1 <> jcommodities j2 ,jcommodities = jcommodities j1 <> jcommodities j2
,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2 ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
,jmarketprices = jmarketprices j1 <> jmarketprices j2 ,jpricedirectives = jpricedirectives j1 <> jpricedirectives j2
,jtxnmodifiers = jtxnmodifiers j1 <> jtxnmodifiers j2 ,jtxnmodifiers = jtxnmodifiers j1 <> jtxnmodifiers j2
,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2 ,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2
,jtxns = jtxns j1 <> jtxns j2 ,jtxns = jtxns j1 <> jtxns j2
@ -213,7 +213,7 @@ nulljournal = Journal {
,jdeclaredaccounttypes = M.empty ,jdeclaredaccounttypes = M.empty
,jcommodities = M.empty ,jcommodities = M.empty
,jinferredcommodities = M.empty ,jinferredcommodities = M.empty
,jmarketprices = [] ,jpricedirectives = []
,jtxnmodifiers = [] ,jtxnmodifiers = []
,jperiodictxns = [] ,jperiodictxns = []
,jtxns = [] ,jtxns = []
@ -240,8 +240,8 @@ addTransactionModifier mt j = j { jtxnmodifiers = mt : jtxnmodifiers j }
addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal
addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j } addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j }
addMarketPrice :: MarketPrice -> Journal -> Journal addPriceDirective :: PriceDirective -> Journal -> Journal
addMarketPrice h j = j { jmarketprices = h : jmarketprices j } -- XXX #999 keep sorted addPriceDirective h j = j { jpricedirectives = h : jpricedirectives j } -- XXX #999 keep sorted
-- | Get the transaction with this index (its 1-based position in the input stream), if any. -- | Get the transaction with this index (its 1-based position in the input stream), if any.
journalTransactionAt :: Journal -> Integer -> Maybe Transaction journalTransactionAt :: Journal -> Integer -> Maybe Transaction
@ -556,7 +556,7 @@ journalReverse j =
,jtxns = reverse $ jtxns j ,jtxns = reverse $ jtxns j
,jtxnmodifiers = reverse $ jtxnmodifiers j ,jtxnmodifiers = reverse $ jtxnmodifiers j
,jperiodictxns = reverse $ jperiodictxns j ,jperiodictxns = reverse $ jperiodictxns j
,jmarketprices = reverse $ jmarketprices j ,jpricedirectives = reverse $ jpricedirectives j
} }
-- | Set this journal's last read time, ie when its files were last read. -- | Set this journal's last read time, ie when its files were last read.
@ -908,16 +908,16 @@ checkBalanceAssignmentUnassignableAccountB p = do
-- a commodity format directive, or otherwise inferred from posting -- a commodity format directive, or otherwise inferred from posting
-- amounts as in hledger < 0.28. -- amounts as in hledger < 0.28.
journalApplyCommodityStyles :: Journal -> Journal journalApplyCommodityStyles :: Journal -> Journal
journalApplyCommodityStyles j@Journal{jtxns=ts, jmarketprices=mps} = j'' journalApplyCommodityStyles j@Journal{jtxns=ts, jpricedirectives=pds} = j''
where where
j' = journalInferCommodityStyles j j' = journalInferCommodityStyles j
styles = journalCommodityStyles j' styles = journalCommodityStyles j'
j'' = j'{jtxns=map fixtransaction ts, jmarketprices=map fixmarketprice mps} j'' = j'{jtxns=map fixtransaction ts, jpricedirectives=map fixpricedirective pds}
fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
fixposting p = p{pamount=styleMixedAmount styles $ pamount p fixposting p = p{pamount=styleMixedAmount styles $ pamount p
,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p} ,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p}
fixbalanceassertion ba = ba{baamount=styleAmount styles $ baamount ba} fixbalanceassertion ba = ba{baamount=styleAmount styles $ baamount ba}
fixmarketprice mp@MarketPrice{mpamount=a} = mp{mpamount=styleAmount styles a} fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmount styles a}
-- | Get all the amount styles defined in this journal, either declared by -- | Get all the amount styles defined in this journal, either declared by
-- a commodity directive or inferred from amounts, as a map from symbol to style. -- a commodity directive or inferred from amounts, as a map from symbol to style.
@ -963,8 +963,8 @@ canonicalStyleFrom ss@(first:_) = first {asprecision = prec, asdecimalpoint = md
-- [] -> (Just '.', 0) -- [] -> (Just '.', 0)
-- -- | Apply this journal's historical price records to unpriced amounts where possible. -- -- | Apply this journal's historical price records to unpriced amounts where possible.
-- journalApplyMarketPrices :: Journal -> Journal -- journalApplyPriceDirectives :: Journal -> Journal
-- journalApplyMarketPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} -- journalApplyPriceDirectives j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}
-- where -- where
-- fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps} -- fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}
-- where -- where
@ -972,14 +972,14 @@ canonicalStyleFrom ss@(first:_) = first {asprecision = prec, asdecimalpoint = md
-- fixmixedamount (Mixed as) = Mixed $ map fixamount as -- fixmixedamount (Mixed as) = Mixed $ map fixamount as
-- fixamount = fixprice -- fixamount = fixprice
-- fixprice a@Amount{price=Just _} = a -- fixprice a@Amount{price=Just _} = a
-- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalMarketPriceFor j d c} -- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalPriceDirectiveFor j d c}
-- -- | Get the price for a 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.
-- -- Does only one lookup step, ie will not look up the price of a price. -- -- Does only one lookup step, ie will not look up the price of a price.
-- journalMarketPriceFor :: Journal -> Day -> CommoditySymbol -> Maybe MixedAmount -- journalPriceDirectiveFor :: Journal -> Day -> CommoditySymbol -> Maybe MixedAmount
-- journalMarketPriceFor j d CommoditySymbol{symbol=s} = do -- journalPriceDirectiveFor j d CommoditySymbol{symbol=s} = do
-- let ps = reverse $ filter ((<= d).mpdate) $ filter ((s==).hsymbol) $ sortBy (comparing mpdate) $ jmarketprices j -- let ps = reverse $ filter ((<= d).pddate) $ filter ((s==).hsymbol) $ sortBy (comparing pddate) $ jpricedirectives j
-- case ps of (MarketPrice{mpamount=a}:_) -> Just a -- case ps of (PriceDirective{pdamount=a}:_) -> Just a
-- _ -> Nothing -- _ -> Nothing
-- | Convert all this journal's amounts to cost using the transaction prices, if any. -- | Convert all this journal's amounts to cost using the transaction prices, if any.
@ -1037,12 +1037,12 @@ traverseJournalAmounts
=> (Amount -> f Amount) => (Amount -> f Amount)
-> Journal -> f Journal -> Journal -> f Journal
traverseJournalAmounts f j = traverseJournalAmounts f j =
recombine <$> (traverse . mpa) f (jmarketprices j) recombine <$> (traverse . mpa) f (jpricedirectives j)
<*> (traverse . tp . traverse . pamt . maa . traverse) f (jtxns j) <*> (traverse . tp . traverse . pamt . maa . traverse) f (jtxns j)
where where
recombine mps txns = j { jmarketprices = mps, jtxns = txns } recombine mps txns = j { jpricedirectives = mps, jtxns = txns }
-- a bunch of traversals -- a bunch of traversals
mpa g mp = (\amt -> mp { mpamount = amt }) <$> g (mpamount mp) mpa g pd = (\amt -> pd { pdamount = amt }) <$> g (pdamount pd)
tp g t = (\ps -> t { tpostings = ps }) <$> g (tpostings t) tp g t = (\ps -> t { tpostings = ps }) <$> g (tpostings t)
pamt g p = (\amt -> p { pamount = amt }) <$> g (pamount p) pamt g p = (\amt -> p { pamount = amt }) <$> g (pamount p)
maa g (Mixed as) = Mixed <$> g as maa g (Mixed as) = Mixed <$> g as
@ -1098,17 +1098,19 @@ postingPivot fieldortagname p = p{paccount = pivotedacct, poriginal = Just $ ori
postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue) postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue)
postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p
-- | Convert a journal's market price declarations -- -- | Build a database of market prices in effect on the given date,
journalPrices :: Journal -> Prices -- -- from the journal's price directives.
journalPrices = toPrices . jmarketprices -- journalPrices :: Day -> Journal -> Prices
-- journalPrices d = toPrices d . jpricedirectives
-- -- | Render a market price as a P directive. -- -- | Render a market price as a P directive.
-- showMarketPriceDirective :: MarketPrice -> String -- showPriceDirectiveDirective :: PriceDirective -> String
-- showMarketPriceDirective mp = unwords -- showPriceDirectiveDirective pd = unwords
-- [ "P" -- [ "P"
-- , showDate (mpdate mp) -- , showDate (pddate pd)
-- , T.unpack (mpcommodity mp) -- , T.unpack (pdcommodity pd)
-- , (showAmount . setAmountPrecision maxprecision) (mpamount mp) -- , (showAmount . setAmountPrecision maxprecision) (pdamount pd
-- )
-- ] -- ]
-- Misc helpers -- Misc helpers

4
hledger-lib/Hledger/Data/Posting.hs
View File

@ -350,7 +350,7 @@ aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.un
-- Apply a specified valuation to this posting's amount, using the provided -- Apply a specified valuation to this posting's amount, using the provided
-- prices db, commodity styles, period-end/current dates, and whether -- prices db, commodity styles, period-end/current dates, and whether
-- this is for a multiperiod report or not. -- this is for a multiperiod report or not.
postingApplyValuation :: Prices -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting postingApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
postingApplyValuation prices styles periodend today ismultiperiod p v = postingApplyValuation prices styles periodend today ismultiperiod p v =
case v of case v of
AtCost Nothing -> postingToCost styles p AtCost Nothing -> postingToCost styles p
@ -370,7 +370,7 @@ postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a
-- using the given market prices. -- using the given market prices.
-- When market prices available on that date are not sufficient to -- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged. -- calculate the value, amounts are left unchanged.
postingValueAtDate :: Prices -> Maybe CommoditySymbol -> Day -> Posting -> Posting postingValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Posting -> Posting
postingValueAtDate prices mc d p = postingTransformAmount (mixedAmountValueAtDate prices mc d) p postingValueAtDate prices mc d p = postingTransformAmount (mixedAmountValueAtDate prices mc d) p
-- | Apply a transform function to this posting's amount. -- | Apply a transform function to this posting's amount.

171
hledger-lib/Hledger/Data/Prices.hs
View File

@ -5,19 +5,18 @@ convert amounts to value in various ways.
-} -}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Data.Prices ( module Hledger.Data.Prices (
Prices Prices
,nullPrices
,toPrices
,priceLookup
,amountValueAtDate ,amountValueAtDate
,amountApplyValuation ,amountApplyValuation
,mixedAmountValueAtDate ,mixedAmountValueAtDate
,mixedAmountApplyValuation ,mixedAmountApplyValuation
,priceLookup
,tests_Prices ,tests_Prices
) )
where where
@ -34,39 +33,69 @@ import Hledger.Data.Types
import Hledger.Data.Amount import Hledger.Data.Amount
import Hledger.Data.Dates (parsedate) import Hledger.Data.Dates (parsedate)
-- | A database of historical market prices for multiple commodites,
-- allowing fast lookup of exchange rates between commodity pairs on a
-- given date.
data Prices = Prices {
prPrices :: [MarketPrice] -- ^ For now, just a list of price declarations,
-- sorted by date then parse order, then reversed.
}
nullPrices = toPrices []
-- | Convert a list of market prices in declaration order to a 'Prices' db.
toPrices :: [MarketPrice] -> Prices
toPrices declaredprices = Prices{prPrices = reverse $ sortOn mpdate declaredprices}
-- | Reverse a market price from A to B, so that it becomes an equivalent price from B to A.
marketPriceInvert :: MarketPrice -> MarketPrice
marketPriceInvert p@MarketPrice{mpcommodity, mpamount} =
p{ mpcommodity = acommodity mpamount
, mpamount = setMinimalPrecision mpamount{acommodity=mpcommodity, aquantity=1 / aquantity mpamount}
}
tests_marketPriceInvert = tests "marketPriceInvert" [
marketPriceInvert (MarketPrice{mpdate=d "2019-06-01", mpcommodity="A", mpamount=amt "B" 2})
`is` (MarketPrice{mpdate=d "2019-06-01", mpcommodity="B", mpamount=amt "A" 0.5 `withPrecision` 1})
]
d = parsedate d = parsedate
amt c q = nullamt{acommodity=c, aquantity=q} -- amt c q = nullamt{acommodity=c, aquantity=q}
-- | Using the market prices in effect at the given date, find the tests_Prices = tests "Prices" [
-- market value of one unit of a given commodity, in a different tests_priceLookup
-- specified valuation commodity, defaulting to the commodity of the ]
-- most recent applicable price.
------------------------------------------------------------------------------
-- Valuation
-- 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 :: [PriceDirective] -> 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
-- | Find the market value of each component amount in the given
-- commodity, or its default valuation commodity, at the given
-- valuation date, using the given market prices.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
mixedAmountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate prices mc d (Mixed as) = Mixed $ map (amountValueAtDate prices mc d) as
-- | 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.
amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation prices styles periodend today ismultiperiod v a =
case v of
AtCost Nothing -> amountToCost styles a
AtCost mc -> amountValueAtDate prices mc periodend $ amountToCost styles a
AtEnd mc -> amountValueAtDate prices mc periodend a
AtNow mc -> amountValueAtDate prices mc today a
AtDefault mc | ismultiperiod -> amountValueAtDate prices mc periodend a
AtDefault mc -> amountValueAtDate prices mc today a
AtDate d mc -> amountValueAtDate prices mc d a
-- | Find the market value of this amount in the given valuation
-- commodity if any, otherwise the default valuation commodity, at the
-- given valuation date. (The default valuation commodity is the
-- commodity of the latest applicable market price before the
-- valuation date.)
-- If the market prices available on that date are not sufficient to
-- calculate this value, the amount is left unchanged.
amountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate pricedirectives mc d a =
case priceLookup pricedirectives d mc (acommodity a) of
Just v -> v{aquantity=aquantity v * aquantity a}
Nothing -> a
------------------------------------------------------------------------------
-- Market price lookup, naive version
-- | Given a list of price directives in parse order, find the market
-- value at the given date of one unit of a given commodity, in a
-- different specified valuation commodity, defaulting to the
-- commodity of the most recent applicable price.
-- This might be slow if there are many price declarations.
-- --
-- When the valuation commodity is specified, this looks for, in order: -- When the valuation commodity is specified, this looks for, in order:
-- --
@ -91,8 +120,8 @@ amt c q = nullamt{acommodity=c, aquantity=q}
-- if the source commodity and the valuation commodity are the same, -- if the source commodity and the valuation commodity are the same,
-- this returns Nothing. -- this returns Nothing.
-- --
priceLookup :: Prices -> Day -> Maybe CommoditySymbol -> CommoditySymbol -> Maybe Amount priceLookup :: [PriceDirective] -> Day -> Maybe CommoditySymbol -> CommoditySymbol -> Maybe Amount
priceLookup Prices{prPrices} d mto from priceLookup pricedirectives d mto from
| mto == Just from = Nothing | mto == Just from = Nothing
| otherwise = mdirectprice <|> mreverseprice | otherwise = mdirectprice <|> mreverseprice
where where
@ -100,84 +129,38 @@ priceLookup Prices{prPrices} d mto from
dbg4With ( ((lbl++" for "++T.unpack from++" at "++show d++": ") ++) dbg4With ( ((lbl++" for "++T.unpack from++" at "++show d++": ") ++)
. maybe "none" showAmount ) . maybe "none" showAmount )
latestfirst = reverse $ sortOn pddate pricedirectives -- sortOn will preserve parse order within the same date I think
-- Key to commodity symbols: -- Key to commodity symbols:
-- from - commodity we are converting from (looking up a price for) -- from - commodity we are converting from (looking up a price for)
-- mto - commodity we want to convert to, or Nothing meaning use default -- mto - commodity we want to convert to, or Nothing meaning use default
-- pfrom - commodity that this market price converts from -- pfrom - commodity that this market price converts from
-- pto - commodity that this market price converts to -- pto - commodity that this market price converts to
-- prPrices is sorted by date then parse order, reversed. So the -- prPriceDirectives is sorted by date then parse order, reversed. So the
-- first price on or before the valuation date is the effective one. -- first price on or before the valuation date is the effective one.
mdirectprice = mdirectprice =
dbgprice "direct market price" $ dbgprice "direct market price" $
headMay [mpamount | MarketPrice{mpdate, mpcommodity=pfrom, mpamount} <- prPrices headMay [pdamount | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
, let pto = acommodity mpamount , let pto = acommodity pdamount
, mpdate <= d , pddate <= d
, pfrom == from , pfrom == from
, maybe True (== pto) mto , maybe True (== pto) mto
] ]
mreverseprice = mreverseprice =
dbgprice "reverse market price" $ dbgprice "reverse market price" $
headMay [ priceamt headMay [ priceamt
| mp@MarketPrice{mpdate, mpcommodity=pfrom, mpamount} <- prPrices | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
, let pto = acommodity mpamount , let pto = acommodity pdamount
, mpdate <= d , pddate <= d
, pto == from , pto == from
, maybe False (== pfrom) mto -- use reverse prices only when target commodity is explicitly specified , maybe False (== pfrom) mto -- use reverse prices only when target commodity is explicitly specified
, let MarketPrice{mpamount=priceamt} = marketPriceInvert mp , let PriceDirective{pdamount=priceamt} = undefined -- marketPriceInvert mp
] ]
tests_priceLookup = tests "priceLookup" [ tests_priceLookup = tests "priceLookup" [
priceLookup (Prices []) (d "2019-06-01") Nothing "" `is` Nothing priceLookup [] (d "2019-06-01") Nothing "" `is` Nothing
]
-- 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
-- | Find the market value of each component amount in the given
-- commodity, or its default valuation commodity, at the given
-- valuation date, using the given market prices.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
mixedAmountValueAtDate :: Prices -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate prices mc d (Mixed as) = Mixed $ map (amountValueAtDate prices mc d) as
-- | 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.
amountApplyValuation :: Prices -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation prices styles periodend today ismultiperiod v a =
case v of
AtCost Nothing -> amountToCost styles a
AtCost mc -> amountValueAtDate prices mc periodend $ amountToCost styles a
AtEnd mc -> amountValueAtDate prices mc periodend a
AtNow mc -> amountValueAtDate prices mc today a
AtDefault mc | ismultiperiod -> amountValueAtDate prices mc periodend a
AtDefault mc -> amountValueAtDate prices mc today a
AtDate d mc -> amountValueAtDate prices mc d a
-- | Find the market value of this amount in the given valuation
-- commodity if any, otherwise the default valuation commodity, at the
-- given valuation date. (The default valuation commodity is the
-- commodity of the latest applicable market price before the
-- valuation date.)
-- If the market prices available on that date are not sufficient to
-- calculate this value, the amount is left unchanged.
amountValueAtDate :: Prices -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate prices mc d a =
case priceLookup prices d mc (acommodity a) of
Just v -> v{aquantity=aquantity v * aquantity a}
Nothing -> a
tests_Prices = tests "Prices" [
tests_marketPriceInvert
,tests_priceLookup
] ]
------------------------------------------------------------------------------

51
hledger-lib/Hledger/Data/Types.hs
View File

@ -154,12 +154,13 @@ instance ToMarkup Quantity
where where
toMarkup = toMarkup . show toMarkup = toMarkup . show
-- | An amount's price (none, per unit, or total) in another commodity. -- | An amount's per-unit or total cost/selling price in another
-- The price amount should always be positive. -- commodity, as recorded in the journal entry eg with @ or @@.
data Price = NoPrice | UnitPrice Amount | TotalPrice Amount -- Docs call this "transaction price". The amount is always positive.
data AmountPrice = NoPrice | UnitPrice Amount | TotalPrice Amount
deriving (Eq,Ord,Typeable,Data,Generic,Show) deriving (Eq,Ord,Typeable,Data,Generic,Show)
instance NFData Price instance NFData AmountPrice
-- | Display style for an amount. -- | Display style for an amount.
data AmountStyle = AmountStyle { data AmountStyle = AmountStyle {
@ -207,7 +208,7 @@ data Amount = Amount {
aismultiplier :: Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier aismultiplier :: Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier
-- in a TMPostingRule. In a regular Posting, should always be false. -- in a TMPostingRule. In a regular Posting, should always be false.
astyle :: AmountStyle, astyle :: AmountStyle,
aprice :: Price -- ^ the (fixed, transaction-specific) price for this amount, if any aprice :: AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any
} deriving (Eq,Ord,Typeable,Data,Generic,Show) } deriving (Eq,Ord,Typeable,Data,Generic,Show)
instance NFData Amount instance NFData Amount
@ -420,17 +421,40 @@ data TimeclockEntry = TimeclockEntry {
instance NFData TimeclockEntry instance NFData TimeclockEntry
-- | A historical exchange rate between two commodities, eg published -- | A market price declaration made by the journal format's P directive.
-- by a stock exchange or the foreign exchange market. -- It declares two things: a historical exchange rate between two commodities,
-- and an amount display style for the second commodity.
data PriceDirective = PriceDirective {
pddate :: Day
,pdcommodity :: CommoditySymbol
,pdamount :: Amount
} deriving (Eq,Ord,Typeable,Data,Generic,Show)
-- Show instance derived in Amount.hs (XXX why ?)
instance NFData PriceDirective
-- | A historical market price (exchange rate) from one commodity to another.
-- A more concise form of a PriceDirective, without the amount display info.
data MarketPrice = MarketPrice { data MarketPrice = MarketPrice {
mpdate :: Day, mpdate :: Day -- ^ Date on which this price becomes effective.
mpcommodity :: CommoditySymbol, ,mpfrom :: CommoditySymbol -- ^ The commodity being converted from.
mpamount :: Amount ,mpto :: CommoditySymbol -- ^ The commodity being converted to.
} deriving (Eq,Ord,Typeable,Data,Generic) ,mprate :: Quantity -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity.
-- Show instance derived in Amount.hs } deriving (Eq,Ord,Typeable,Data,Generic)
-- Show instance derived in Amount.hs (XXX why ?)
instance NFData MarketPrice instance NFData MarketPrice
-- | A database of the exchange rates between commodity pairs at a given date,
-- organised as maps for efficient lookup.
data Prices = Prices {
prDeclaredPrices ::
M.Map CommoditySymbol -- from commodity A
(M.Map CommoditySymbol -- to commodity B
Quantity) -- exchange rate from A to B (one A is worth this many B)
-- ^ Explicitly declared market prices, as { FROMCOMM : { TOCOMM : RATE } }.
}
-- | What kind of value conversion should be done on amounts ? -- | What kind of value conversion should be done on amounts ?
-- UI: --value=cost|end|now|DATE[,COMM] -- UI: --value=cost|end|now|DATE[,COMM]
data ValuationType = data ValuationType =
@ -465,9 +489,8 @@ data Journal = Journal {
,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts) ,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts)
,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives
,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts TODO misnamed - jusedstyles ,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts TODO misnamed - jusedstyles
,jmarketprices :: [MarketPrice] -- ^ All market price declarations (P directives), in parse order (after journal finalisation). ,jpricedirectives :: [PriceDirective] -- ^ All market price declarations (P directives), in parse order (after journal finalisation).
-- These will be converted to a Prices db for looking up prices by date. -- These will be converted to a Prices db for looking up prices by date.
-- (This field is not date-sorted, to allow monoidally combining finalised journals.)
,jtxnmodifiers :: [TransactionModifier] ,jtxnmodifiers :: [TransactionModifier]
,jperiodictxns :: [PeriodicTransaction] ,jperiodictxns :: [PeriodicTransaction]
,jtxns :: [Transaction] ,jtxns :: [Transaction]

20
hledger-lib/Hledger/Query.hs
View File

@ -43,7 +43,7 @@ module Hledger.Query (
matchesMixedAmount, matchesMixedAmount,
matchesAmount, matchesAmount,
matchesCommodity, matchesCommodity,
matchesMarketPrice, matchesPriceDirective,
words'', words'',
-- * tests -- * tests
tests_Query tests_Query
@ -639,15 +639,15 @@ matchesTags namepat valuepat = not . null . filter (match namepat valuepat)
match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v) match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v)
-- | Does the query match this market price ? -- | Does the query match this market price ?
matchesMarketPrice :: Query -> MarketPrice -> Bool matchesPriceDirective :: Query -> PriceDirective -> Bool
matchesMarketPrice (None) _ = False matchesPriceDirective (None) _ = False
matchesMarketPrice (Not q) p = not $ matchesMarketPrice q p matchesPriceDirective (Not q) p = not $ matchesPriceDirective q p
matchesMarketPrice (Or qs) p = any (`matchesMarketPrice` p) qs matchesPriceDirective (Or qs) p = any (`matchesPriceDirective` p) qs
matchesMarketPrice (And qs) p = all (`matchesMarketPrice` p) qs matchesPriceDirective (And qs) p = all (`matchesPriceDirective` p) qs
matchesMarketPrice q@(Amt _ _) p = matchesAmount q (mpamount p) matchesPriceDirective q@(Amt _ _) p = matchesAmount q (pdamount p)
matchesMarketPrice q@(Sym _) p = matchesCommodity q (mpcommodity p) matchesPriceDirective q@(Sym _) p = matchesCommodity q (pdcommodity p)
matchesMarketPrice (Date span) p = spanContainsDate span (mpdate p) matchesPriceDirective (Date span) p = spanContainsDate span (pddate p)
matchesMarketPrice _ _ = True matchesPriceDirective _ _ = True
-- tests -- tests

2
hledger-lib/Hledger/Read/Common.hs
View File

@ -714,7 +714,7 @@ quotedcommoditysymbolp =
simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar) simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
priceamountp :: JournalParser m Price priceamountp :: JournalParser m AmountPrice
priceamountp = option NoPrice $ do priceamountp = option NoPrice $ do
char '@' char '@'
priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice

14
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -143,7 +143,7 @@ addJournalItemP =
, transactionp >>= modify' . addTransaction , transactionp >>= modify' . addTransaction
, transactionmodifierp >>= modify' . addTransactionModifier , transactionmodifierp >>= modify' . addTransactionModifier
, periodictransactionp >>= modify' . addPeriodicTransaction , periodictransactionp >>= modify' . addPeriodicTransaction
, marketpricedirectivep >>= modify' . addMarketPrice , marketpricedirectivep >>= modify' . addPriceDirective
, void (lift emptyorcommentlinep) , void (lift emptyorcommentlinep)
, void (lift multilinecommentp) , void (lift multilinecommentp)
] <?> "transaction or directive" ] <?> "transaction or directive"
@ -486,7 +486,7 @@ defaultcommoditydirectivep = do
then customFailure $ parseErrorAt off pleaseincludedecimalpoint then customFailure $ parseErrorAt off pleaseincludedecimalpoint
else setDefaultCommodityAndStyle (acommodity, astyle) else setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: JournalParser m MarketPrice marketpricedirectivep :: JournalParser m PriceDirective
marketpricedirectivep = do marketpricedirectivep = do
char 'P' <?> "market price" char 'P' <?> "market price"
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
@ -496,7 +496,7 @@ marketpricedirectivep = do
lift (skipMany spacenonewline) lift (skipMany spacenonewline)
price <- amountp price <- amountp
lift restofline lift restofline
return $ MarketPrice date symbol price return $ PriceDirective date symbol price
ignoredpricecommoditydirectivep :: JournalParser m () ignoredpricecommoditydirectivep :: JournalParser m ()
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
@ -917,10 +917,10 @@ tests_JournalReader = tests "JournalReader" [
,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep ,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep
"P 2017/01/30 BTC $922.83\n" "P 2017/01/30 BTC $922.83\n"
MarketPrice{ PriceDirective{
mpdate = fromGregorian 2017 1 30, pddate = fromGregorian 2017 1 30,
mpcommodity = "BTC", pdcommodity = "BTC",
mpamount = usd 922.83 pdamount = usd 922.83
} }
,test "tagdirectivep" $ do ,test "tagdirectivep" $ do

5
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -64,7 +64,7 @@ flatShowsExclusiveBalance = True
-- This is like PeriodChangeReport with a single column (but more mature, -- This is like PeriodChangeReport with a single column (but more mature,
-- eg this can do hierarchical display). -- eg this can do hierarchical display).
balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReport ropts@ReportOpts{..} q j = balanceReport ropts@ReportOpts{..} q j@Journal{..} =
(if invert_ then brNegate else id) $ (if invert_ then brNegate else id) $
(sorteditems, total) (sorteditems, total)
where where
@ -73,7 +73,6 @@ balanceReport ropts@ReportOpts{..} q j =
today = fromMaybe (error' "balanceReport: ReportOpts today_ is unset so could not satisfy --value=now") today_ today = fromMaybe (error' "balanceReport: ReportOpts today_ is unset so could not satisfy --value=now") today_
multiperiod = interval_ /= NoInterval multiperiod = interval_ /= NoInterval
prices = journalPrices j
styles = journalCommodityStyles j styles = journalCommodityStyles j
-- Get all the summed accounts & balances, according to the query, as an account tree. -- Get all the summed accounts & balances, according to the query, as an account tree.
@ -85,7 +84,7 @@ balanceReport ropts@ReportOpts{..} q j =
where where
valueaccount a@Account{..} = a{aebalance=val aebalance, aibalance=val aibalance} valueaccount a@Account{..} = a{aebalance=val aebalance, aibalance=val aibalance}
where where
val = maybe id (mixedAmountApplyValuation prices styles periodlastday today multiperiod) value_ val = maybe id (mixedAmountApplyValuation jpricedirectives styles periodlastday today multiperiod) value_
where where
periodlastday = periodlastday =
fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen

3
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -38,10 +38,9 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
sortBy (comparing datefn) $ filter (q `matchesTransaction`) $ map tvalue jtxns sortBy (comparing datefn) $ filter (q `matchesTransaction`) $ map tvalue jtxns
where where
datefn = transactionDateFn ropts datefn = transactionDateFn ropts
prices = journalPrices j
styles = journalCommodityStyles j styles = journalCommodityStyles j
tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings} tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings}
pvalue p = maybe p (postingApplyValuation prices styles end today False p) value_ pvalue p = maybe p (postingApplyValuation jpricedirectives styles end today False p) value_
where where
today = fromMaybe (error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now") today_ today = fromMaybe (error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now") today_
end = fromMaybe (postingDate p) mperiodorjournallastday end = fromMaybe (postingDate p) mperiodorjournallastday

3
hledger-lib/Hledger/Reports/MultiBalanceReports.hs
View File

@ -158,7 +158,6 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
-- date: summed/averaged row amounts -- date: summed/averaged row amounts
today = fromMaybe (error' "postingsReport: ReportOpts today_ is unset so could not satisfy --value=now") today_ today = fromMaybe (error' "postingsReport: ReportOpts today_ is unset so could not satisfy --value=now") today_
-- Market prices, commodity display styles. -- Market prices, commodity display styles.
prices = journalPrices j
styles = journalCommodityStyles j styles = journalCommodityStyles j
-- The last day of each column subperiod. -- The last day of each column subperiod.
lastdays :: [Day] = lastdays :: [Day] =
@ -274,7 +273,7 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
CumulativeChange -> drop 1 $ scanl (+) 0 changes CumulativeChange -> drop 1 $ scanl (+) 0 changes
HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
-- The row amounts valued according to --value if needed. -- The row amounts valued according to --value if needed.
, let val end = maybe id (mixedAmountApplyValuation prices styles end today multiperiod) value_ , let val end = maybe id (mixedAmountApplyValuation jpricedirectives styles end today multiperiod) value_
, let valuedrowbals = dbg1 "valuedrowbals" $ [val periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays] , let valuedrowbals = dbg1 "valuedrowbals" $ [val periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
-- The total and average for the row, and their values. -- The total and average for the row, and their values.
-- Total for a cumulative/historical report is always zero. -- Total for a cumulative/historical report is always zero.

5
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -73,7 +73,6 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
reportspan = adjustReportDates ropts q j reportspan = adjustReportDates ropts q j
whichdate = whichDateFromOpts ropts whichdate = whichDateFromOpts ropts
depth = queryDepth q depth = queryDepth q
prices = journalPrices j
styles = journalCommodityStyles j styles = journalCommodityStyles j
-- postings to be included in the report, and similarly-matched postings before the report start date -- postings to be included in the report, and similarly-matched postings before the report start date
@ -100,7 +99,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
reportPeriodOrJournalLastDay ropts j reportPeriodOrJournalLastDay ropts j
multiperiod = interval_ /= NoInterval multiperiod = interval_ /= NoInterval
showempty = empty_ || average_ showempty = empty_ || average_
pvalue p end = maybe p (postingApplyValuation prices styles end today multiperiod p) value_ pvalue p end = maybe p (postingApplyValuation jpricedirectives styles end today multiperiod p) value_
-- Postings, or summary postings 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)]
@ -122,7 +121,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
-- For --value=end/now/DATE, convert the initial running total/average to value. -- For --value=end/now/DATE, convert the initial running total/average to value.
startbalvalued = val startbal startbalvalued = val startbal
where where
val = maybe id (mixedAmountApplyValuation prices styles daybeforereportstart today multiperiod) value_ val = maybe id (mixedAmountApplyValuation jpricedirectives styles daybeforereportstart today multiperiod) value_
where where
daybeforereportstart = maybe daybeforereportstart = maybe
(error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen

2
hledger-web/Hledger/Web/Handler/MiscR.hs
View File

@ -69,7 +69,7 @@ getPricesR = do
VD{caps, j} <- getViewData VD{caps, j} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability") when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
selectRep $ do selectRep $ do
provideJson $ jmarketprices j provideJson $ jpricedirectives j
getCommoditiesR :: Handler TypedContent getCommoditiesR :: Handler TypedContent
getCommoditiesR = do getCommoditiesR = do

4
hledger-web/Hledger/Web/Json.hs
View File

@ -51,7 +51,7 @@ instance ToJSON Side
instance ToJSON DigitGroupStyle instance ToJSON DigitGroupStyle
instance ToJSON MixedAmount instance ToJSON MixedAmount
instance ToJSON BalanceAssertion instance ToJSON BalanceAssertion
instance ToJSON Price instance ToJSON AmountPrice
instance ToJSON MarketPrice instance ToJSON MarketPrice
instance ToJSON PostingType instance ToJSON PostingType
@ -103,7 +103,7 @@ instance FromJSON Side
instance FromJSON DigitGroupStyle instance FromJSON DigitGroupStyle
instance FromJSON MixedAmount instance FromJSON MixedAmount
instance FromJSON BalanceAssertion instance FromJSON BalanceAssertion
instance FromJSON Price instance FromJSON AmountPrice
instance FromJSON MarketPrice instance FromJSON MarketPrice
instance FromJSON PostingType instance FromJSON PostingType
instance FromJSON Posting instance FromJSON Posting

24
hledger/Hledger/Cli/Commands/Prices.hs
View File

@ -28,20 +28,20 @@ prices opts j = do
let let
q = queryFromOpts d (reportopts_ opts) q = queryFromOpts d (reportopts_ opts)
ps = filter (matchesPosting q) $ allPostings j ps = filter (matchesPosting q) $ allPostings j
mprices = jmarketprices j mprices = jpricedirectives j
cprices = concatMap postingCosts ps cprices = concatMap postingCosts ps
icprices = concatMap postingCosts . mapAmount invertPrice $ ps icprices = concatMap postingCosts . mapAmount invertPrice $ ps
allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices
mapM_ (putStrLn . showPrice) $ mapM_ (putStrLn . showPriceDirective) $
sortOn mpdate $ sortOn pddate $
filter (matchesMarketPrice q) $ filter (matchesPriceDirective q) $
allprices allprices
where where
ifBoolOpt opt | boolopt opt $ rawopts_ opts = id ifBoolOpt opt | boolopt opt $ rawopts_ opts = id
| otherwise = const [] | otherwise = const []
showPrice :: MarketPrice -> String showPriceDirective :: PriceDirective -> String
showPrice mp = unwords ["P", show $ mpdate mp, T.unpack . quoteCommoditySymbolIfNeeded $ mpcommodity mp, showAmountWithZeroCommodity $ mpamount mp] showPriceDirective mp = unwords ["P", show $ pddate mp, T.unpack . quoteCommoditySymbolIfNeeded $ pdcommodity mp, showAmountWithZeroCommodity $ pdamount mp]
divideAmount' :: Quantity -> Amount -> Amount divideAmount' :: Quantity -> Amount -> Amount
divideAmount' n a = a' where divideAmount' n a = a' where
@ -50,7 +50,9 @@ divideAmount' n a = a' where
extPrecision = (1+) . floor . logBase 10 $ (realToFrac n :: Double) extPrecision = (1+) . floor . logBase 10 $ (realToFrac n :: Double)
precision' = extPrecision + asprecision (astyle a) precision' = extPrecision + asprecision (astyle a)
-- | Invert an amount's price for --invert-cost, somehow (? unclear XXX) -- XXX
-- | Invert an amount's price for --invert-cost, somehow ? Unclear.
invertPrice :: Amount -> Amount invertPrice :: Amount -> Amount
invertPrice a = invertPrice a =
case aprice a of case aprice a of
@ -63,16 +65,16 @@ invertPrice a =
a { aquantity = aquantity pa * signum (aquantity a), acommodity = acommodity pa, aprice = TotalPrice pa' } where a { aquantity = aquantity pa * signum (aquantity a), acommodity = acommodity pa, aprice = TotalPrice pa' } where
pa' = pa { aquantity = abs $ aquantity a, acommodity = acommodity a, aprice = NoPrice, astyle = astyle a } pa' = pa { aquantity = abs $ aquantity a, acommodity = acommodity a, aprice = NoPrice, astyle = astyle a }
amountCost :: Day -> Amount -> Maybe MarketPrice amountCost :: Day -> Amount -> Maybe PriceDirective
amountCost d a = amountCost d a =
case aprice a of case aprice a of
NoPrice -> Nothing NoPrice -> Nothing
UnitPrice pa -> Just UnitPrice pa -> Just
MarketPrice { mpdate = d, mpcommodity = acommodity a, mpamount = pa } PriceDirective { pddate = d, pdcommodity = acommodity a, pdamount = pa }
TotalPrice pa -> Just TotalPrice pa -> Just
MarketPrice { mpdate = d, mpcommodity = acommodity a, mpamount = abs (aquantity a) `divideAmount'` pa } PriceDirective { pddate = d, pdcommodity = acommodity a, pdamount = abs (aquantity a) `divideAmount'` pa }
postingCosts :: Posting -> [MarketPrice] postingCosts :: Posting -> [PriceDirective]
postingCosts p = mapMaybe (amountCost date) . amounts $ pamount p where postingCosts p = mapMaybe (amountCost date) . amounts $ pamount p where
date = fromMaybe (tdate . fromJust $ ptransaction p) $ pdate p date = fromMaybe (tdate . fromJust $ ptransaction p) $ pdate p