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

    module Hledger.Cli.Commands.Registermatch (
      registermatchmode
     ,registermatch
    )
    where

    import Data.Char (toUpper)
    import Data.List
    import qualified Data.Text as T
    import Hledger
    import Hledger.Cli.CliOptions
    import Hledger.Cli.Commands.Register

    registermatchmode :: Mode RawOpts
    registermatchmode = CommandDoc
    -> [Flag RawOpts]
    -> [(CommandDoc, [Flag RawOpts])]
    -> [Flag RawOpts]
    -> ([Arg RawOpts], Maybe (Arg RawOpts))
    -> Mode RawOpts
    hledgerCommandMode
      $(embedFileRelative "Hledger/Cli/Commands/Registermatch.txt")
      []
      [(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 "DESC")

    registermatch :: CliOpts -> Journal -> IO ()
    registermatch :: CliOpts -> Journal -> IO ()
    registermatch opts :: CliOpts
    opts@CliOpts{rawopts_ :: CliOpts -> RawOpts
    rawopts_=RawOpts
    rawopts,reportopts_ :: CliOpts -> ReportOpts
    reportopts_=ReportOpts
    ropts} j :: Journal
    j = do
      let args' :: [CommandDoc]
    args' = CommandDoc -> RawOpts -> [CommandDoc]
    listofstringopt "args" RawOpts
    rawopts
      case [CommandDoc]
    args' of
        [desc :: CommandDoc
    desc] -> do
            Day
    d <- IO Day
    getCurrentDay
            let q :: Query
    q  = Day -> ReportOpts -> Query
    queryFromOptsOnly Day
    d ReportOpts
    ropts
                (_,pris :: [PostingsReportItem]
    pris) = ReportOpts
    -> Query -> Journal -> (CommandDoc, [PostingsReportItem])
    postingsReport ReportOpts
    ropts Query
    q Journal
    j
                ps :: [Posting]
    ps = [Posting
    p | (_,_,_,p :: Posting
    p,_) <- [PostingsReportItem]
    pris]
            case [Posting] -> CommandDoc -> Maybe Posting
    similarPosting [Posting]
    ps CommandDoc
    desc of
              Nothing -> CommandDoc -> IO ()
    putStrLn "no matches found."
              Just p :: Posting
    p  -> CommandDoc -> IO ()
    putStr (CommandDoc -> IO ()) -> CommandDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ CliOpts -> (CommandDoc, [PostingsReportItem]) -> CommandDoc
    postingsReportAsText CliOpts
    opts ("",[PostingsReportItem
    forall a.
    (Maybe Day, Maybe a, Maybe CommandDoc, Posting, MixedAmount)
    pri])
                         where pri :: (Maybe Day, Maybe a, Maybe CommandDoc, Posting, MixedAmount)
    pri = (Day -> Maybe Day
    forall a. a -> Maybe a
    Just (Posting -> Day
    postingDate Posting
    p)
                                     ,Maybe a
    forall a. Maybe a
    Nothing
                                     ,CommandDoc -> Maybe CommandDoc
    forall a. a -> Maybe a
    Just (CommandDoc -> Maybe CommandDoc) -> CommandDoc -> Maybe CommandDoc
    forall a b. (a -> b) -> a -> b
    $ Text -> CommandDoc
    T.unpack (Text -> (Transaction -> Text) -> Maybe Transaction -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe "" Transaction -> Text
    tdescription (Maybe Transaction -> Text) -> Maybe Transaction -> Text
    forall a b. (a -> b) -> a -> b
    $ Posting -> Maybe Transaction
    ptransaction Posting
    p)
                                     ,Posting
    p
                                     ,0)
        _ -> CommandDoc -> IO ()
    putStrLn "please provide one description argument."

    -- Identify the closest recent match for this description in the given date-sorted postings.
    similarPosting :: [Posting] -> String -> Maybe Posting
    similarPosting :: [Posting] -> CommandDoc -> Maybe Posting
    similarPosting ps :: [Posting]
    ps desc :: CommandDoc
    desc =
      let matches :: [(Double, Posting)]
    matches =
              ((Double, Posting) -> (Double, Posting) -> Ordering)
    -> [(Double, Posting)] -> [(Double, Posting)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (Double, Posting) -> (Double, Posting) -> Ordering
    forall a. Ord a => (a, Posting) -> (a, Posting) -> Ordering
    compareRelevanceAndRecency
                         ([(Double, Posting)] -> [(Double, Posting)])
    -> [(Double, Posting)] -> [(Double, Posting)]
    forall a b. (a -> b) -> a -> b
    $ ((Double, Posting) -> Bool)
    -> [(Double, Posting)] -> [(Double, Posting)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Double -> Double -> Bool
    forall a. Ord a => a -> a -> Bool
    > Double
    threshold)(Double -> Bool)
    -> ((Double, Posting) -> Double) -> (Double, Posting) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(Double, Posting) -> Double
    forall a b. (a, b) -> a
    fst)
                         [(Double -> (Transaction -> Double) -> Maybe Transaction -> Double
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe 0 (\t :: Transaction
    t -> CommandDoc -> CommandDoc -> Double
    compareDescriptions CommandDoc
    desc (Text -> CommandDoc
    T.unpack (Text -> CommandDoc) -> Text -> CommandDoc
    forall a b. (a -> b) -> a -> b
    $ Transaction -> Text
    tdescription Transaction
    t)) (Posting -> Maybe Transaction
    ptransaction Posting
    p), Posting
    p) | Posting
    p <- [Posting]
    ps]
                  where
                    compareRelevanceAndRecency :: (a, Posting) -> (a, Posting) -> Ordering
    compareRelevanceAndRecency (n1 :: a
    n1,p1 :: Posting
    p1) (n2 :: a
    n2,p2 :: Posting
    p2) = (a, Day) -> (a, Day) -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (a
    n2,Posting -> Day
    postingDate Posting
    p2) (a
    n1,Posting -> Day
    postingDate Posting
    p1)
                    threshold :: Double
    threshold = 0
      in case [(Double, Posting)]
    matches of []  -> Maybe Posting
    forall a. Maybe a
    Nothing
                         m :: (Double, Posting)
    m:_ -> Posting -> Maybe Posting
    forall a. a -> Maybe a
    Just (Posting -> Maybe Posting) -> Posting -> Maybe Posting
    forall a b. (a -> b) -> a -> b
    $ (Double, Posting) -> Posting
    forall a b. (a, b) -> b
    snd (Double, Posting)
    m

    -- -- Identify the closest recent match for this description in past transactions.
    -- similarTransaction :: Journal -> Query -> String -> Maybe Transaction
    -- similarTransaction j q desc =
    --   case historymatches = transactionsSimilarTo j q desc of
    --     ((,t):_) = Just t
    --     []       = Nothing

    compareDescriptions :: String -> String -> Double
    compareDescriptions :: CommandDoc -> CommandDoc -> Double
    compareDescriptions s :: CommandDoc
    s t :: CommandDoc
    t = CommandDoc -> CommandDoc -> Double
    compareStrings CommandDoc
    s' CommandDoc
    t'
        where s' :: CommandDoc
    s' = CommandDoc -> CommandDoc
    simplify CommandDoc
    s
              t' :: CommandDoc
    t' = CommandDoc -> CommandDoc
    simplify CommandDoc
    t
              simplify :: CommandDoc -> CommandDoc
    simplify = (Char -> Bool) -> CommandDoc -> CommandDoc
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> CommandDoc -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` ("0123456789"::String)))

    -- | Return a similarity measure, from 0 to 1, for two strings.
    -- This is Simon White's letter pairs algorithm from
    -- http://www.catalysoft.com/articles/StrikeAMatch.html
    -- with a modification for short strings.
    compareStrings :: String -> String -> Double
    compareStrings :: CommandDoc -> CommandDoc -> Double
    compareStrings "" "" = 1
    compareStrings [_] "" = 0
    compareStrings "" [_] = 0
    compareStrings [a :: Char
    a] [b :: Char
    b] = if Char -> Char
    toUpper Char
    a Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char -> Char
    toUpper Char
    b then 1 else 0
    compareStrings s1 :: CommandDoc
    s1 s2 :: CommandDoc
    s2 = 2.0 Double -> Double -> Double
    forall a. Num a => a -> a -> a
    * Int -> Double
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i Double -> Double -> Double
    forall a. Fractional a => a -> a -> a
    / Int -> Double
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    u
        where
          i :: Int
    i = [CommandDoc] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([CommandDoc] -> Int) -> [CommandDoc] -> Int
    forall a b. (a -> b) -> a -> b
    $ [CommandDoc] -> [CommandDoc] -> [CommandDoc]
    forall a. Eq a => [a] -> [a] -> [a]
    intersect [CommandDoc]
    pairs1 [CommandDoc]
    pairs2
          u :: Int
    u = [CommandDoc] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [CommandDoc]
    pairs1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [CommandDoc] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [CommandDoc]
    pairs2
          pairs1 :: [CommandDoc]
    pairs1 = CommandDoc -> [CommandDoc]
    wordLetterPairs (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
    forall a b. (a -> b) -> a -> b
    $ CommandDoc -> CommandDoc
    uppercase CommandDoc
    s1
          pairs2 :: [CommandDoc]
    pairs2 = CommandDoc -> [CommandDoc]
    wordLetterPairs (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
    forall a b. (a -> b) -> a -> b
    $ CommandDoc -> CommandDoc
    uppercase CommandDoc
    s2

    wordLetterPairs :: CommandDoc -> [CommandDoc]
    wordLetterPairs = (CommandDoc -> [CommandDoc]) -> [CommandDoc] -> [CommandDoc]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap CommandDoc -> [CommandDoc]
    forall a. [a] -> [[a]]
    letterPairs ([CommandDoc] -> [CommandDoc])
    -> (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CommandDoc -> [CommandDoc]
    words

    letterPairs :: [a] -> [[a]]
    letterPairs (a :: a
    a:b :: a
    b:rest :: [a]
    rest) = [a
    a,a
    b] [a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    : [a] -> [[a]]
    letterPairs (a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    rest)
    letterPairs _ = []