1{-| 2A history-aware add command to help with data entry. 3|-} 4 5{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} 6{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-} 7{-# LANGUAGE TemplateHaskell #-} 8 9module Hledger.Cli.Commands.Add ( 10 addmode 11 ,add 12 ,appendToJournalFileOrStdout 13 ,journalAddTransaction 14 ,transactionsSimilarTo 15) 16where 17 18import Prelude () 19import "base-compat-batteries" Prelude.Compat hiding (fail) 20import Control.Exception as E 21import Control.Monad (when) 22import Control.Monad.Trans.Class 23import Control.Monad.State.Strict (evalState, evalStateT) 24import Control.Monad.Trans (liftIO) 25import Data.Char (toUpper, toLower) 26import Data.Either (isRight) 27import Data.Functor.Identity (Identity(..)) 28import "base-compat-batteries" Data.List.Compat 29import qualified Data.Set as S 30import Data.Maybe 31import Data.Text (Text) 32import qualified Data.Text as T 33import Data.Time.Calendar (Day) 34import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) 35import Safe (headDef, headMay, atMay) 36import System.Console.CmdArgs.Explicit 37import System.Console.Haskeline (runInputT, defaultSettings, setComplete) 38import System.Console.Haskeline.Completion 39import System.Console.Wizard 40import System.Console.Wizard.Haskeline 41import System.IO ( stderr, hPutStr, hPutStrLn ) 42import Text.Megaparsec 43import Text.Megaparsec.Char 44import Text.Printf 45 46import Hledger 47import Hledger.Cli.CliOptions 48import Hledger.Cli.Commands.Register (postingsReportAsText) 49 50 51addmode = hledgerCommandMode 52 $(embedFileRelative "Hledger/Cli/Commands/Add.txt") 53 [flagNone ["no-new-accounts"] (setboolopt "no-new-accounts") "don't allow creating new accounts"] 54 [generalflagsgroup2] 55 [] 56 ([], Just $ argsFlag "[DATE [DESCRIPTION [ACCOUNT1 [AMOUNT1 [ACCOUNT2 [ETC...]]]]]]") 57 58-- | State used while entering transactions. 59data EntryState = EntryState { 60 esOpts :: CliOpts -- ^ command line options 61 ,esArgs :: [String] -- ^ command line arguments remaining to be used as defaults 62 ,esToday :: Day -- ^ today's date 63 ,esDefDate :: Day -- ^ the default date for next transaction 64 ,esJournal :: Journal -- ^ the journal we are adding to 65 ,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn 66 ,esPostings :: [Posting] -- ^ postings entered so far in the current txn 67 } deriving (Show) 68 69defEntryState = EntryState { 70 esOpts = defcliopts 71 ,esArgs = [] 72 ,esToday = nulldate 73 ,esDefDate = nulldate 74 ,esJournal = nulljournal 75 ,esSimilarTransaction = Nothing 76 ,esPostings = [] 77} 78 79data RestartTransactionException = RestartTransactionException deriving (Show) 80instance Exception RestartTransactionException 81 82-- data ShowHelpException = ShowHelpException deriving (Show) 83-- instance Exception ShowHelpException 84 85-- | Read multiple transactions from the console, prompting for each 86-- field, and append them to the journal file. If the journal came 87-- from stdin, this command has no effect. 88add :: CliOpts -> Journal -> IO () 89add opts j 90 | journalFilePath j == "-" = return () 91 | otherwise = do 92 hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j) 93 showHelp 94 today <- getCurrentDay 95 let es = defEntryState{esOpts=opts 96 ,esArgs=listofstringopt "args" $ rawopts_ opts 97 ,esToday=today 98 ,esDefDate=today 99 ,esJournal=j 100 } 101 getAndAddTransactions es `E.catch` (\(_::UnexpectedEOF) -> putStr "") 102 103showHelp = hPutStr stderr $ unlines [ 104 "Any command line arguments will be used as defaults." 105 ,"Use tab key to complete, readline keys to edit, enter to accept defaults." 106 ,"An optional (CODE) may follow transaction dates." 107 ,"An optional ; COMMENT may follow descriptions or amounts." 108 ,"If you make a mistake, enter < at any prompt to go one step backward." 109 ,"To end a transaction, enter . when prompted." 110 ,"To quit, enter . at a date prompt or press control-d or control-c." 111 ] 112 113-- | Loop reading transactions from the console, prompting, validating 114-- and appending each one to the journal file, until end of input or 115-- ctrl-c (then raise an EOF exception). If provided, command-line 116-- arguments are used as defaults; otherwise defaults come from the 117-- most similar recent transaction in the journal. 118getAndAddTransactions :: EntryState -> IO () 119getAndAddTransactions es@EntryState{..} = (do 120 let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]} 121 mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard defaultPrevInput es []) 122 case mt of 123 Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL: 124 Just t -> do 125 j <- if debug_ esOpts > 0 126 then do hPrintf stderr "Skipping journal add due to debug mode.\n" 127 return esJournal 128 else do j' <- journalAddTransaction esJournal esOpts t 129 hPrintf stderr "Saved.\n" 130 return j' 131 hPrintf stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)\n" 132 getAndAddTransactions es{esJournal=j, esDefDate=tdate t} 133 ) 134 `E.catch` (\(_::RestartTransactionException) -> 135 hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es) 136 137data TxnParams = TxnParams 138 { txnDate :: Day 139 , txnCode :: Text 140 , txnDesc :: Text 141 , txnCmnt :: Text 142 } deriving (Show) 143 144data PrevInput = PrevInput 145 { prevDateAndCode :: Maybe String 146 , prevDescAndCmnt :: Maybe String 147 , prevAccount :: [String] 148 , prevAmountAndCmnt :: [String] 149 } deriving (Show) 150 151data AddingStage = EnterDateAndCode 152 | EnterDescAndComment (Day, Text) 153 | EnterAccount TxnParams 154 | EnterAmountAndComment TxnParams String 155 | EndStage Transaction 156 | EnterNewPosting TxnParams (Maybe Posting) 157 158confirmedTransactionWizard :: PrevInput -> EntryState -> [AddingStage] -> Wizard Haskeline Transaction 159confirmedTransactionWizard prevInput es [] = confirmedTransactionWizard prevInput es [EnterDateAndCode] 160confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _) = case currentStage of 161 EnterDateAndCode -> dateAndCodeWizard prevInput es >>= \case 162 Just (date, code) -> do 163 let es' = es 164 { esArgs = drop 1 esArgs 165 , esDefDate = date 166 } 167 dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date ++ (if T.null code then "" else " (" ++ T.unpack code ++ ")") 168 yyyymmddFormat = iso8601DateFormat Nothing 169 confirmedTransactionWizard prevInput{prevDateAndCode=Just dateAndCodeString} es' (EnterDescAndComment (date, code) : stack) 170 Nothing -> 171 confirmedTransactionWizard prevInput es stack 172 173 EnterDescAndComment (date, code) -> descriptionAndCommentWizard prevInput es >>= \case 174 Just (desc, comment) -> do 175 let mbaset = similarTransaction es desc 176 es' = es 177 { esArgs = drop 1 esArgs 178 , esPostings = [] 179 , esSimilarTransaction = mbaset 180 } 181 descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment) 182 prevInput' = prevInput{prevDescAndCmnt=Just descAndCommentString} 183 when (isJust mbaset) $ liftIO $ hPrintf stderr "Using this similar transaction for defaults:\n%s" (showTransaction $ fromJust mbaset) 184 confirmedTransactionWizard prevInput' es' ((EnterNewPosting TxnParams{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack) 185 Nothing -> 186 confirmedTransactionWizard prevInput es (drop 1 stack) 187 188 EnterNewPosting txnParams@TxnParams{..} posting -> case (esPostings, posting) of 189 ([], Nothing) -> 190 confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) 191 (_, Just _) -> 192 confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) 193 (_, Nothing) -> do 194 let t = nulltransaction{tdate=txnDate 195 ,tstatus=Unmarked 196 ,tcode=txnCode 197 ,tdescription=txnDesc 198 ,tcomment=txnCmnt 199 ,tpostings=esPostings 200 } 201 case balanceTransaction Nothing t of -- imprecise balancing (?) 202 Right t' -> 203 confirmedTransactionWizard prevInput es (EndStage t' : stack) 204 Left err -> do 205 liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ "please re-enter.") 206 let notFirstEnterPost stage = case stage of 207 EnterNewPosting _ Nothing -> False 208 _ -> True 209 confirmedTransactionWizard prevInput es{esPostings=[]} (dropWhile notFirstEnterPost stack) 210 211 EnterAccount txnParams -> accountWizard prevInput es >>= \case 212 Just account 213 | account `elem` [".", ""] -> 214 case (esPostings, postingsBalanced esPostings) of 215 ([],_) -> liftIO (hPutStrLn stderr "Please enter some postings first.") >> confirmedTransactionWizard prevInput es stack 216 (_,False) -> liftIO (hPutStrLn stderr "Please enter more postings to balance the transaction.") >> confirmedTransactionWizard prevInput es stack 217 (_,True) -> confirmedTransactionWizard prevInput es (EnterNewPosting txnParams Nothing : stack) 218 | otherwise -> do 219 let prevAccount' = replaceNthOrAppend (length esPostings) account (prevAccount prevInput) 220 confirmedTransactionWizard prevInput{prevAccount=prevAccount'} es{esArgs=drop 1 esArgs} (EnterAmountAndComment txnParams account : stack) 221 Nothing -> do 222 let notPrevAmountAndNotEnterDesc stage = case stage of 223 EnterAmountAndComment _ _ -> False 224 EnterDescAndComment _ -> False 225 _ -> True 226 confirmedTransactionWizard prevInput es{esPostings=init esPostings} (dropWhile notPrevAmountAndNotEnterDesc stack) 227 228 EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case 229 Just (amount, comment) -> do 230 let posting = nullposting{paccount=T.pack $ stripbrackets account 231 ,pamount=Mixed [amount] 232 ,pcomment=comment 233 ,ptype=accountNamePostingType $ T.pack account 234 } 235 amountAndCommentString = showAmount amount ++ (if T.null comment then "" else " ;" ++ T.unpack comment) 236 prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput) 237 es' = es{esPostings=esPostings++[posting], esArgs=drop 2 esArgs} 238 confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack) 239 Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack) 240 241 EndStage t -> do 242 output $ showTransaction t 243 y <- let def = "y" in 244 retryMsg "Please enter y or n." $ 245 parser ((fmap (\c -> if c == '<' then Nothing else Just c)) . headMay . map toLower . strip) $ 246 defaultTo' def $ nonEmpty $ 247 line $ green $ printf "Save this transaction to the journal ?%s: " (showDefault def) 248 case y of 249 Just 'y' -> return t 250 Just _ -> throw RestartTransactionException 251 Nothing -> confirmedTransactionWizard prevInput es (drop 2 stack) 252 where 253 replaceNthOrAppend n newElem xs = take n xs ++ [newElem] ++ drop (n + 1) xs 254 255-- Identify the closest recent match for this description in past transactions. 256similarTransaction :: EntryState -> Text -> Maybe Transaction 257similarTransaction EntryState{..} desc = 258 let q = queryFromOptsOnly esToday $ reportopts_ esOpts 259 historymatches = transactionsSimilarTo esJournal q desc 260 bestmatch | null historymatches = Nothing 261 | otherwise = Just $ snd $ head historymatches 262 in bestmatch 263 264dateAndCodeWizard PrevInput{..} EntryState{..} = do 265 let def = headDef (showDate esDefDate) esArgs 266 retryMsg "A valid hledger smart date is required. Eg: 2014/2/14, 14, yesterday." $ 267 parser (parseSmartDateAndCode esToday) $ 268 withCompletion (dateCompleter def) $ 269 defaultTo' def $ nonEmpty $ 270 maybeExit $ 271 -- maybeShowHelp $ 272 linePrewritten (green $ printf "Date%s: " (showDefault def)) (fromMaybe "" prevDateAndCode) "" 273 where 274 parseSmartDateAndCode refdate s = if s == "<" then return Nothing else either (const Nothing) (\(d,c) -> return $ Just (fixSmartDate refdate d, c)) edc 275 where 276 edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s 277 dateandcodep :: SimpleTextParser (SmartDate, Text) 278 dateandcodep = do 279 d <- smartdate 280 c <- optional codep 281 skipNonNewlineSpaces 282 eof 283 return (d, fromMaybe "" c) 284 -- defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate 285 -- datestr = showDate $ fixSmartDate defday smtdate 286 287descriptionAndCommentWizard PrevInput{..} EntryState{..} = do 288 let def = headDef "" esArgs 289 s <- withCompletion (descriptionCompleter esJournal def) $ 290 defaultTo' def $ nonEmpty $ 291 linePrewritten (green $ printf "Description%s: " (showDefault def)) (fromMaybe "" prevDescAndCmnt) "" 292 if s == "<" 293 then return Nothing 294 else do 295 let (desc,comment) = (T.pack $ strip a, T.pack $ strip $ dropWhile (==';') b) where (a,b) = break (==';') s 296 return $ Just (desc, comment) 297 298postingsBalanced :: [Posting] -> Bool 299postingsBalanced ps = isRight $ balanceTransaction Nothing nulltransaction{tpostings=ps} 300 301accountWizard PrevInput{..} EntryState{..} = do 302 let pnum = length esPostings + 1 303 historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction 304 historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p) 305 Nothing -> "" 306 def = headDef historicalacct esArgs 307 endmsg | canfinish && null def = " (or . or enter to finish this transaction)" 308 | canfinish = " (or . to finish this transaction)" 309 | otherwise = "" 310 retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $ 311 parser (parseAccountOrDotOrNull def canfinish) $ 312 withCompletion (accountCompleter esJournal def) $ 313 defaultTo' def $ -- nonEmpty $ 314 linePrewritten (green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)) (fromMaybe "" $ prevAccount `atMay` length esPostings) "" 315 where 316 canfinish = not (null esPostings) && postingsBalanced esPostings 317 parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String) 318 parseAccountOrDotOrNull _ _ "<" = dbg1 $ Just Nothing 319 parseAccountOrDotOrNull _ _ "." = dbg1 $ Just $ Just "." -- . always signals end of txn 320 parseAccountOrDotOrNull "" True "" = dbg1 $ Just $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn 321 parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just $ Just def -- when there's a default, "" means use that 322 parseAccountOrDotOrNull _ _ s = dbg1 $ fmap (Just . T.unpack) $ 323 either (const Nothing) validateAccount $ 324 flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input as an accountname 325 where 326 validateAccount :: Text -> Maybe Text 327 validateAccount t | no_new_accounts_ esOpts && notElem t (journalAccountNamesDeclaredOrImplied esJournal) = Nothing 328 | otherwise = Just t 329 dbg1 = id -- strace 330 331amountAndCommentWizard PrevInput{..} EntryState{..} = do 332 let pnum = length esPostings + 1 333 (mhistoricalp,followedhistoricalsofar) = 334 case esSimilarTransaction of 335 Nothing -> (Nothing,False) 336 Just Transaction{tpostings=ps} -> (if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing 337 ,all (\(a,b) -> pamount a == pamount b) $ zip esPostings ps) 338 def = case (esArgs, mhistoricalp, followedhistoricalsofar) of 339 (d:_,_,_) -> d 340 (_,Just hp,True) -> showamt $ pamount hp 341 _ | pnum > 1 && not (mixedAmountLooksZero balancingamt) -> showamt balancingamtfirstcommodity 342 _ -> "" 343 retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." $ 344 parser parseAmountAndComment $ 345 withCompletion (amountCompleter def) $ 346 defaultTo' def $ nonEmpty $ 347 linePrewritten (green $ printf "Amount %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length esPostings) "" 348 where 349 parseAmountAndComment s = if s == "<" then return Nothing else either (const Nothing) (return . Just) $ 350 runParser 351 (evalStateT (amountandcommentp <* eof) nodefcommodityj) 352 "" 353 (T.pack s) 354 nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing} 355 amountandcommentp :: JournalParser Identity (Amount, Text) 356 amountandcommentp = do 357 a <- amountp 358 lift skipNonNewlineSpaces 359 c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle) 360 -- eof 361 return (a,c) 362 balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings 363 balancingamtfirstcommodity = Mixed $ take 1 $ amounts balancingamt 364 showamt = 365 showMixedAmountWithPrecision 366 -- what should this be ? 367 -- 1 maxprecision (show all decimal places or none) ? 368 -- 2 maxprecisionwithpoint (show all decimal places or .0 - avoids some but not all confusion with thousands separators) ? 369 -- 3 canonical precision for this commodity in the journal ? 370 -- 4 maximum precision entered so far in this transaction ? 371 -- 5 3 or 4, whichever would show the most decimal places ? 372 -- I think 1 or 4, whichever would show the most decimal places 373 NaturalPrecision 374 -- 375 -- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt 376 -- a = fromparse $ runParser (amountp <|> return missingamt) (jparsestate esJournal) "" amt 377 -- awithoutjps = fromparse $ runParser (amountp <|> return missingamt) mempty "" amt 378 -- defamtaccepted = Just (showAmount a) == mdefamt 379 -- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing} 380 -- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a 381 -- when (isJust mdefaultcommodityapplied) $ 382 -- liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied) 383 384maybeExit = parser (\s -> if s=="." then throw UnexpectedEOF else Just s) 385 386-- maybeShowHelp :: Wizard Haskeline String -> Wizard Haskeline String 387-- maybeShowHelp wizard = maybe (liftIO showHelp >> wizard) return $ 388-- parser (\s -> if s=="?" then Nothing else Just s) wizard 389 390-- Completion helpers 391 392dateCompleter :: String -> CompletionFunc IO 393dateCompleter = completer ["today","tomorrow","yesterday"] 394 395descriptionCompleter :: Journal -> String -> CompletionFunc IO 396descriptionCompleter j = completer (map T.unpack $ journalDescriptions j) 397 398accountCompleter :: Journal -> String -> CompletionFunc IO 399accountCompleter j = completer (map T.unpack $ journalAccountNamesDeclaredOrImplied j) 400 401amountCompleter :: String -> CompletionFunc IO 402amountCompleter = completer [] 403 404-- | Generate a haskeline completion function from the given 405-- completions and default, that case insensitively completes with 406-- prefix matches, or infix matches above a minimum length, or 407-- completes the null string with the default. 408completer :: [String] -> String -> CompletionFunc IO 409completer completions def = completeWord Nothing "" completionsFor 410 where 411 simpleCompletion' s = (simpleCompletion s){isFinished=False} 412 completionsFor "" = return [simpleCompletion' def] 413 completionsFor i = return (map simpleCompletion' ciprefixmatches) 414 where 415 ciprefixmatches = [c | c <- completions, i `isPrefixOf` c] 416 -- mixed-case completions require haskeline > 0.7.1.2 417 -- ciprefixmatches = [c | c <- completions, lowercase i `isPrefixOf` lowercase c] 418 419-------------------------------------------------------------------------------- 420 421-- utilities 422 423defaultTo' = flip defaultTo 424 425withCompletion f = withSettings (setComplete f defaultSettings) 426 427green s = "\ESC[1;32m\STX"++s++"\ESC[0m\STX" 428 429showDefault "" = "" 430showDefault s = " [" ++ s ++ "]" 431 432-- | Append this transaction to the journal's file and transaction list. 433journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal 434journalAddTransaction j@Journal{jtxns=ts} opts t = do 435 let f = journalFilePath j 436 appendToJournalFileOrStdout f $ showTransaction t 437 -- unelided shows all amounts explicitly, in case there's a price, cf #283 438 when (debug_ opts > 0) $ do 439 putStrLn $ printf "\nAdded transaction to %s:" f 440 putStrLn =<< registerFromString (showTransaction t) 441 return j{jtxns=ts++[t]} 442 443-- | Append a string, typically one or more transactions, to a journal 444-- file, or if the file is "-", dump it to stdout. Tries to avoid 445-- excess whitespace. 446-- 447-- XXX This writes unix line endings (\n), some at least, 448-- even if the file uses dos line endings (\r\n), which could leave 449-- mixed line endings in the file. See also writeFileWithBackupIfChanged. 450-- 451appendToJournalFileOrStdout :: FilePath -> String -> IO () 452appendToJournalFileOrStdout f s 453 | f == "-" = putStr s' 454 | otherwise = appendFile f s' 455 where s' = "\n" ++ ensureOneNewlineTerminated s 456 457-- | Replace a string's 0 or more terminating newlines with exactly one. 458ensureOneNewlineTerminated :: String -> String 459ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse 460 461-- | Convert a string of journal data into a register report. 462registerFromString :: String -> IO String 463registerFromString s = do 464 d <- getCurrentDay 465 j <- readJournal' $ T.pack s 466 return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j 467 where 468 ropts = defreportopts{empty_=True} 469 opts = defcliopts{reportopts_=ropts} 470 471capitalize :: String -> String 472capitalize "" = "" 473capitalize (c:cs) = toUpper c : cs 474 475-- | Find the most similar and recent transactions matching the given 476-- transaction description and report query. Transactions are listed 477-- with their "relevancy" score, most relevant first. 478transactionsSimilarTo :: Journal -> Query -> Text -> [(Double,Transaction)] 479transactionsSimilarTo j q desc = 480 sortBy compareRelevanceAndRecency 481 $ filter ((> threshold).fst) 482 [(compareDescriptions desc $ tdescription t, t) | t <- ts] 483 where 484 compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1) 485 ts = filter (q `matchesTransaction`) $ jtxns j 486 threshold = 0 487 488-- | Return a similarity measure, from 0 to 1, for two transaction 489-- descriptions. This is like compareStrings, but first strips out 490-- any numbers, to improve accuracy eg when there are bank transaction 491-- ids from imported data. 492compareDescriptions :: Text -> Text -> Double 493compareDescriptions s t = compareStrings s' t' 494 where s' = simplify $ T.unpack s 495 t' = simplify $ T.unpack t 496 simplify = filter (not . (`elem` ("0123456789" :: String))) 497 498-- | Return a similarity measure, from 0 to 1, for two strings. This 499-- was based on Simon White's string similarity algorithm 500-- (http://www.catalysoft.com/articles/StrikeAMatch.html), later found 501-- to be https://en.wikipedia.org/wiki/S%C3%B8rensen%E2%80%93Dice_coefficient, 502-- modified to handle short strings better. 503-- Todo: check out http://nlp.fi.muni.cz/raslan/2008/raslan08.pdf#page=14 . 504compareStrings :: String -> String -> Double 505compareStrings "" "" = 1 506compareStrings [_] "" = 0 507compareStrings "" [_] = 0 508compareStrings [a] [b] = if toUpper a == toUpper b then 1 else 0 509compareStrings s1 s2 = 2 * commonpairs / totalpairs 510 where 511 pairs1 = S.fromList $ wordLetterPairs $ uppercase s1 512 pairs2 = S.fromList $ wordLetterPairs $ uppercase s2 513 commonpairs = fromIntegral $ S.size $ S.intersection pairs1 pairs2 514 totalpairs = fromIntegral $ S.size pairs1 + S.size pairs2 515 516wordLetterPairs = concatMap letterPairs . words 517 518letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest) 519letterPairs _ = [] 520