try to make the add command a bit more usable
This commit is contained in:
Simon Michael
parent
c0c9c7a070
commit
e2d14aebb7
185
AddCommand.hs
185
AddCommand.hs
@ -6,7 +6,6 @@ An add command to help with data entry.
|
||||
|
||||
module AddCommand
|
||||
where
|
||||
-- import Data.List.Utils (replace)
|
||||
import Prelude hiding (putStr, putStrLn, getLine, appendFile)
|
||||
import Ledger
|
||||
import Options
|
||||
@ -18,73 +17,93 @@ import Text.ParserCombinators.Parsec
|
||||
import Utils (ledgerFromStringWithOpts)
|
||||
|
||||
|
||||
-- | Read ledger transactions from the command line, prompting for each
|
||||
-- field, and append them to the ledger file. If the ledger came from
|
||||
-- stdin, this command has no effect.
|
||||
-- | Read ledger transactions from the terminal, prompting for each field,
|
||||
-- and append them to the ledger file. If the ledger came from stdin, this
|
||||
-- command has no effect.
|
||||
add :: [Opt] -> [String] -> Ledger -> IO ()
|
||||
add opts args l
|
||||
| filepath (rawledger l) == "-" = return ()
|
||||
| otherwise = do
|
||||
hPutStrLn stderr ("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 args
|
||||
hPutStrLn stderr $ printf "\nAdded %d transactions to %s" (length ts) (filepath $ rawledger l)
|
||||
hPutStrLn stderr
|
||||
"Enter one or more transactions, which will be added to your ledger file.\n\
|
||||
\To complete a transaction, enter . as account name.\n\
|
||||
\To finish input, enter control-d (discards any transaction in progress)."
|
||||
getAndAddTransactions l args
|
||||
return ()
|
||||
|
||||
-- | Read a number of ledger transactions from the command line,
|
||||
-- prompting, validating, displaying and appending them to the ledger
|
||||
-- file, until EOF.
|
||||
-- file, until end of input.
|
||||
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)
|
||||
getAndAddTransactions l args = do
|
||||
-- for now, thread the eoi flag throughout rather than muck about with monads
|
||||
(t, eoi) <- getTransaction l args
|
||||
l <- if isJust t then addTransaction l (fromJust t) else return l
|
||||
if eoi then return $ maybe [] (:[]) t
|
||||
else liftM (fromJust t:) (getAndAddTransactions l args)
|
||||
|
||||
-- | Read a transaction from the command line.
|
||||
getTransaction :: Ledger -> [String] -> IO LedgerTransaction
|
||||
-- | Get a transaction from the command line, if possible, and a flag
|
||||
-- indicating end of input.
|
||||
getTransaction :: Ledger -> [String] -> IO (Maybe LedgerTransaction, Bool)
|
||||
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 <- 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 bestmatchpostings []
|
||||
let t = nullledgertxn{ltdate=date
|
||||
,ltstatus=False
|
||||
,ltdescription=description
|
||||
,ltpostings=ps
|
||||
}
|
||||
either (const retry) (return) $ balanceLedgerTransaction t
|
||||
retry = do
|
||||
hPutStrLn stderr $ nonzerobalanceerror ++ ". Re-enter:"
|
||||
getpostingsandvalidate
|
||||
getpostingsandvalidate
|
||||
|
||||
-- | Read two or more postings from the command line.
|
||||
getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting]
|
||||
getPostings bestmatchps enteredps = do
|
||||
account <- askFor (printf "account %d" n) defaultaccount validateaccount
|
||||
if null account
|
||||
then return enteredps
|
||||
(datestr, eoi) <- askFor "date"
|
||||
(Just $ showDate today)
|
||||
(Just $ \s -> null s ||
|
||||
(isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
|
||||
if eoi
|
||||
then return (Nothing, True)
|
||||
else do
|
||||
amountstr <- askFor (printf "amount %d" n) defaultamount validateamount
|
||||
(description, eoi) <- if null args
|
||||
then askFor "description" Nothing (Just $ not . null)
|
||||
else (do
|
||||
let description = unwords args
|
||||
hPutStrLn stderr $ "description: " ++ description
|
||||
return (description, False))
|
||||
if eoi
|
||||
then return (Nothing, True)
|
||||
else do
|
||||
let historymatches = transactionsSimilarTo l description
|
||||
when (not $ null historymatches) (do
|
||||
hPutStrLn stderr "Similar past transactions found:"
|
||||
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
|
||||
bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch
|
||||
date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
|
||||
getpostingsandvalidate = do
|
||||
(ps, eoi) <- getPostings bestmatchpostings []
|
||||
let t = nullledgertxn{ltdate=date
|
||||
,ltstatus=False
|
||||
,ltdescription=description
|
||||
,ltpostings=ps
|
||||
}
|
||||
if eoi && null ps
|
||||
then return (Nothing, eoi)
|
||||
else either (const retry) (return . flip (,) eoi . Just) $ balanceLedgerTransaction t
|
||||
retry = do
|
||||
hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"
|
||||
getpostingsandvalidate
|
||||
getpostingsandvalidate
|
||||
|
||||
-- | Get two or more postings from the command line, if possible, and a
|
||||
-- flag indicating end of input.
|
||||
getPostings :: Maybe [Posting] -> [Posting] -> IO ([Posting], Bool)
|
||||
getPostings bestmatchps enteredps = do
|
||||
(account, eoi) <- askFor (printf "account %d" n) defaultaccount validateaccount
|
||||
if account=="." || eoi
|
||||
then return (enteredps, eoi)
|
||||
else do
|
||||
(amountstr, eoi) <- askFor (printf "amount %d" n) defaultamount validateamount
|
||||
let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr
|
||||
let p = nullrawposting{paccount=account,pamount=amount}
|
||||
if amount == missingamt
|
||||
then return $ enteredps ++ [p]
|
||||
else getPostings bestmatchps $ enteredps ++ [p]
|
||||
if eoi
|
||||
then if null enteredps
|
||||
then return ([], True)
|
||||
else return (enteredps ++ [p], True)
|
||||
else if amount == missingamt
|
||||
then return $ (enteredps ++ [p], eoi)
|
||||
else getPostings bestmatchps $ enteredps ++ [p]
|
||||
where
|
||||
n = length enteredps + 1
|
||||
bestmatch | isNothing bestmatchps = Nothing
|
||||
@ -92,32 +111,44 @@ getPostings bestmatchps enteredps = do
|
||||
| otherwise = Nothing
|
||||
where Just ps = bestmatchps
|
||||
defaultaccount = maybe Nothing (Just . paccount) bestmatch
|
||||
validateaccount = Just $ \s -> not $ null s && (length enteredps < 2)
|
||||
validateaccount = Just $ \s -> not $ null s
|
||||
defaultamount = maybe Nothing (Just . show . pamount) bestmatch
|
||||
validateamount = Just $ \s ->
|
||||
(null s && (not $ null enteredps)) ||
|
||||
(isRight $ parse (someamount>>many spacenonewline>>eof) "" s)
|
||||
|
||||
|
||||
-- | 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.
|
||||
askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO String
|
||||
-- | Prompt for and read a string value and a flag indicating whether
|
||||
-- input has ended (control-d was pressed), optionally with a default
|
||||
-- value and a validator. A validator will cause the prompt to repeat
|
||||
-- until the input is valid (unless the input is just ctrl-d).
|
||||
askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO (String, Bool)
|
||||
askFor prompt def validator = do
|
||||
hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": "
|
||||
hFlush stderr
|
||||
l <- getLine
|
||||
let input = if null l then fromMaybe l def else l
|
||||
-- ugly
|
||||
l <- getLine `catch` (\e -> if isEOFError e then return "*EOF*" else ioError e)
|
||||
let (l', eoi) = case l of "*EOF*" -> ("", True)
|
||||
_ -> (l, False)
|
||||
let input = if null l' then fromMaybe l' def else l'
|
||||
case validator of
|
||||
Just valid -> if valid input then return input else askFor prompt def validator
|
||||
Nothing -> return input
|
||||
Just valid -> if valid input || (null input && eoi)
|
||||
then return (input, eoi)
|
||||
else askFor prompt def validator
|
||||
Nothing -> return (input, eoi)
|
||||
where showdef s = " [" ++ s ++ "]"
|
||||
|
||||
-- | Append this transaction to the ledger's file.
|
||||
addTransaction :: Ledger -> LedgerTransaction -> IO LedgerTransaction
|
||||
-- | Append this transaction to the ledger's file. Also, to the ledger's
|
||||
-- transaction list, but we don't bother updating the other fields - this
|
||||
-- is enough to include new transactions in the history matching.
|
||||
addTransaction :: Ledger -> LedgerTransaction -> IO Ledger
|
||||
addTransaction l t = do
|
||||
putStrLn =<< registerFromString (show t)
|
||||
appendToLedgerFile l $ show t
|
||||
return t
|
||||
putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l)
|
||||
putStrLn =<< registerFromString (show t)
|
||||
return l{rawledger=rl{ledger_txns=ts}}
|
||||
where rl = rawledger l
|
||||
ts = ledger_txns rl ++ [t]
|
||||
|
||||
-- | Append data to the ledger's file, ensuring proper separation from any
|
||||
-- existing data; or if the file is "-", dump it to stdout.
|
||||
@ -138,16 +169,23 @@ registerFromString :: String -> IO String
|
||||
registerFromString s = do
|
||||
now <- getCurrentLocalTime
|
||||
l <- ledgerFromStringWithOpts [] [] now s
|
||||
return $ showRegisterReport [] [] l
|
||||
return $ showRegisterReport [Empty] [] l
|
||||
|
||||
-- | Simon White's letter pairs algorithm from
|
||||
-- | Return a similarity measure, from 0 to 1, for two strings.
|
||||
-- This is Simon White's letter pairs algorithm from
|
||||
-- http://www.catalysoft.com/articles/StrikeAMatch.html
|
||||
compareStrings s t = 2.0 * (fromIntegral i) / (fromIntegral u)
|
||||
-- with a modification for short strings.
|
||||
compareStrings :: String -> String -> Float
|
||||
compareStrings "" "" = 1
|
||||
compareStrings (a:[]) "" = 0
|
||||
compareStrings "" (b:[]) = 0
|
||||
compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0
|
||||
compareStrings s1 s2 = 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
|
||||
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 _ = []
|
||||
@ -160,12 +198,13 @@ compareLedgerDescriptions s t = compareStrings s' t'
|
||||
transactionsSimilarTo :: Ledger -> String -> [(Float,LedgerTransaction)]
|
||||
transactionsSimilarTo l s =
|
||||
sortBy compareRelevanceAndRecency
|
||||
$ filter ((/=0).fst)
|
||||
$ filter ((> threshold).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
|
||||
threshold = 0
|
||||
|
||||
{- doctests
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user