slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add: < at any prompt restarts the current transaction (#47)

Browse Source
This commit is contained in:
Simon Michael 2013-02-23 01:44:45 +00:00
parent 7fcd45614b
commit c8e2751aa5
1 changed files with 38 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
hledger/Hledger/Cli/Add.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
{-| {-|
A history-aware add command to help with data entry. A history-aware add command to help with data entry.
@ -17,6 +18,7 @@ import Data.Char (toUpper)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Time.Calendar import Data.Time.Calendar
import Data.Typeable (Typeable)
import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine) import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine)
import System.Console.Haskeline.Completion import System.Console.Haskeline.Completion
import System.IO ( stderr, hPutStrLn, hPutStr ) import System.IO ( stderr, hPutStrLn, hPutStr )
@ -52,7 +54,7 @@ add opts j
"Adding transactions to journal file "++f "Adding transactions to journal file "++f
,"Provide field values at the prompts, or press enter to accept defaults." ,"Provide field values at the prompts, or press enter to accept defaults."
,"Use readline keys to edit, use tab key to complete account names." ,"Use readline keys to edit, use tab key to complete account names."
-- ,"If you make a mistake, enter < at any prompt to restart the transaction." ,"If you make a mistake, enter < at any prompt to restart the transaction."
,"To record a transaction, enter . when prompted." ,"To record a transaction, enter . when prompted."
,"To quit, press control-d or control-c." ,"To quit, press control-d or control-c."
] ]
@ -73,10 +75,8 @@ getAndAddTransactions j opts defaultDate = do
getAndAddTransactions j opts d getAndAddTransactions j opts d
-- | Read a transaction from the command line, with history-aware prompting. -- | Read a transaction from the command line, with history-aware prompting.
getTransaction :: Journal -> CliOpts -> Day getTransaction :: Journal -> CliOpts -> Day -> IO (Transaction,Day)
-> IO (Transaction,Day)
getTransaction j opts defaultDate = do getTransaction j opts defaultDate = do
today <- getCurrentDay
datestr <- runInteractionDefault $ askFor "date" datestr <- runInteractionDefault $ askFor "date"
(Just $ showDate defaultDate) (Just $ showDate defaultDate)
(Just $ \s -> null s (Just $ \s -> null s
@ -84,6 +84,19 @@ getTransaction j opts defaultDate = do
|| isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) || isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
when (datestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing when (datestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing
description <- runInteractionDefault $ askFor "description" (Just "") Nothing description <- runInteractionDefault $ askFor "description" (Just "") Nothing
let restart = do hPrintf stderr "\nRestarting this transaction..\n\n"
getTransaction j opts defaultDate
if description == "<"
then restart
else do
mr <- getPostingsAndValidateTransaction j opts datestr description
case mr of
Nothing -> restart
Just r -> return r
getPostingsAndValidateTransaction :: Journal -> CliOpts -> String -> String -> IO (Maybe (Transaction,Day))
getPostingsAndValidateTransaction j opts datestr description = do
today <- getCurrentDay
let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description
bestmatch | null historymatches = Nothing bestmatch | null historymatches = Nothing
| otherwise = Just $ snd $ head historymatches | otherwise = Just $ snd $ head historymatches
@ -95,7 +108,7 @@ getTransaction j opts defaultDate = do
else True else True
existingaccts = journalAccountNames j existingaccts = journalAccountNames j
getpostingsandvalidate = do getpostingsandvalidate = do
ps <- getPostings (PostingState j accept True bestmatchpostings) [] ps <- getPostingsWithState (PostingState j accept True bestmatchpostings) []
let t = nulltransaction{tdate=date let t = nulltransaction{tdate=date
,tstatus=False ,tstatus=False
,tdescription=description ,tdescription=description
@ -105,22 +118,20 @@ getTransaction j opts defaultDate = do
let msg' = capitalize msg let msg' = capitalize msg
liftIO $ hPutStrLn stderr $ "\n" ++ msg' ++ "please re-enter." liftIO $ hPutStrLn stderr $ "\n" ++ msg' ++ "please re-enter."
getpostingsandvalidate getpostingsandvalidate
either retry (return . flip (,) date) $ balanceTransaction Nothing t -- imprecise balancing either retry (return . Just . flip (,) date) $ balanceTransaction Nothing t -- imprecise balancing
unless (null historymatches) $ unless (null historymatches) $ liftIO $ hPutStr stderr $
liftIO $ hPutStr stderr $ "\nSimilar transactions found, using the first for defaults:\n"
"\nSimilar transactions found, using the first for defaults:\n" ++ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) (take 3 historymatches)
++ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) (take 3 historymatches) getpostingsandvalidate `catch` \(_::RestartEntryException) -> return Nothing
getpostingsandvalidate
capitalize :: String -> String data RestartEntryException = RestartEntryException deriving (Typeable,Show)
capitalize "" = "" instance Exception RestartEntryException
capitalize (c:cs) = toUpper c : cs
-- fragile -- fragile
-- | Read postings from the command line until . is entered, using any -- | Read postings from the command line until . is entered, using any
-- provided historical postings and the journal context to guess defaults. -- provided historical postings and the journal context to guess defaults.
getPostings :: PostingState -> [Posting] -> IO [Posting] getPostingsWithState :: PostingState -> [Posting] -> IO [Posting]
getPostings st enteredps = do getPostingsWithState st enteredps = do
let bestmatch | isNothing historicalps = Nothing let bestmatch | isNothing historicalps = Nothing
| n <= length ps = Just $ ps !! (n-1) | n <= length ps = Just $ ps !! (n-1)
| otherwise = Nothing | otherwise = Nothing
@ -129,11 +140,12 @@ getPostings st enteredps = do
ordot | null enteredps || length enteredrealps == 1 = "" :: String ordot | null enteredps || length enteredrealps == 1 = "" :: String
| otherwise = " (or . to record)" | otherwise = " (or . to record)"
account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defaultaccount (Just accept) account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defaultaccount (Just accept)
when (account=="<") $ throwIO RestartEntryException
if account=="." if account=="."
then then
if null enteredps if null enteredps
then do hPutStrLn stderr $ "\nPlease enter some postings first." then do hPutStrLn stderr $ "\nPlease enter some postings first."
getPostings st enteredps getPostingsWithState st enteredps
else return enteredps else return enteredps
else do else do
let defaultacctused = Just account == defaultaccount let defaultacctused = Just account == defaultaccount
@ -157,6 +169,7 @@ getPostings st enteredps = do
-- I think 1 or 4, whichever would show the most decimal places -- I think 1 or 4, whichever would show the most decimal places
p = maxprecisionwithpoint p = maxprecisionwithpoint
amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount
when (amountstr=="<") $ throwIO RestartEntryException
let a = fromparse $ runParser (amountp <|> return missingamt) ctx "" amountstr let a = fromparse $ runParser (amountp <|> return missingamt) ctx "" amountstr
a' = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amountstr a' = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amountstr
wasdefaultamtused = Just (showAmount a) == defaultamountstr wasdefaultamtused = Just (showAmount a) == defaultamountstr
@ -171,7 +184,7 @@ getPostings st enteredps = do
else st{psHistory=historicalps', psSuggestHistoricalAmount=False} else st{psHistory=historicalps', psSuggestHistoricalAmount=False}
when (isJust defaultcommodityadded) $ when (isJust defaultcommodityadded) $
liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defaultcommodityadded) liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defaultcommodityadded)
getPostings st' (enteredps ++ [p]) getPostingsWithState st' (enteredps ++ [p])
where where
j = psJournal st j = psJournal st
historicalps = psHistory st historicalps = psHistory st
@ -185,8 +198,9 @@ getPostings st enteredps = do
postingtype ('(':_) = VirtualPosting postingtype ('(':_) = VirtualPosting
postingtype _ = RegularPosting postingtype _ = RegularPosting
validateamount = Just $ \s -> (null s && not (null enteredrealps)) validateamount = Just $ \s -> (null s && not (null enteredrealps))
|| (s /= "." || s == "<"
&& isRight (runParser (amountp >> many spacenonewline >> eof) ctx "" s)) || (isRight (runParser (amountp >> many spacenonewline >> eof) ctx "" s)
&& s /= ".")
-- | Prompt for and read a string value, optionally with a default value -- | Prompt for and read a string value, optionally with a default value
-- and a validator. A validator causes the prompt to repeat until the -- and a validator. A validator causes the prompt to repeat until the
@ -298,3 +312,7 @@ accountCompletion cc = completeWord Nothing
-- can contain spaces. -- can contain spaces.
$ \s -> return $ map simpleCompletion $ \s -> return $ map simpleCompletion
$ filter (s `isPrefixOf`) cc $ filter (s `isPrefixOf`) cc
capitalize :: String -> String
capitalize "" = ""
capitalize (c:cs) = toUpper c : cs