{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Hledger.Cli.Commands.Registermatch (
registermatchmode
,registermatch
)
where
import Data.Char (toUpper)
import Data.List
import Data.String.Here
import qualified Data.Text as T
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Register
registermatchmode = hledgerCommandMode
[here| register-match
Print the one posting whose transaction description is closest to DESC,
in the style of the register command.
If there are multiple equally good matches, it shows the most recent.
Query options (options, not arguments) can be used to restrict the search space.
Helps ledger-autosync detect already-seen transactions when importing.
|]
[]
[generalflagsgroup1]
[]
([], Nothing)
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 _ = []