{-# LANGUAGE TemplateHaskell #-}

module Hledger.Cli.Commands.Prices (
  pricesmode
 ,prices
)
where

import qualified Data.Map as M
import Data.Maybe
import Data.List
import qualified Data.Text as T
import Data.Time
import Hledger
import Hledger.Cli.CliOptions
import System.Console.CmdArgs.Explicit

pricesmode :: Mode RawOpts
pricesmode = CommandDoc
-> [Flag RawOpts]
-> [(CommandDoc, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Prices.txt")
  [[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone [CommandDoc
"costs"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"costs") CommandDoc
"print transaction prices from postings"
  ,[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone [CommandDoc
"inverted-costs"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"inverted-costs") CommandDoc
"print transaction inverted prices from postings also"]
  [(CommandDoc, [Flag RawOpts])
generalflagsgroup1]
  [Flag RawOpts]
hiddenflags
  ([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Arg RawOpts
argsFlag CommandDoc
"[QUERY]")

-- XXX the original hledger-prices script always ignored assertions
prices :: CliOpts -> Journal -> IO ()
prices CliOpts
opts Journal
j = do
  let
    styles :: Map CommoditySymbol AmountStyle
styles     = Journal -> Map CommoditySymbol AmountStyle
journalCommodityStyles Journal
j
    q :: Query
q          = ReportSpec -> Query
rsQuery (ReportSpec -> Query) -> ReportSpec -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportSpec
reportspec_ CliOpts
opts
    ps :: [Posting]
ps         = (Posting -> Bool) -> [Posting] -> [Posting]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query -> Posting -> Bool
matchesPosting Query
q) ([Posting] -> [Posting]) -> [Posting] -> [Posting]
forall a b. (a -> b) -> a -> b
$ Journal -> [Posting]
allPostings Journal
j
    mprices :: [PriceDirective]
mprices    = Journal -> [PriceDirective]
jpricedirectives Journal
j
    cprices :: [PriceDirective]
cprices    = (PriceDirective -> PriceDirective)
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> [a] -> [b]
map (Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
stylePriceDirectiveExceptPrecision Map CommoditySymbol AmountStyle
styles) ([PriceDirective] -> [PriceDirective])
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$ (Posting -> [PriceDirective]) -> [Posting] -> [PriceDirective]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Posting -> [PriceDirective]
postingsPriceDirectivesFromCosts [Posting]
ps
    icprices :: [PriceDirective]
icprices   = (PriceDirective -> PriceDirective)
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> [a] -> [b]
map (Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
stylePriceDirectiveExceptPrecision Map CommoditySymbol AmountStyle
styles) ([PriceDirective] -> [PriceDirective])
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$ (Posting -> [PriceDirective]) -> [Posting] -> [PriceDirective]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Posting -> [PriceDirective]
postingsPriceDirectivesFromCosts ([Posting] -> [PriceDirective]) -> [Posting] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$ (Amount -> Amount) -> [Posting] -> [Posting]
mapAmount Amount -> Amount
invertPrice [Posting]
ps
    allprices :: [PriceDirective]
allprices  = [PriceDirective]
mprices [PriceDirective] -> [PriceDirective] -> [PriceDirective]
forall a. [a] -> [a] -> [a]
++ CommandDoc -> [PriceDirective] -> [PriceDirective]
forall a. CommandDoc -> [a] -> [a]
ifBoolOpt CommandDoc
"costs" [PriceDirective]
cprices [PriceDirective] -> [PriceDirective] -> [PriceDirective]
forall a. [a] -> [a] -> [a]
++ CommandDoc -> [PriceDirective] -> [PriceDirective]
forall a. CommandDoc -> [a] -> [a]
ifBoolOpt CommandDoc
"inverted-costs" [PriceDirective]
icprices
  (PriceDirective -> IO ()) -> [PriceDirective] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandDoc -> IO ()
putStrLn (CommandDoc -> IO ())
-> (PriceDirective -> CommandDoc) -> PriceDirective -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PriceDirective -> CommandDoc
showPriceDirective) ([PriceDirective] -> IO ()) -> [PriceDirective] -> IO ()
forall a b. (a -> b) -> a -> b
$
    (PriceDirective -> Day) -> [PriceDirective] -> [PriceDirective]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn PriceDirective -> Day
pddate ([PriceDirective] -> [PriceDirective])
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$
    (PriceDirective -> Bool) -> [PriceDirective] -> [PriceDirective]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query -> PriceDirective -> Bool
matchesPriceDirective Query
q) ([PriceDirective] -> [PriceDirective])
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$
    [PriceDirective]
allprices
  where
    ifBoolOpt :: CommandDoc -> [a] -> [a]
ifBoolOpt CommandDoc
opt | CommandDoc -> RawOpts -> Bool
boolopt CommandDoc
opt (RawOpts -> Bool) -> RawOpts -> Bool
forall a b. (a -> b) -> a -> b
$ CliOpts -> RawOpts
rawopts_ CliOpts
opts = [a] -> [a]
forall a. a -> a
id
                  | Bool
otherwise = [a] -> [a] -> [a]
forall a b. a -> b -> a
const []

showPriceDirective :: PriceDirective -> String
showPriceDirective :: PriceDirective -> CommandDoc
showPriceDirective PriceDirective
mp = [CommandDoc] -> CommandDoc
unwords [CommandDoc
"P", Day -> CommandDoc
forall a. Show a => a -> CommandDoc
show (Day -> CommandDoc) -> Day -> CommandDoc
forall a b. (a -> b) -> a -> b
$ PriceDirective -> Day
pddate PriceDirective
mp, CommoditySymbol -> CommandDoc
T.unpack (CommoditySymbol -> CommandDoc)
-> (CommoditySymbol -> CommoditySymbol)
-> CommoditySymbol
-> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommoditySymbol -> CommoditySymbol
quoteCommoditySymbolIfNeeded (CommoditySymbol -> CommandDoc) -> CommoditySymbol -> CommandDoc
forall a b. (a -> b) -> a -> b
$ PriceDirective -> CommoditySymbol
pdcommodity PriceDirective
mp, Amount -> CommandDoc
showAmountWithZeroCommodity (Amount -> CommandDoc) -> Amount -> CommandDoc
forall a b. (a -> b) -> a -> b
$ PriceDirective -> Amount
pdamount PriceDirective
mp]

divideAmount' :: Quantity -> Amount -> Amount
divideAmount' :: Quantity -> Amount -> Amount
divideAmount' Quantity
n Amount
a = Amount
a' where
    a' :: Amount
a' = (Quantity
n Quantity -> Amount -> Amount
`divideAmount` Amount
a) { astyle :: AmountStyle
astyle = AmountStyle
style' }
    style' :: AmountStyle
style' = (Amount -> AmountStyle
astyle Amount
a) { asprecision :: AmountPrecision
asprecision = AmountPrecision
precision' }
    extPrecision :: Word8
extPrecision = (Word8
1Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+) (Word8 -> Word8) -> (Double -> Word8) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Word8) -> (Double -> Double) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10 (Double -> Word8) -> Double -> Word8
forall a b. (a -> b) -> a -> b
$ (Quantity -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Quantity
n :: Double)
    precision' :: AmountPrecision
precision' = case AmountStyle -> AmountPrecision
asprecision (Amount -> AmountStyle
astyle Amount
a) of
                      AmountPrecision
NaturalPrecision -> AmountPrecision
NaturalPrecision
                      Precision Word8
p      -> Word8 -> AmountPrecision
Precision (Word8 -> AmountPrecision) -> Word8 -> AmountPrecision
forall a b. (a -> b) -> a -> b
$ Word8
extPrecision Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
p

-- XXX

-- | Invert an amount's price for --invert-cost, somehow ? Unclear.
invertPrice :: Amount -> Amount
invertPrice :: Amount -> Amount
invertPrice Amount
a =
    case Amount -> Maybe AmountPrice
aprice Amount
a of
        Maybe AmountPrice
Nothing -> Amount
a
        Just (UnitPrice Amount
pa) -> Amount -> Amount
invertPrice
            -- normalize to TotalPrice
            Amount
a { aprice :: Maybe AmountPrice
aprice = AmountPrice -> Maybe AmountPrice
forall a. a -> Maybe a
Just (AmountPrice -> Maybe AmountPrice)
-> AmountPrice -> Maybe AmountPrice
forall a b. (a -> b) -> a -> b
$ Amount -> AmountPrice
TotalPrice Amount
pa' } where
                pa' :: Amount
pa' = ((Quantity
1 Quantity -> Quantity -> Quantity
forall a. Fractional a => a -> a -> a
/ Amount -> Quantity
aquantity Amount
a) Quantity -> Amount -> Amount
`divideAmount` Amount
pa) { aprice :: Maybe AmountPrice
aprice = Maybe AmountPrice
forall a. Maybe a
Nothing }
        Just (TotalPrice Amount
pa) ->
            Amount
a { aquantity :: Quantity
aquantity = Amount -> Quantity
aquantity Amount
pa Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
* Quantity -> Quantity
forall a. Num a => a -> a
signum (Amount -> Quantity
aquantity Amount
a), acommodity :: CommoditySymbol
acommodity = Amount -> CommoditySymbol
acommodity Amount
pa, aprice :: Maybe AmountPrice
aprice = AmountPrice -> Maybe AmountPrice
forall a. a -> Maybe a
Just (AmountPrice -> Maybe AmountPrice)
-> AmountPrice -> Maybe AmountPrice
forall a b. (a -> b) -> a -> b
$ Amount -> AmountPrice
TotalPrice Amount
pa' } where
                pa' :: Amount
pa' = Amount
pa { aquantity :: Quantity
aquantity = Quantity -> Quantity
forall a. Num a => a -> a
abs (Quantity -> Quantity) -> Quantity -> Quantity
forall a b. (a -> b) -> a -> b
$ Amount -> Quantity
aquantity Amount
a, acommodity :: CommoditySymbol
acommodity = Amount -> CommoditySymbol
acommodity Amount
a, aprice :: Maybe AmountPrice
aprice = Maybe AmountPrice
forall a. Maybe a
Nothing, astyle :: AmountStyle
astyle = Amount -> AmountStyle
astyle Amount
a }

postingsPriceDirectivesFromCosts :: Posting -> [PriceDirective]
postingsPriceDirectivesFromCosts :: Posting -> [PriceDirective]
postingsPriceDirectivesFromCosts Posting
p = (Amount -> Maybe PriceDirective) -> [Amount] -> [PriceDirective]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost Day
date) ([Amount] -> [PriceDirective])
-> (MixedAmount -> [Amount]) -> MixedAmount -> [PriceDirective]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amounts (MixedAmount -> [PriceDirective])
-> MixedAmount -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
p  where
   date :: Day
date = Day -> Maybe Day -> Day
forall a. a -> Maybe a -> a
fromMaybe (Transaction -> Day
tdate (Transaction -> Day)
-> (Maybe Transaction -> Transaction) -> Maybe Transaction -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Transaction -> Transaction
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Transaction -> Day) -> Maybe Transaction -> Day
forall a b. (a -> b) -> a -> b
$ Posting -> Maybe Transaction
ptransaction Posting
p) (Maybe Day -> Day) -> Maybe Day -> Day
forall a b. (a -> b) -> a -> b
$ Posting -> Maybe Day
pdate Posting
p

amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost Day
d Amount
a =
    case Amount -> Maybe AmountPrice
aprice Amount
a of
        Maybe AmountPrice
Nothing -> Maybe PriceDirective
forall a. Maybe a
Nothing
        Just (UnitPrice Amount
pa) -> PriceDirective -> Maybe PriceDirective
forall a. a -> Maybe a
Just
            PriceDirective :: Day -> CommoditySymbol -> Amount -> PriceDirective
PriceDirective { pddate :: Day
pddate = Day
d, pdcommodity :: CommoditySymbol
pdcommodity = Amount -> CommoditySymbol
acommodity Amount
a, pdamount :: Amount
pdamount = Amount
pa }
        Just (TotalPrice Amount
pa) -> PriceDirective -> Maybe PriceDirective
forall a. a -> Maybe a
Just
            PriceDirective :: Day -> CommoditySymbol -> Amount -> PriceDirective
PriceDirective { pddate :: Day
pddate = Day
d, pdcommodity :: CommoditySymbol
pdcommodity = Amount -> CommoditySymbol
acommodity Amount
a, pdamount :: Amount
pdamount = Quantity -> Quantity
forall a. Num a => a -> a
abs (Amount -> Quantity
aquantity Amount
a) Quantity -> Amount -> Amount
`divideAmount'` Amount
pa }

