{-# 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 qualified Data.Text.Lazy.IO as TL
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Register

registermatchmode :: Mode RawOpts
registermatchmode = String
-> [Flag RawOpts]
-> [(String, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Registermatch.txt")
  []
  [(String, [Flag RawOpts])
generalflagsgroup1]
  [Flag RawOpts]
hiddenflags
  ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Arg RawOpts
argsFlag String
"DESC")

registermatch :: CliOpts -> Journal -> IO ()
registermatch :: CliOpts -> Journal -> IO ()
registermatch opts :: CliOpts
opts@CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
rawopts,reportspec_ :: CliOpts -> ReportSpec
reportspec_=ReportSpec
rspec} Journal
j =
  case String -> RawOpts -> [String]
listofstringopt String
"args" RawOpts
rawopts of
    [String
desc] -> do
        let ps :: [Posting]
ps = [Posting
p | (Maybe Day
_,Maybe Period
_,Maybe Text
_,Posting
p,MixedAmount
_) <- ReportSpec -> Journal -> PostingsReport
postingsReport ReportSpec
rspec Journal
j]
        case [Posting] -> String -> Maybe Posting
similarPosting [Posting]
ps String
desc of
          Maybe Posting
Nothing -> String -> IO ()
putStrLn String
"no matches found."
          Just Posting
p  -> Text -> IO ()
TL.putStr forall a b. (a -> b) -> a -> b
$ CliOpts -> PostingsReport -> Text
postingsReportAsText CliOpts
opts [forall {a}. (Maybe Day, Maybe a, Maybe Text, Posting, MixedAmount)
pri]
                     where pri :: (Maybe Day, Maybe a, Maybe Text, Posting, MixedAmount)
pri = (forall a. a -> Maybe a
Just (Posting -> Day
postingDate Posting
p)
                                 ,forall a. Maybe a
Nothing
                                 ,Transaction -> Text
tdescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Posting -> Maybe Transaction
ptransaction Posting
p
                                 ,Posting
p
                                 ,MixedAmount
nullmixedamt)
    [String]
_ -> String -> IO ()
putStrLn String
"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] -> String -> Maybe Posting
similarPosting [Posting]
ps String
desc =
  let matches :: [(Double, Posting)]
matches =
          forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a}. Ord a => (a, Posting) -> (a, Posting) -> Ordering
compareRelevanceAndRecency
                     forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Double
threshold)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst)
                     [(forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 (\Transaction
t -> String -> String -> Double
compareDescriptions String
desc (Text -> String
T.unpack 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 (a
n1,Posting
p1) (a
n2,Posting
p2) = 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 = Double
0
  in case [(Double, Posting)]
matches of []  -> forall a. Maybe a
Nothing
                     (Double, Posting)
m:[(Double, Posting)]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 :: String -> String -> Double
compareDescriptions String
s String
t = String -> String -> Double
compareStrings String
s' String
t'
    where s' :: String
s' = String -> String
simplify String
s
          t' :: String
t' = String -> String
simplify String
t
          simplify :: String -> String
simplify = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"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 :: String -> String -> Double
compareStrings String
"" String
"" = Double
1
compareStrings [Char
_] String
"" = Double
0
compareStrings String
"" [Char
_] = Double
0
compareStrings [Char
a] [Char
b] = if Char -> Char
toUpper Char
a forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
b then Double
1 else Double
0
compareStrings String
s1 String
s2 = Double
2.0 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u
    where
      i :: Int
i = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a]
intersect [String]
pairs1 [String]
pairs2
      u :: Int
u = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pairs1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
pairs2
      pairs1 :: [String]
pairs1 = String -> [String]
wordLetterPairs forall a b. (a -> b) -> a -> b
$ String -> String
uppercase String
s1
      pairs2 :: [String]
pairs2 = String -> [String]
wordLetterPairs forall a b. (a -> b) -> a -> b
$ String -> String
uppercase String
s2

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

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