{-# 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."
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
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)))
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 _ = []