-- | Given a map of standard amount display styles, apply the
-- appropriate one, if any, to this price directive's amount.
-- But keep the number of decimal places unchanged.
stylePriceDirectiveExceptPrecision :: M.Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
stylePriceDirectiveExceptPrecision :: Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
stylePriceDirectiveExceptPrecision Map CommoditySymbol AmountStyle
styles pd :: PriceDirective
pd@PriceDirective{pdamount :: PriceDirective -> Amount
pdamount=Amount
a} =
  PriceDirective
pd{pdamount :: Amount
pdamount = Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmountExceptPrecision Map CommoditySymbol AmountStyle
styles Amount
a}

allPostings :: Journal -> [Posting]
allPostings :: Journal -> [Posting]
allPostings = (Transaction -> [Posting]) -> [Transaction] -> [Posting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Transaction -> [Posting]
tpostings ([Transaction] -> [Posting])
-> (Journal -> [Transaction]) -> Journal -> [Posting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Journal -> [Transaction]
jtxns

mapAmount :: (Amount -> Amount) -> [Posting] -> [Posting]
mapAmount :: (Amount -> Amount) -> [Posting] -> [Posting]
mapAmount Amount -> Amount
f = (Posting -> Posting) -> [Posting] -> [Posting]
forall a b. (a -> b) -> [a] -> [b]
map Posting -> Posting
pf where
    pf :: Posting -> Posting
pf Posting
p = Posting
p { pamount :: MixedAmount
pamount = MixedAmount -> MixedAmount
mf (Posting -> MixedAmount
pamount Posting
p) }
    mf :: MixedAmount -> MixedAmount
mf = [Amount] -> MixedAmount
mixed ([Amount] -> MixedAmount)
-> (MixedAmount -> [Amount]) -> MixedAmount -> MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> Amount) -> [Amount] -> [Amount]
forall a b. (a -> b) -> [a] -> [b]
map Amount -> Amount
f ([Amount] -> [Amount])
-> (MixedAmount -> [Amount]) -> MixedAmount -> [Amount]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amounts