diff --git a/AddCommand.hs b/AddCommand.hs index e3312406f..6a723f465 100644 --- a/AddCommand.hs +++ b/AddCommand.hs @@ -1,11 +1,12 @@ {-| -A simple add command to help with data entry. +An add command to help with data entry. -} module AddCommand where +-- import Data.List.Utils (replace) import Ledger import Options import RegisterCommand (showRegisterReport) @@ -24,29 +25,40 @@ add opts args l | otherwise = do hPutStrLn stderr ("Please enter one or more transactions, which will be added to your ledger file.\n\ \A blank account or amount ends a transaction, control-d to finish.") - ts <- getAndAddTransactions l - hPutStrLn stderr $ printf "\nAdded %d transactions to %s ." (length ts) (filepath $ rawledger l) + ts <- getAndAddTransactions l args + hPutStrLn stderr $ printf "\nAdded %d transactions to %s" (length ts) (filepath $ rawledger l) -- | Read a number of ledger transactions from the command line, -- prompting, validating, displaying and appending them to the ledger -- file, until EOF. -getAndAddTransactions :: Ledger -> IO [LedgerTransaction] -getAndAddTransactions l = (do - t <- getTransaction l >>= addTransaction l - liftM (t:) (getAndAddTransactions l) +getAndAddTransactions :: Ledger -> [String] -> IO [LedgerTransaction] +getAndAddTransactions l args = (do + t <- getTransaction l args >>= addTransaction l + liftM (t:) (getAndAddTransactions l args) ) `catch` (\e -> if isEOFError e then return [] else ioError e) -- | Read a transaction from the command line. -getTransaction :: Ledger -> IO LedgerTransaction -getTransaction l = do +getTransaction :: Ledger -> [String] -> IO LedgerTransaction +getTransaction l args = do today <- getCurrentDay datestr <- askFor "date" (Just $ showDate today) (Just $ \s -> null s || (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) let date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr - description <- askFor "description" Nothing (Just $ not . null) + description <- if null args + then askFor "description" Nothing (Just $ not . null) + else (do + hPutStrLn stderr $ "description: " ++ unwords args + return $ unwords args) + let historymatches = transactionsSimilarTo l description + when (not $ null historymatches) (do + hPutStrLn stderr "Similar past transactions:" + hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches) + let bestmatch | null historymatches = Nothing + | otherwise = Just $ snd $ head $ historymatches + let bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch let getpostingsandvalidate = do - ps <- getPostings [] + ps <- getPostings bestmatchpostings [] let t = nullledgertxn{ltdate=date ,ltstatus=False ,ltdescription=description @@ -59,21 +71,28 @@ getTransaction l = do getpostingsandvalidate -- | Read two or more postings from the command line. -getPostings :: [Posting] -> IO [Posting] -getPostings prevps = do - account <- askFor (printf "account %d" n) Nothing (Just $ \s -> not $ null s && (length prevps < 2)) +getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting] +getPostings bestmatchps enteredps = do + account <- askFor (printf "account %d" n) + (maybe Nothing (Just . paccount) bestmatch) + (Just $ \s -> not $ null s && (length enteredps < 2)) if null account - then return prevps + then return enteredps else do amount <- liftM (fromparse . parse (someamount <|> return missingamt) "") - $ askFor (printf "amount %d" n) Nothing - (Just $ \s -> (null s && (not $ null prevps)) || + $ askFor (printf "amount %d" n) + (maybe Nothing (Just . show . pamount) bestmatch) + (Just $ \s -> (null s && (not $ null enteredps)) || (isRight $ parse (someamount>>many spacenonewline>>eof) "" s)) let p = nullrawposting{paccount=account,pamount=amount} if amount == missingamt - then return $ prevps ++ [p] - else getPostings $ prevps ++ [p] - where n = length prevps + 1 + then return $ enteredps ++ [p] + else getPostings bestmatchps $ enteredps ++ [p] + where n = length enteredps + 1 + bestmatch | isNothing bestmatchps = Nothing + | n <= length ps = Just $ ps !! (n-1) + | otherwise = Nothing + where Just ps = bestmatchps -- | Prompt and read a string value, possibly with a default and a validator. -- A validator will cause the prompt to repeat until the input is valid. @@ -116,6 +135,33 @@ registerFromString s = do l <- ledgerFromStringWithOpts [] [] now s return $ showRegisterReport [] [] l +-- | Simon White's letter pairs algorithm from +-- http://www.catalysoft.com/articles/StrikeAMatch.html +compareStrings s t = 2.0 * (fromIntegral i) / (fromIntegral u) + where + pairs1 = wordLetterPairs $ uppercase s + pairs2 = wordLetterPairs $ uppercase t + u = length pairs1 + length pairs2 + i = length $ intersect pairs1 pairs2 +wordLetterPairs = concatMap letterPairs . words +letterPairs (a:b:rest) = [a,b]:(letterPairs (b:rest)) +letterPairs _ = [] + +compareLedgerDescriptions s t = compareStrings s' t' + where s' = simplify s + t' = simplify t + simplify = filter (not . (`elem` "0123456789")) + +transactionsSimilarTo :: Ledger -> String -> [(Float,LedgerTransaction)] +transactionsSimilarTo l s = + sortBy compareRelevanceAndRecency + $ filter ((/=0).fst) + $ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts] + -- $ [(compareLedgerDescriptions s $ (strace $ unwords $ [ltdescription t] ++ (map (replace ":" " " . paccount) $ ltpostings t)), t) | t <- ts] + where + compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1) + ts = ledger_txns $ rawledger l + {- doctests @