add: show and set defaults from similar past transactions; allow description arguments

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
 
 @