{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

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

import qualified Data.Map as M
import Data.List
import qualified Data.Text as T
import qualified Data.Text.IO as T
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
"infer-reverse-prices"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"infer-reverse-prices") CommandDoc
"also show prices obtained by inverting transaction prices"
  ]
  [(CommandDoc, [Flag RawOpts])
generalflagsgroup1]
  ([Flag RawOpts]
hiddenflags [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++
  [[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone [CommandDoc
"costs"]          (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"infer-market-prices") CommandDoc
"deprecated, use --infer-market-prices instead"
  ,[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone [CommandDoc
"inverted-costs"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"infer-reverse-prices")      CommandDoc
"deprecated, use --infer-reverse-prices instead"
  ])
  ([], 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]
postingPriceDirectivesFromCost [Posting]
ps
    rcprices :: [PriceDirective]
rcprices   =
      (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]
postingPriceDirectivesFromCost (Posting -> [PriceDirective])
-> (Posting -> Posting) -> Posting -> [PriceDirective]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MixedAmount -> MixedAmount) -> Posting -> Posting
postingTransformAmount ((Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount 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
"infer-market-prices" [PriceDirective]
cprices
      [PriceDirective] -> [PriceDirective] -> [PriceDirective]
forall a. [a] -> [a] -> [a]
++ CommandDoc -> [PriceDirective] -> [PriceDirective]
forall a. CommandDoc -> [a] -> [a]
ifBoolOpt CommandDoc
"infer-reverse-prices" [PriceDirective]
rcprices  -- TODO: shouldn't this show reversed P prices also ? valuation will use them

  (PriceDirective -> IO ()) -> [PriceDirective] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommoditySymbol -> IO ()
T.putStrLn (CommoditySymbol -> IO ())
-> (PriceDirective -> CommoditySymbol) -> PriceDirective -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PriceDirective -> CommoditySymbol
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 -> T.Text
showPriceDirective :: PriceDirective -> CommoditySymbol
showPriceDirective PriceDirective
mp = [CommoditySymbol] -> CommoditySymbol
T.unwords [CommoditySymbol
"P", CommandDoc -> CommoditySymbol
T.pack (CommandDoc -> CommoditySymbol)
-> (Day -> CommandDoc) -> Day -> CommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> CommandDoc
forall a. Show a => a -> CommandDoc
show (Day -> CommoditySymbol) -> Day -> CommoditySymbol
forall a b. (a -> b) -> a -> b
$ PriceDirective -> Day
pddate PriceDirective
mp, CommoditySymbol -> CommoditySymbol
quoteCommoditySymbolIfNeeded (CommoditySymbol -> CommoditySymbol)
-> CommoditySymbol -> CommoditySymbol
forall a b. (a -> b) -> a -> b
$ PriceDirective -> CommoditySymbol
pdcommodity PriceDirective
mp, WideBuilder -> CommoditySymbol
wbToText (WideBuilder -> CommoditySymbol)
-> (Amount -> WideBuilder) -> Amount -> CommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmountDisplayOpts -> Amount -> WideBuilder
showAmountB AmountDisplayOpts
noColour{displayZeroCommodity :: Bool
displayZeroCommodity=Bool
True} (Amount -> CommoditySymbol) -> Amount -> CommoditySymbol
forall a b. (a -> b) -> a -> b
$ PriceDirective -> Amount
pdamount PriceDirective
mp]

-- 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 p. (Ord a, Num a, Num p) => a -> p
nonZeroSignum (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 }
  where
    nonZeroSignum :: a -> p
nonZeroSignum a
x = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then -p
1 else p
1

-- | 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