1{-# LANGUAGE TemplateHaskell #-} 2 3module Hledger.Cli.Commands.Prices ( 4 pricesmode 5 ,prices 6) 7where 8 9import qualified Data.Map as M 10import Data.Maybe 11import Data.List 12import qualified Data.Text as T 13import Data.Time 14import Hledger 15import Hledger.Cli.CliOptions 16import System.Console.CmdArgs.Explicit 17 18pricesmode = hledgerCommandMode 19 $(embedFileRelative "Hledger/Cli/Commands/Prices.txt") 20 [flagNone ["costs"] (setboolopt "costs") "print transaction prices from postings" 21 ,flagNone ["inverted-costs"] (setboolopt "inverted-costs") "print transaction inverted prices from postings also"] 22 [generalflagsgroup1] 23 hiddenflags 24 ([], Just $ argsFlag "[QUERY]") 25 26-- XXX the original hledger-prices script always ignored assertions 27prices opts j = do 28 d <- getCurrentDay 29 let 30 styles = journalCommodityStyles j 31 q = queryFromOpts d (reportopts_ opts) 32 ps = filter (matchesPosting q) $ allPostings j 33 mprices = jpricedirectives j 34 cprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts ps 35 icprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts $ mapAmount invertPrice ps 36 allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices 37 mapM_ (putStrLn . showPriceDirective) $ 38 sortOn pddate $ 39 filter (matchesPriceDirective q) $ 40 allprices 41 where 42 ifBoolOpt opt | boolopt opt $ rawopts_ opts = id 43 | otherwise = const [] 44 45showPriceDirective :: PriceDirective -> String 46showPriceDirective mp = unwords ["P", show $ pddate mp, T.unpack . quoteCommoditySymbolIfNeeded $ pdcommodity mp, showAmountWithZeroCommodity $ pdamount mp] 47 48divideAmount' :: Quantity -> Amount -> Amount 49divideAmount' n a = a' where 50 a' = (n `divideAmount` a) { astyle = style' } 51 style' = (astyle a) { asprecision = precision' } 52 extPrecision = (1+) . floor . logBase 10 $ (realToFrac n :: Double) 53 precision' = case asprecision (astyle a) of 54 NaturalPrecision -> NaturalPrecision 55 Precision p -> Precision $ extPrecision + p 56 57-- XXX 58 59-- | Invert an amount's price for --invert-cost, somehow ? Unclear. 60invertPrice :: Amount -> Amount 61invertPrice a = 62 case aprice a of 63 Nothing -> a 64 Just (UnitPrice pa) -> invertPrice 65 -- normalize to TotalPrice 66 a { aprice = Just $ TotalPrice pa' } where 67 pa' = ((1 / aquantity a) `divideAmount` pa) { aprice = Nothing } 68 Just (TotalPrice pa) -> 69 a { aquantity = aquantity pa * signum (aquantity a), acommodity = acommodity pa, aprice = Just $ TotalPrice pa' } where 70 pa' = pa { aquantity = abs $ aquantity a, acommodity = acommodity a, aprice = Nothing, astyle = astyle a } 71 72postingsPriceDirectivesFromCosts :: Posting -> [PriceDirective] 73postingsPriceDirectivesFromCosts p = mapMaybe (amountPriceDirectiveFromCost date) . amounts $ pamount p where 74 date = fromMaybe (tdate . fromJust $ ptransaction p) $ pdate p 75 76amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective 77amountPriceDirectiveFromCost d a = 78 case aprice a of 79 Nothing -> Nothing 80 Just (UnitPrice pa) -> Just 81 PriceDirective { pddate = d, pdcommodity = acommodity a, pdamount = pa } 82 Just (TotalPrice pa) -> Just 83 PriceDirective { pddate = d, pdcommodity = acommodity a, pdamount = abs (aquantity a) `divideAmount'` pa } 84 85-- | Given a map of standard amount display styles, apply the 86-- appropriate one, if any, to this price directive's amount. 87-- But keep the number of decimal places unchanged. 88stylePriceDirectiveExceptPrecision :: M.Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective 89stylePriceDirectiveExceptPrecision styles pd@PriceDirective{pdamount=a} = 90 pd{pdamount = styleAmountExceptPrecision styles a} 91 92allPostings :: Journal -> [Posting] 93allPostings = concatMap tpostings . jtxns 94 95mapAmount :: (Amount -> Amount) -> [Posting] -> [Posting] 96mapAmount f = map pf where 97 pf p = p { pamount = mf (pamount p) } 98 mf = mixed . map f . amounts 99