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

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

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
import Data.Maybe (mapMaybe)
import Data.Function ((&))

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
"show-reverse"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"show-reverse")
    CommandDoc
"also show the prices inferred by reversing known 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
"show-reverse") CommandDoc
"deprecated, use --show-reverse instead"
  ,[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone [CommandDoc
"infer-reverse-prices"] (CommandDoc -> RawOpts -> RawOpts
setboolopt CommandDoc
"show-reverse") CommandDoc
"deprecated, use --show-reverse 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]")

instance HasAmounts PriceDirective where
  styleAmounts :: Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
styleAmounts Map CommoditySymbol AmountStyle
styles PriceDirective
pd = PriceDirective
pd{pdamount :: Amount
pdamount=Map CommoditySymbol AmountStyle -> Amount -> Amount
forall a. HasAmounts a => Map CommoditySymbol AmountStyle -> a -> a
styleAmounts Map CommoditySymbol AmountStyle
styles (Amount -> Amount) -> Amount -> Amount
forall a b. (a -> b) -> a -> b
$ PriceDirective -> Amount
pdamount PriceDirective
pd}

-- List market prices.
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

    -- XXX duplicates logic in Hledger.Data.Valuation.makePriceGraph, keep synced

    declaredprices :: [PriceDirective]
declaredprices =
      -- dbg0 "declaredprices" $
      Journal -> [PriceDirective]
jpricedirectives Journal
j

    pricesfromcosts :: [PriceDirective]
pricesfromcosts =
      -- dbg0 "pricesfromcosts" $
      (Posting -> [PriceDirective]) -> [Posting] -> [PriceDirective]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Posting -> [PriceDirective]
postingPriceDirectivesFromCost ([Posting] -> [PriceDirective]) -> [Posting] -> [PriceDirective]
forall a b. (a -> b) -> a -> b
$
      Journal -> [Posting]
journalPostings Journal
j

    forwardprices :: [PriceDirective]
forwardprices =
      -- dbg0 "forwardprices" $
      if CommandDoc -> RawOpts -> Bool
boolopt CommandDoc
"infer-market-prices" (CliOpts -> RawOpts
rawopts_ CliOpts
opts)
      then [PriceDirective]
declaredprices [PriceDirective] -> [PriceDirective] -> [PriceDirective]
`mergePriceDirectives` [PriceDirective]
pricesfromcosts
      else [PriceDirective]
declaredprices

    reverseprices :: [PriceDirective]
reverseprices =
      -- dbg0 "reverseprices" $
      (PriceDirective -> Maybe PriceDirective)
-> [PriceDirective] -> [PriceDirective]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PriceDirective -> Maybe PriceDirective
reversePriceDirective [PriceDirective]
forwardprices

    allprices :: [PriceDirective]
allprices =
      -- dbg0 "allprices" $
      if CommandDoc -> RawOpts -> Bool
boolopt CommandDoc
"show-reverse" (CliOpts -> RawOpts
rawopts_ CliOpts
opts)
      then [PriceDirective]
forwardprices [PriceDirective] -> [PriceDirective] -> [PriceDirective]
`mergePriceDirectives` [PriceDirective]
reverseprices
      else [PriceDirective]
forwardprices

    filteredprices :: [PriceDirective]
filteredprices =
      -- dbg0 "filtered unsorted" $
      (PriceDirective -> Bool) -> [PriceDirective] -> [PriceDirective]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query -> PriceDirective -> Bool
matchesPriceDirective Query
q) [PriceDirective]
allprices

  (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 -> CommoditySymbol)
