{-# 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 = hledgerCommandMode
($(hereFileRelative "Hledger/Cli/Commands/Registermatch.txt"))
[]
[generalflagsgroup1]
[]
([], Just $ argsFlag "[QUERY]")
registermatch :: CliOpts -> Journal -> IO ()
registermatch opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
let args' = listofstringopt "args" rawopts
case args' of
[desc] -> do
d <- getCurrentDay
let q = queryFromOptsOnly d ropts
(_,pris) = postingsReport ropts q j
ps = [p | (_,_,_,p,_) <- pris]
case similarPosting ps desc of
Nothing -> putStrLn "no matches found."
Just p -> putStr $ postingsReportAsText opts ("",[pri])
where pri = (Just (postingDate p)
,Nothing
,Just $ T.unpack (maybe "" tdescription $ ptransaction p)
,p
,0)
_ -> putStrLn "please provide one description argument."
similarPosting :: [Posting] -> String -> Maybe Posting
similarPosting ps desc =
let matches =
sortBy compareRelevanceAndRecency
$ filter ((> threshold).fst)
[(maybe 0 (\t -> compareDescriptions desc (T.unpack $ tdescription t)) (ptransaction p), p) | p <- ps]
where
compareRelevanceAndRecency (n1,p1) (n2,p2) = compare (n2,postingDate p2) (n1,postingDate p1)
threshold = 0
in case matches of [] -> Nothing
m:_ -> Just $ snd m
compareDescriptions :: [Char] -> [Char] -> Double
compareDescriptions s t = compareStrings s' t'
where s' = simplify s
t' = simplify t
simplify = filter (not . (`elem` ("0123456789"::String)))
compareStrings :: String -> String -> Double
compareStrings "" "" = 1
compareStrings (_:[]) "" = 0
compareStrings "" (_:[]) = 0
compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0
compareStrings s1 s2 = 2.0 * fromIntegral i / fromIntegral u
where
i = length $ intersect pairs1 pairs2
u = length pairs1 + length pairs2
pairs1 = wordLetterPairs $ uppercase s1
pairs2 = wordLetterPairs $ uppercase s2
wordLetterPairs = concatMap letterPairs . words
letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
letterPairs _ = []