    {-# 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 Text AmountStyle
    styles     = Journal -> Map Text 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 Text AmountStyle -> PriceDirective -> PriceDirective
    stylePriceDirectiveExceptPrecision Map Text 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 Text AmountStyle -> PriceDirective -> PriceDirective
    stylePriceDirectiveExceptPrecision Map Text 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_ (Text -> IO ()
    T.putStrLn (Text -> IO ())
    -> (PriceDirective -> Text) -> PriceDirective -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . PriceDirective -> Text
    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 -> Text
    showPriceDirective PriceDirective
    mp = [Text] -> Text
    T.unwords [Text
    "P", CommandDoc -> Text
    T.pack (CommandDoc -> Text) -> (Day -> CommandDoc) -> Day -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Day -> CommandDoc
    forall a. Show a => a -> CommandDoc
    show (Day -> Text) -> Day -> Text
    forall a b. (a -> b) -> a -> b
    $ PriceDirective -> Day
    pddate PriceDirective
    mp, Text -> Text
    quoteCommoditySymbolIfNeeded (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ PriceDirective -> Text
    pdcommodity PriceDirective
    mp, WideBuilder -> Text
    wbToText (WideBuilder -> Text) -> (Amount -> WideBuilder) -> Amount -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AmountDisplayOpts -> Amount -> WideBuilder
    showAmountB AmountDisplayOpts
    noColour{displayZeroCommodity :: Bool
    displayZeroCommodity=Bool
    True} (Amount -> Text) -> Amount -> Text
    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} {a}. (Ord a, Num a, Num a) => a -> a
    nonZeroSignum (Amount -> Quantity
    aquantity Amount
    a), acommodity :: Text
    acommodity = Amount -> Text
    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 :: Text
    acommodity = Amount -> Text
    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 -> a
    nonZeroSignum a
    x = if a
    x a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < a
    0 then -a
    1 else a
    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 Text AmountStyle -> PriceDirective -> PriceDirective
    stylePriceDirectiveExceptPrecision Map Text AmountStyle
    styles pd :: PriceDirective
    pd@PriceDirective{pdamount :: PriceDirective -> Amount
    pdamount=Amount
    a} =
      PriceDirective
    pd{pdamount :: Amount
    pdamount = Map Text AmountStyle -> Amount -> Amount
    styleAmountExceptPrecision Map Text 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