-> (PriceDirective -> PriceDirective)
-> PriceDirective
-> CommoditySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CommoditySymbol AmountStyle -> PriceDirective -> PriceDirective
forall a. HasAmounts a => Map CommoditySymbol AmountStyle -> a -> a
styleAmounts Map CommoditySymbol AmountStyle
styles) ([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]
filteredprices

-- XXX performance
-- | Append any new price directives (with different from commodity,
-- to commodity, or date) from the second list to the first.
-- (Does not remove redundant prices from the first; just avoids adding more.)
mergePriceDirectives :: [PriceDirective] -> [PriceDirective] -> [PriceDirective]
mergePriceDirectives :: [PriceDirective] -> [PriceDirective] -> [PriceDirective]
mergePriceDirectives [PriceDirective]
pds1 [PriceDirective]
pds2 =
  [PriceDirective]
pds1 [PriceDirective] -> [PriceDirective] -> [PriceDirective]
forall a. [a] -> [a] -> [a]
++ [ PriceDirective
pd | PriceDirective
pd <- [PriceDirective]
pds2 , PriceDirective -> (Day, CommoditySymbol, CommoditySymbol)
pdid PriceDirective
pd (Day, CommoditySymbol, CommoditySymbol)
-> [(Day, CommoditySymbol, CommoditySymbol)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(Day, CommoditySymbol, CommoditySymbol)]
pds1ids ]
  where
    pds1ids :: [(Day, CommoditySymbol, CommoditySymbol)]
pds1ids = (PriceDirective -> (Day, CommoditySymbol, CommoditySymbol))
-> [PriceDirective] -> [(Day, CommoditySymbol, CommoditySymbol)]
forall a b. (a -> b) -> [a] -> [b]
map PriceDirective -> (Day, CommoditySymbol, CommoditySymbol)
pdid [PriceDirective]
pds1
    pdid :: PriceDirective -> (Day, CommoditySymbol, CommoditySymbol)
pdid PriceDirective{Day
pddate :: Day
pddate :: PriceDirective -> Day
pddate,CommoditySymbol
pdcommodity :: PriceDirective -> CommoditySymbol
pdcommodity :: CommoditySymbol
pdcommodity,Amount
pdamount :: Amount
pdamount :: PriceDirective -> Amount
pdamount} = (Day
pddate, CommoditySymbol
pdcommodity, Amount -> CommoditySymbol
acommodity Amount
pdamount)

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
  ]

-- | Convert a market price directive to a corresponding one in the
-- opposite direction, if possible. (A price directive with a zero
-- price can't be reversed.)
--
-- The price's display precision will be set to show all significant
-- decimal digits (or if they appear infinite, a smaller default precision (8).
-- This is visible eg in the prices command's output.
--
reversePriceDirective :: PriceDirective -> Maybe PriceDirective
reversePriceDirective :: PriceDirective -> Maybe PriceDirective
reversePriceDirective pd :: PriceDirective
pd@PriceDirective{pdcommodity :: PriceDirective -> CommoditySymbol
pdcommodity=CommoditySymbol
c, pdamount :: PriceDirective -> Amount
pdamount=Amount
a}
  | Amount -> Bool
amountIsZero Amount
a = Maybe PriceDirective
forall a. Maybe a
Nothing
  | Bool
otherwise      = PriceDirective -> Maybe PriceDirective
forall a. a -> Maybe a
Just PriceDirective
pd{pdcommodity :: CommoditySymbol
pdcommodity=Amount -> CommoditySymbol
acommodity Amount
a, pdamount :: Amount
pdamount=Amount
a'}
    where
      lbl :: CommandDoc -> CommandDoc -> CommandDoc
lbl = CommandDoc -> CommandDoc -> CommandDoc -> CommandDoc
lbl_ CommandDoc
"reversePriceDirective"
      a' :: Amount
a' =
        Maybe Word8 -> Amount -> Amount
amountSetFullPrecisionOr (Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
defaultMaxPrecision) (Amount -> Amount) -> Amount -> Amount
forall a b. (a -> b) -> a -> b
$
        Amount -> Amount
invertAmount Amount
a{acommodity :: CommoditySymbol
acommodity=CommoditySymbol
c}
        Amount -> (Amount -> Amount) -> Amount
forall a b. a -> (a -> b) -> b
& (Amount -> CommandDoc) -> Amount -> Amount
forall a. Show a => (a -> CommandDoc) -> a -> a
dbg9With (CommandDoc -> CommandDoc -> CommandDoc
lbl CommandDoc
"calculated reverse price"(CommandDoc -> CommandDoc)
-> (Amount -> CommandDoc) -> Amount -> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Amount -> CommandDoc
showAmount)
        -- & dbg9With (lbl "precision of reverse price".show.amountDisplayPrecision)