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