add: rewrite using wizards and make it more robust
The code is now much more manageable, faciliating further improvements. Completion now works at all prompts, and will insert the default value if the input area is empty. Account and amount defaults are more robust and useful in various situations. There might be a slight regression with default commodity handling.
This commit is contained in:
Simon Michael
parent
46d594bada
commit
dcdb032d96
@ -1,224 +1,256 @@
|
|||||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}
|
|
||||||
{-|
|
{-|
|
||||||
|
|
||||||
A history-aware add command to help with data entry.
|
A history-aware add command to help with data entry.
|
||||||
|
|-}
|
||||||
|
|
||||||
Note: this might not be sensible, but add has some aspirations of being
|
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
|
||||||
both user-friendly and pipeable/scriptable and for this reason
|
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts #-}
|
||||||
informational messages are mostly written to stderr rather than stdout.
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
module Hledger.Cli.Add
|
module Hledger.Cli.Add
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Exception as E
|
import Control.Exception as E
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans (liftIO)
|
import Control.Monad.Trans (liftIO)
|
||||||
import Data.Char (toUpper, toLower)
|
import Data.Char (toUpper, toLower)
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.Time.Calendar (Day)
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
import Safe (headDef, tailDef, headMay)
|
import Safe (headDef, headMay)
|
||||||
import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine)
|
import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
|
||||||
import System.Console.Haskeline.Completion
|
import System.Console.Haskeline.Completion
|
||||||
|
import System.Console.Wizard
|
||||||
|
import System.Console.Wizard.Haskeline
|
||||||
import System.IO ( stderr, hPutStr, hPutStrLn )
|
import System.IO ( stderr, hPutStr, hPutStrLn )
|
||||||
import System.IO.Error
|
import Text.ParserCombinators.Parsec hiding (Line)
|
||||||
import Text.ParserCombinators.Parsec
|
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
import qualified Data.Set as Set
|
|
||||||
|
|
||||||
import Hledger
|
import Hledger
|
||||||
import Prelude hiding (putStr, putStrLn, appendFile)
|
|
||||||
import Hledger.Utils.UTF8IOCompat (putStr, putStrLn, appendFile)
|
|
||||||
import Hledger.Cli.Options
|
import Hledger.Cli.Options
|
||||||
import Hledger.Cli.Register (postingsReportAsText)
|
import Hledger.Cli.Register (postingsReportAsText)
|
||||||
|
|
||||||
|
-- | State used while entering transactions.
|
||||||
|
data EntryState = EntryState {
|
||||||
|
esOpts :: CliOpts -- ^ command line options
|
||||||
|
,esArgs :: [String] -- ^ command line arguments remaining to be used as defaults
|
||||||
|
,esToday :: Day -- ^ today's date
|
||||||
|
,esDefDate :: Day -- ^ the default date for next transaction
|
||||||
|
,esJournal :: Journal -- ^ the journal we are adding to
|
||||||
|
,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn
|
||||||
|
,esPostings :: [Posting] -- ^ postings entered so far in the current txn
|
||||||
|
} deriving (Show,Typeable)
|
||||||
|
|
||||||
|
defEntryState = EntryState {
|
||||||
|
esOpts = defcliopts
|
||||||
|
,esArgs = []
|
||||||
|
,esToday = nulldate
|
||||||
|
,esDefDate = nulldate
|
||||||
|
,esJournal = nulljournal
|
||||||
|
,esSimilarTransaction = Nothing
|
||||||
|
,esPostings = []
|
||||||
|
}
|
||||||
|
|
||||||
|
data RestartTransactionException = RestartTransactionException deriving (Typeable,Show)
|
||||||
|
instance Exception RestartTransactionException
|
||||||
|
|
||||||
|
-- data ShowHelpException = ShowHelpException deriving (Typeable,Show)
|
||||||
|
-- instance Exception ShowHelpException
|
||||||
|
|
||||||
-- | Read multiple transactions from the console, prompting for each
|
-- | Read multiple transactions from the console, prompting for each
|
||||||
-- field, and append them to the journal file. If the journal came
|
-- field, and append them to the journal file. If the journal came
|
||||||
-- from stdin, this command has no effect.
|
-- from stdin, this command has no effect.
|
||||||
add :: CliOpts -> Journal -> IO ()
|
add :: CliOpts -> Journal -> IO ()
|
||||||
add opts j
|
add opts j
|
||||||
| f == "-" = return ()
|
| journalFilePath j == "-" = return ()
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
hPutStr stderr $ unlines [
|
hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j)
|
||||||
"Adding transactions to journal file "++f
|
showHelp
|
||||||
,"Provide field values at the prompts, or press enter to accept defaults."
|
today <- getCurrentDay
|
||||||
,"Use readline keys to edit, use tab key to complete account names."
|
let es = defEntryState{esOpts=opts
|
||||||
,"A code (in parentheses) may be entered following transaction dates."
|
,esArgs=listofstringopt "args" $ rawopts_ opts
|
||||||
,"A comment may be entered following descriptions or amounts."
|
,esToday=today
|
||||||
|
,esDefDate=today
|
||||||
|
,esJournal=j
|
||||||
|
}
|
||||||
|
getAndAddTransactions es `E.catch` (\(_::UnexpectedEOF) -> putStr "\n")
|
||||||
|
|
||||||
|
showHelp = hPutStr stderr $ unlines [
|
||||||
|
"Any command line arguments will be used as defaults."
|
||||||
|
,"Use tab key to complete, readline keys to edit, enter to accept defaults."
|
||||||
|
,"An optional (CODE) may follow transaction dates."
|
||||||
|
,"An optional ; COMMENT may follow descriptions or amounts."
|
||||||
,"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 complete a transaction, enter . when prompted."
|
,"To finish and save a transaction, enter . when prompted."
|
||||||
,"To quit, press control-d or control-c."
|
,"To end, press control-d or control-c."
|
||||||
]
|
]
|
||||||
today <- showDate `fmap` getCurrentDay
|
|
||||||
let args = words' $ query_ $ reportopts_ opts
|
|
||||||
(defdate, defs) = headTailDef today args
|
|
||||||
getAndAddTransactionsLoop j opts defdate defs
|
|
||||||
`E.catch` (\e -> if isEOFError e then putStr "\n" else ioError e)
|
|
||||||
where f = journalFilePath j
|
|
||||||
|
|
||||||
-- | Loop reading transactions from the console, prompting for,
|
-- | Loop reading transactions from the console, prompting, validating
|
||||||
-- validating, displaying and appending each one to the journal file,
|
-- and appending each one to the journal file, until end of input or
|
||||||
-- until end of input or ctrl-c (then raise an EOF exception).
|
-- ctrl-c (then raise an EOF exception). If provided, command-line
|
||||||
-- If provided, command-line arguments are used as defaults for the
|
-- arguments are used as defaults; otherwise defaults come from the
|
||||||
-- first transaction; otherwise defaults come from the most similar
|
-- most similar recent transaction in the journal.
|
||||||
-- recent transaction in the journal.
|
getAndAddTransactions :: EntryState -> IO ()
|
||||||
getAndAddTransactionsLoop :: Journal -> CliOpts -> String -> [String] -> IO ()
|
getAndAddTransactions es@EntryState{..} = (do
|
||||||
getAndAddTransactionsLoop j opts defdate defs = do
|
mt <- runInputT (setComplete noCompletion defaultSettings) (run $ haskeline $ confirmedTransactionWizard es)
|
||||||
hPrintf stderr "\nStarting a new transaction.\n"
|
|
||||||
t <- getTransactionAndConfirm j opts defdate defs
|
|
||||||
j' <- journalAddTransaction j opts t
|
|
||||||
hPrintf stderr "Added to the journal.\n"
|
|
||||||
let defdate' = showDate $ tdate t
|
|
||||||
getAndAddTransactionsLoop j' opts defdate' []
|
|
||||||
|
|
||||||
-- | Read a single transaction from the console, with history-aware prompting,
|
|
||||||
-- allowing the user to restart and confirm at the end.
|
|
||||||
-- A default date, and zero or more defaults for subsequent fields, are provided.
|
|
||||||
getTransactionAndConfirm :: Journal -> CliOpts -> String -> [String] -> IO Transaction
|
|
||||||
getTransactionAndConfirm j opts defdate defs = do
|
|
||||||
mt <- getTransaction j opts defdate defs
|
|
||||||
let restart = do
|
|
||||||
hPrintf stderr "\nRestarting this transaction.\n"
|
|
||||||
getTransactionAndConfirm j opts defdate defs
|
|
||||||
case mt of
|
case mt of
|
||||||
Nothing -> restart
|
Nothing -> fail "urk ?"
|
||||||
Just t -> do
|
Just t -> do
|
||||||
hPrintf stderr "\nTransaction entered:\n%s" (show t)
|
j <- if debug_ esOpts > 0
|
||||||
yn <- runInteraction $ askFor "Accept this transaction" (Just "y") (Just $ \s -> map toLower s `elem` ["<","y","yes","n","no"])
|
then hPrintf stderr "Skipping journal add due to debug mode.\n" >> return esJournal
|
||||||
case headMay $ map toLower yn of
|
else journalAddTransaction esJournal esOpts t >> hPrintf stderr "Saved.\n"
|
||||||
Just 'y' -> return t
|
hPrintf stderr "Starting the next transaction (or ctrl-D/ctrl-C to end)\n"
|
||||||
_ -> restart
|
getAndAddTransactions es{esJournal=j, esDefDate=tdate t}
|
||||||
|
)
|
||||||
|
`E.catch` (\(_::RestartTransactionException) ->
|
||||||
|
hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es)
|
||||||
|
|
||||||
-- | Read a single transaction from the console, with history-aware prompting,
|
-- confirmedTransactionWizard :: (ArbitraryIO :<: b, OutputLn :<: b, Line :<: b) => EntryState -> Wizard b Transaction
|
||||||
-- or return nothing indicating that the user wants to restart entering this transaction.
|
-- confirmedTransactionWizard :: EntryState -> Wizard Haskeline Transaction
|
||||||
-- A default date, and zero or more defaults for subsequent fields, are provided.
|
confirmedTransactionWizard es@EntryState{..} = do
|
||||||
getTransaction :: Journal -> CliOpts -> String -> [String] -> IO (Maybe Transaction)
|
t <- transactionWizard es
|
||||||
getTransaction j opts defdate defs = do
|
-- liftIO $ hPrintf stderr {- "Transaction entered:\n%s" -} (show t)
|
||||||
let dateandcodep = do
|
output $ show t
|
||||||
|
y <- let def = "y" in
|
||||||
|
retryMsg "Please enter y or n." $
|
||||||
|
parser ((fmap ('y' ==)) . headMay . map toLower . strip) $
|
||||||
|
defaultTo' def $ nonEmpty $
|
||||||
|
maybeRestartTransaction $
|
||||||
|
line $ printf "Save this transaction to the journal ?%s: " (showDefault def)
|
||||||
|
if y then return t else throw RestartTransactionException
|
||||||
|
|
||||||
|
transactionWizard es@EntryState{..} = do
|
||||||
|
(date,code) <- dateAndCodeWizard es
|
||||||
|
let es1@EntryState{esArgs=args1} = es{esArgs=drop 1 esArgs, esDefDate=date}
|
||||||
|
(desc,comment) <- descriptionAndCommentWizard es1
|
||||||
|
let mbaset = similarTransaction es1 desc
|
||||||
|
when (isJust mbaset) $ liftIO $ hPrintf stderr "Using this similar transaction for defaults:\n%s" (show $ fromJust mbaset)
|
||||||
|
let es2 = es1{esArgs=drop 1 args1, esSimilarTransaction=mbaset}
|
||||||
|
balancedPostingsWizard = do
|
||||||
|
ps <- postingsWizard es2{esPostings=[]}
|
||||||
|
let t = nulltransaction{tdate=date
|
||||||
|
,tstatus=False
|
||||||
|
,tcode=code
|
||||||
|
,tdescription=desc
|
||||||
|
,tcomment=comment
|
||||||
|
,tpostings=ps
|
||||||
|
}
|
||||||
|
case balanceTransaction Nothing t of -- imprecise balancing (?)
|
||||||
|
Right t' -> return t'
|
||||||
|
Left err -> liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ "please re-enter.") >> balancedPostingsWizard
|
||||||
|
balancedPostingsWizard
|
||||||
|
|
||||||
|
-- Identify the closest recent match for this description in past transactions.
|
||||||
|
similarTransaction :: EntryState -> String -> Maybe Transaction
|
||||||
|
similarTransaction EntryState{..} desc =
|
||||||
|
let q = queryFromOptsOnly esToday $ reportopts_ esOpts
|
||||||
|
historymatches = transactionsSimilarTo esJournal q desc
|
||||||
|
bestmatch | null historymatches = Nothing
|
||||||
|
| otherwise = Just $ snd $ head historymatches
|
||||||
|
in bestmatch
|
||||||
|
|
||||||
|
dateAndCodeWizard EntryState{..} = do
|
||||||
|
let def = headDef (showDate esDefDate) esArgs
|
||||||
|
retryMsg "A valid hledger smart date is required. Eg: 2014/2/14, 14, yesterday." $
|
||||||
|
parser (parseSmartDateAndCode esToday) $
|
||||||
|
withCompletion (dateCompleter def) $
|
||||||
|
defaultTo' def $ nonEmpty $
|
||||||
|
maybeRestartTransaction $
|
||||||
|
-- maybeShowHelp $
|
||||||
|
line $ printf "Date%s: " (showDefault def)
|
||||||
|
where
|
||||||
|
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
|
||||||
|
where
|
||||||
|
edc = parseWithCtx nullctx dateandcodep $ lowercase s
|
||||||
|
dateandcodep = do
|
||||||
d <- smartdate
|
d <- smartdate
|
||||||
c <- optionMaybe codep
|
c <- optionMaybe codep
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
eof
|
eof
|
||||||
return (d, fromMaybe "" c)
|
return (d, fromMaybe "" c)
|
||||||
validate s = null s
|
-- defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
|
||||||
|| s == "."
|
-- datestr = showDate $ fixSmartDate defday smtdate
|
||||||
|| isRight (parseWithCtx nullctx dateandcodep $ lowercase s)
|
|
||||||
dateandcode <- runInteraction $ askFor "date" (Just defdate) (Just validate)
|
descriptionAndCommentWizard EntryState{..} = do
|
||||||
when (dateandcode == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing
|
let def = headDef "" esArgs
|
||||||
today <- getCurrentDay
|
s <- withCompletion (descriptionCompleter esJournal def) $
|
||||||
let (smtdate,code) = fromparse $ parseWithCtx nullctx dateandcodep dateandcode
|
defaultTo' def $ nonEmpty $
|
||||||
defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
|
maybeRestartTransaction $
|
||||||
datestr = showDate $ fixSmartDate defday smtdate
|
line $ printf "Description%s: " (showDefault def)
|
||||||
let (defdesc, defs') = headTailDef "" defs
|
let (desc,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') s
|
||||||
desc <- runInteraction $ askFor "description" (Just defdesc) Nothing
|
return (desc,comment)
|
||||||
if desc == "<"
|
|
||||||
then return Nothing
|
postingsWizard es@EntryState{..} = do
|
||||||
|
mp <- postingWizard es
|
||||||
|
case mp of Nothing -> return esPostings
|
||||||
|
Just p -> postingsWizard es{esArgs=drop 2 esArgs, esPostings=esPostings++[p]}
|
||||||
|
|
||||||
|
postingWizard es@EntryState{..} = do
|
||||||
|
acct <- accountWizard es
|
||||||
|
if acct == "."
|
||||||
|
then case (esPostings, postingsBalanced esPostings) of
|
||||||
|
([],_) -> liftIO (hPutStrLn stderr "Please enter some postings first.") >> postingWizard es
|
||||||
|
(_,False) -> liftIO (hPutStrLn stderr "Please enter more postings to balance the transaction.") >> postingWizard es
|
||||||
|
(_,True) -> return Nothing
|
||||||
else do
|
else do
|
||||||
let (description,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') desc
|
let es1 = es{esArgs=drop 1 esArgs}
|
||||||
getPostingsForTransaction j opts datestr code description comment defs'
|
(amt,comment) <- amountAndCommentWizard es1
|
||||||
|
return $ Just nullposting{paccount=stripbrackets acct
|
||||||
data RestartEntryException = RestartEntryException deriving (Typeable,Show)
|
|
||||||
instance Exception RestartEntryException
|
|
||||||
|
|
||||||
-- | State used while entering a single transaction.
|
|
||||||
data EntryState = EntryState {
|
|
||||||
esJournal :: Journal -- ^ the journal we are adding to
|
|
||||||
,esOpts :: CliOpts -- ^ command line options
|
|
||||||
,esDefaultsRemaining :: [String] -- ^ command line arguments not yet used as defaults
|
|
||||||
,esHistoricalPostings :: Maybe [Posting] -- ^ postings of the most similar past txn, if applicable
|
|
||||||
,esEnteredPostings :: [Posting] -- ^ postings entered so far
|
|
||||||
}
|
|
||||||
|
|
||||||
defEntryState = EntryState {
|
|
||||||
esJournal = nulljournal
|
|
||||||
,esOpts = defcliopts
|
|
||||||
,esDefaultsRemaining = []
|
|
||||||
,esHistoricalPostings = Nothing
|
|
||||||
,esEnteredPostings = []
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Loop reading postings from the console, until a valid balanced
|
|
||||||
-- set of postings has been entered, then return the final transaction,
|
|
||||||
-- or nothing indicating that the user wants to restart entering this transaction.
|
|
||||||
getPostingsForTransaction :: Journal -> CliOpts -> String -> String -> String -> String -> [String] -> IO (Maybe Transaction)
|
|
||||||
getPostingsForTransaction j opts datestr code description comment defs = do
|
|
||||||
today <- getCurrentDay
|
|
||||||
let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description
|
|
||||||
bestmatch | not (null defs) || null historymatches = Nothing
|
|
||||||
| otherwise = Just $ snd $ head historymatches
|
|
||||||
bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch
|
|
||||||
date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
|
|
||||||
getvalidpostings = do
|
|
||||||
let st = defEntryState{esJournal=j
|
|
||||||
,esOpts=opts
|
|
||||||
,esDefaultsRemaining=defs
|
|
||||||
,esHistoricalPostings=bestmatchpostings
|
|
||||||
}
|
|
||||||
ps <- getPostingsLoop st
|
|
||||||
let t = nulltransaction{tdate=date
|
|
||||||
,tstatus=False
|
|
||||||
,tcode=code
|
|
||||||
,tdescription=description
|
|
||||||
,tcomment=comment
|
|
||||||
,tpostings=ps
|
|
||||||
}
|
|
||||||
either retry (return . Just) $ balanceTransaction Nothing t -- imprecise balancing
|
|
||||||
where
|
|
||||||
retry msg = liftIO (hPutStrLn stderr $ "\n" ++ (capitalize msg) ++ "please re-enter.") >> getvalidpostings
|
|
||||||
|
|
||||||
when (isJust bestmatch) $ liftIO $ hPrintf stderr "\nUsing this existing transaction for defaults:\n%s" (show $ fromJust bestmatch)
|
|
||||||
getvalidpostings `E.catch` \(_::RestartEntryException) -> return Nothing
|
|
||||||
|
|
||||||
-- | Read postings from the command line until . is entered, generating
|
|
||||||
-- useful defaults based on historical context and postings entered so far.
|
|
||||||
getPostingsLoop :: EntryState -> IO [Posting]
|
|
||||||
getPostingsLoop st = do
|
|
||||||
(st1,account) <- getAccount st
|
|
||||||
if account=="."
|
|
||||||
then case esEnteredPostings st of
|
|
||||||
[] -> hPutStrLn stderr "\nPlease enter some postings first." >> getPostingsLoop st
|
|
||||||
ps -> return ps
|
|
||||||
else do
|
|
||||||
(st2,amt,comment) <- getAmountAndComment st1
|
|
||||||
let p = nullposting{paccount=stripbrackets account
|
|
||||||
,pamount=mixed amt
|
,pamount=mixed amt
|
||||||
,pcomment=comment
|
,pcomment=comment
|
||||||
,ptype=accountNamePostingType account
|
,ptype=accountNamePostingType acct
|
||||||
}
|
}
|
||||||
getPostingsLoop st2{esEnteredPostings=esEnteredPostings st2 ++ [p]}
|
|
||||||
|
|
||||||
getAccount :: EntryState -> IO (EntryState,AccountName)
|
postingsBalanced :: [Posting] -> Bool
|
||||||
getAccount st@EntryState{..} = do
|
postingsBalanced ps = isRight $ balanceTransaction Nothing nulltransaction{tpostings=ps}
|
||||||
let pnum = length esEnteredPostings + 1
|
|
||||||
mhistoricalacct = maybe Nothing (Just . showacctname) mhistoricalp
|
accountWizard EntryState{..} = do
|
||||||
|
let pnum = length esPostings + 1
|
||||||
|
historicalp = maybe Nothing (Just . (!! (pnum-1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction
|
||||||
|
historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p)
|
||||||
|
Nothing -> ""
|
||||||
|
def = headDef historicalacct esArgs
|
||||||
|
retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $
|
||||||
|
parser parseAccount $
|
||||||
|
withCompletion (accountCompleter esJournal def) $
|
||||||
|
defaultTo' def $ nonEmpty $
|
||||||
|
maybeRestartTransaction $
|
||||||
|
line $ printf "Account %d%s%s: " pnum endmsg (showDefault def)
|
||||||
where
|
where
|
||||||
mhistoricalp | isNothing esHistoricalPostings = Nothing
|
canfinish = not (null esPostings) && postingsBalanced esPostings
|
||||||
| pnum <= length historicalps = Just $ historicalps !! (pnum-1)
|
endmsg | canfinish = " (or . to finish this transaction)"
|
||||||
| otherwise = Nothing
|
| otherwise = ""
|
||||||
where Just historicalps = esHistoricalPostings
|
parseAccount s = either (const Nothing) validateAccount $ parseWithCtx (jContext esJournal) accountnamep s
|
||||||
showacctname p = showAccountName Nothing (ptype p) $ paccount p
|
validateAccount s | null s = Nothing
|
||||||
(mdefacct, st1) = case esDefaultsRemaining of
|
| no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
|
||||||
d:ds -> (Just d, st{esDefaultsRemaining=ds})
|
| otherwise = Just s
|
||||||
[] -> (mhistoricalacct, st)
|
|
||||||
endmsg | null esEnteredPostings || numenteredrealps == 1 = "" :: String
|
|
||||||
| otherwise = " (or . to complete this transaction)"
|
|
||||||
where numenteredrealps = length $ filter isReal esEnteredPostings
|
|
||||||
validate s = s == "."
|
|
||||||
|| (not . null) s
|
|
||||||
&& (not (no_new_accounts_ esOpts) || s `elem` journalAccountNames esJournal)
|
|
||||||
account <- runInteractionWithAccountCompletion esJournal $
|
|
||||||
askFor (printf "account %d%s" pnum endmsg) mdefacct (Just validate)
|
|
||||||
if (account=="<")
|
|
||||||
then throwIO RestartEntryException
|
|
||||||
else let defacctaccepted = Just account == mdefacct
|
|
||||||
st2 = if defacctaccepted then st1 else st1{esHistoricalPostings=Nothing}
|
|
||||||
in return (st2, account)
|
|
||||||
|
|
||||||
getAmountAndComment :: EntryState -> IO (EntryState,Amount,String)
|
amountAndCommentWizard EntryState{..} = do
|
||||||
getAmountAndComment st@EntryState{..} = do
|
let pnum = length esPostings + 1
|
||||||
let pnum = length esEnteredPostings + 1
|
(mhistoricalp,followedhistoricalsofar) =
|
||||||
|
case esSimilarTransaction of
|
||||||
|
Nothing -> (Nothing,False)
|
||||||
|
Just Transaction{tpostings=ps} -> (if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing
|
||||||
|
,all (\(a,b) -> paccount a == paccount b && pamount a == pamount b) $ zip esPostings ps)
|
||||||
|
def = case (esArgs, mhistoricalp, followedhistoricalsofar) of
|
||||||
|
(d:_,_,_) -> d
|
||||||
|
(_,Just hp,True) -> showamt $ pamount hp
|
||||||
|
_ | pnum > 1 && not (isZeroMixedAmount balancingamt) -> showamt balancingamt
|
||||||
|
_ -> ""
|
||||||
|
retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." $
|
||||||
|
parser parseAmountAndComment $
|
||||||
|
withCompletion (amountCompleter def) $
|
||||||
|
defaultTo' def $ nonEmpty $
|
||||||
|
maybeRestartTransaction $
|
||||||
|
line $ printf "Amount %d%s: " pnum (showDefault def)
|
||||||
|
where
|
||||||
|
parseAmountAndComment = either (const Nothing) Just . parseWithCtx (jContext esJournal) amountandcommentp
|
||||||
|
amountandcommentp = do
|
||||||
|
a <- amountp
|
||||||
|
many spacenonewline
|
||||||
|
c <- fromMaybe "" `fmap` optionMaybe (char ';' >> many anyChar)
|
||||||
|
-- eof
|
||||||
|
return (a,c)
|
||||||
|
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
|
||||||
showamt = showMixedAmountWithPrecision
|
showamt = showMixedAmountWithPrecision
|
||||||
-- what should this be ?
|
-- what should this be ?
|
||||||
-- 1 maxprecision (show all decimal places or none) ?
|
-- 1 maxprecision (show all decimal places or none) ?
|
||||||
@ -228,64 +260,61 @@ getAmountAndComment st@EntryState{..} = do
|
|||||||
-- 5 3 or 4, whichever would show the most decimal places ?
|
-- 5 3 or 4, whichever would show the most decimal places ?
|
||||||
-- I think 1 or 4, whichever would show the most decimal places
|
-- I think 1 or 4, whichever would show the most decimal places
|
||||||
maxprecisionwithpoint
|
maxprecisionwithpoint
|
||||||
mhistoricalamt = maybe Nothing (Just . showamt . pamount) mhistoricalp
|
--
|
||||||
|
-- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
|
||||||
|
-- a = fromparse $ runParser (amountp <|> return missingamt) (jContext esJournal) "" amt
|
||||||
|
-- awithoutctx = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amt
|
||||||
|
-- defamtaccepted = Just (showAmount a) == mdefamt
|
||||||
|
-- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing}
|
||||||
|
-- mdefaultcommodityapplied = if acommodity a == acommodity awithoutctx then Nothing else Just $ acommodity a
|
||||||
|
-- when (isJust mdefaultcommodityapplied) $
|
||||||
|
-- liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied)
|
||||||
|
|
||||||
|
maybeRestartTransaction = parser (\s -> if s=="<" then throw RestartTransactionException else Just s)
|
||||||
|
|
||||||
|
-- maybeShowHelp :: Wizard Haskeline String -> Wizard Haskeline String
|
||||||
|
-- maybeShowHelp wizard = maybe (liftIO showHelp >> wizard) return $
|
||||||
|
-- parser (\s -> if s=="?" then Nothing else Just s) wizard
|
||||||
|
|
||||||
|
simpleCompletion' s = (simpleCompletion s){isFinished=False}
|
||||||
|
|
||||||
|
dateCompleter :: String -> CompletionFunc IO
|
||||||
|
dateCompleter def = completeWord Nothing "" f
|
||||||
where
|
where
|
||||||
mhistoricalp | isNothing esHistoricalPostings = Nothing
|
f "" = return [simpleCompletion' def]
|
||||||
| pnum <= length historicalps = Just $ historicalps !! (pnum-1)
|
f s = return $ map simpleCompletion' $ filter (s `isPrefixOf`) cs
|
||||||
| otherwise = Nothing
|
cs = ["today","tomorrow","yesterday"]
|
||||||
where Just historicalps = esHistoricalPostings
|
|
||||||
enteredrealps = filter isReal esEnteredPostings
|
descriptionCompleter j def = completeWord Nothing "" f
|
||||||
(mdefamt, st1) = case esDefaultsRemaining of
|
|
||||||
d:ds -> (Just d, st{esDefaultsRemaining=ds})
|
|
||||||
_ | isJust mhistoricalamt -> (mhistoricalamt, st)
|
|
||||||
_ | pnum > 1 -> (Just balancingamt, st)
|
|
||||||
_ -> (Nothing, st)
|
|
||||||
where
|
where
|
||||||
balancingamt = showamt $ negate $ sum $ map pamount enteredrealps
|
f "" = return [simpleCompletion' def]
|
||||||
validateamount = Just $ \s ->
|
f s = return $ map simpleCompletion' $ filter (s `isPrefixOf`) cs
|
||||||
(null s && not (null enteredrealps))
|
-- f s = return $ map simpleCompletion' $ filter ((lowercase s `isPrefixOf`) . lowercase) cs
|
||||||
|| s == "<"
|
cs = journalDescriptions j
|
||||||
|| (s /= "." && isRight (runParser amountandoptionalcommentp (jContext esJournal) "" s))
|
|
||||||
|
accountCompleter j def = completeWord Nothing "" f
|
||||||
where
|
where
|
||||||
amountandoptionalcommentp = do
|
f "" = return [simpleCompletion' def]
|
||||||
amountp
|
f s = return $ map simpleCompletion' $ filter (s `isPrefixOf`) cs
|
||||||
many spacenonewline
|
cs = journalAccountNamesUsed j
|
||||||
optional (char ';' >> many anyChar)
|
|
||||||
eof
|
amountCompleter def = completeWord Nothing "" f
|
||||||
amtcmt <- runInteraction $ askFor (printf "amount %d" pnum) mdefamt validateamount
|
where
|
||||||
when (amtcmt=="<") $ throwIO RestartEntryException
|
f "" = return [simpleCompletion' def]
|
||||||
let (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
|
f _ = return []
|
||||||
a = fromparse $ runParser (amountp <|> return missingamt) (jContext esJournal) "" amt
|
|
||||||
awithoutctx = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amt
|
--------------------------------------------------------------------------------
|
||||||
defamtaccepted = Just (showAmount a) == mdefamt
|
|
||||||
st2 = if defamtaccepted then st1 else st1{esHistoricalPostings=Nothing}
|
|
||||||
mdefaultcommodityapplied = if acommodity a == acommodity awithoutctx then Nothing else Just $ acommodity a
|
|
||||||
when (isJust mdefaultcommodityapplied) $
|
|
||||||
liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied)
|
|
||||||
return (st2, a, comment)
|
|
||||||
|
|
||||||
-- utilities
|
-- utilities
|
||||||
|
|
||||||
-- | Prompt for and read a string value, optionally with a default value
|
defaultTo' = flip defaultTo
|
||||||
-- and a validator. A validator causes the prompt to repeat until the
|
|
||||||
-- input is valid. May also raise an EOF exception if control-d or control-c is pressed.
|
|
||||||
askFor :: String -> Maybe String -> Maybe (String -> Bool) -> InputT IO String
|
|
||||||
askFor prompt def validator = do
|
|
||||||
l <- fmap (maybe eofErr id)
|
|
||||||
$ getInputLine $ prompt ++ " ? " ++ maybe "" showdef def ++ ": "
|
|
||||||
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
|
|
||||||
where
|
|
||||||
showdef "" = ""
|
|
||||||
showdef s = "[" ++ s ++ "]"
|
|
||||||
eofErr = E.throw $ mkIOError eofErrorType "end of input" Nothing Nothing
|
|
||||||
|
|
||||||
-- | Append this transaction to the journal's file, and to the journal's
|
withCompletion f = withSettings (setComplete f defaultSettings)
|
||||||
-- transaction list.
|
|
||||||
|
showDefault "" = ""
|
||||||
|
showDefault s = " [" ++ s ++ "]"
|
||||||
|
|
||||||
|
-- | Append this transaction to the journal's file and transaction list.
|
||||||
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
|
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
|
||||||
journalAddTransaction j@Journal{jtxns=ts} opts t = do
|
journalAddTransaction j@Journal{jtxns=ts} opts t = do
|
||||||
let f = journalFilePath j
|
let f = journalFilePath j
|
||||||
@ -318,6 +347,28 @@ registerFromString s = do
|
|||||||
ropts = defreportopts{empty_=True}
|
ropts = defreportopts{empty_=True}
|
||||||
opts = defcliopts{reportopts_=ropts}
|
opts = defcliopts{reportopts_=ropts}
|
||||||
|
|
||||||
|
capitalize :: String -> String
|
||||||
|
capitalize "" = ""
|
||||||
|
capitalize (c:cs) = toUpper c : cs
|
||||||
|
|
||||||
|
-- Find the most similar and recent transactions matching the given transaction description and report query.
|
||||||
|
-- Transactions are listed with their "relevancy" score, most relevant first.
|
||||||
|
transactionsSimilarTo :: Journal -> Query -> String -> [(Double,Transaction)]
|
||||||
|
transactionsSimilarTo j q desc =
|
||||||
|
sortBy compareRelevanceAndRecency
|
||||||
|
$ filter ((> threshold).fst)
|
||||||
|
[(compareDescriptions desc $ tdescription t, t) | t <- ts]
|
||||||
|
where
|
||||||
|
compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)
|
||||||
|
ts = filter (q `matchesTransaction`) $ jtxns j
|
||||||
|
threshold = 0
|
||||||
|
|
||||||
|
compareDescriptions :: [Char] -> [Char] -> Double
|
||||||
|
compareDescriptions s t = compareStrings s' t'
|
||||||
|
where s' = simplify s
|
||||||
|
t' = simplify t
|
||||||
|
simplify = filter (not . (`elem` "0123456789"))
|
||||||
|
|
||||||
-- | Return a similarity measure, from 0 to 1, for two strings.
|
-- | Return a similarity measure, from 0 to 1, for two strings.
|
||||||
-- This is Simon White's letter pairs algorithm from
|
-- This is Simon White's letter pairs algorithm from
|
||||||
-- http://www.catalysoft.com/articles/StrikeAMatch.html
|
-- http://www.catalysoft.com/articles/StrikeAMatch.html
|
||||||
@ -333,54 +384,8 @@ compareStrings s1 s2 = 2.0 * fromIntegral i / fromIntegral u
|
|||||||
u = length pairs1 + length pairs2
|
u = length pairs1 + length pairs2
|
||||||
pairs1 = wordLetterPairs $ uppercase s1
|
pairs1 = wordLetterPairs $ uppercase s1
|
||||||
pairs2 = wordLetterPairs $ uppercase s2
|
pairs2 = wordLetterPairs $ uppercase s2
|
||||||
|
|
||||||
wordLetterPairs = concatMap letterPairs . words
|
wordLetterPairs = concatMap letterPairs . words
|
||||||
|
|
||||||
letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
|
letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
|
||||||
letterPairs _ = []
|
letterPairs _ = []
|
||||||
|
|
||||||
compareDescriptions :: [Char] -> [Char] -> Double
|
|
||||||
compareDescriptions s t = compareStrings s' t'
|
|
||||||
where s' = simplify s
|
|
||||||
t' = simplify t
|
|
||||||
simplify = filter (not . (`elem` "0123456789"))
|
|
||||||
|
|
||||||
transactionsSimilarTo :: Journal -> Query -> String -> [(Double,Transaction)]
|
|
||||||
transactionsSimilarTo j q s =
|
|
||||||
sortBy compareRelevanceAndRecency
|
|
||||||
$ filter ((> threshold).fst)
|
|
||||||
[(compareDescriptions s $ tdescription t, t) | t <- ts]
|
|
||||||
where
|
|
||||||
compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)
|
|
||||||
ts = filter (q `matchesTransaction`) $ jtxns j
|
|
||||||
threshold = 0
|
|
||||||
|
|
||||||
runInteraction :: InputT IO a -> IO a
|
|
||||||
runInteraction m = do
|
|
||||||
runInputT (setComplete noCompletion defaultSettings) m
|
|
||||||
|
|
||||||
runInteractionWithAccountCompletion :: Journal -> InputT IO a -> IO a
|
|
||||||
runInteractionWithAccountCompletion j m = do
|
|
||||||
let cc = completionCache j
|
|
||||||
runInputT (setComplete (accountCompletion cc) defaultSettings) m
|
|
||||||
|
|
||||||
-- A precomputed list of all accounts previously entered into the journal.
|
|
||||||
type CompletionCache = [AccountName]
|
|
||||||
|
|
||||||
completionCache :: Journal -> CompletionCache
|
|
||||||
completionCache j = -- Only keep unique account names.
|
|
||||||
Set.toList $ Set.fromList
|
|
||||||
[paccount p | t <- jtxns j, p <- tpostings t]
|
|
||||||
|
|
||||||
accountCompletion :: CompletionCache -> CompletionFunc IO
|
|
||||||
accountCompletion cc = completeWord Nothing
|
|
||||||
"" -- don't break words on whitespace, since account names
|
|
||||||
-- can contain spaces.
|
|
||||||
$ \s -> return $ map simpleCompletion
|
|
||||||
$ filter (s `isPrefixOf`) cc
|
|
||||||
|
|
||||||
capitalize :: String -> String
|
|
||||||
capitalize "" = ""
|
|
||||||
capitalize (c:cs) = toUpper c : cs
|
|
||||||
|
|
||||||
headTailDef :: a -> [a] -> (a,[a])
|
|
||||||
headTailDef defhead as = (headDef defhead as, tailDef [] as)
|
|
||||||
|
|
||||||
|
|||||||
@ -142,6 +142,7 @@ executable hledger
|
|||||||
,time
|
,time
|
||||||
,utf8-string >= 0.3.5 && < 0.4
|
,utf8-string >= 0.3.5 && < 0.4
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
,wizards == 1.0.*
|
||||||
|
|
||||||
test-suite tests
|
test-suite tests
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
|
|||||||
@ -5,14 +5,14 @@
|
|||||||
hledgerdev -f $$-add.j add; rm -f $$-add.j
|
hledgerdev -f $$-add.j add; rm -f $$-add.j
|
||||||
<<<
|
<<<
|
||||||
2009/1/32
|
2009/1/32
|
||||||
>>> /date .*: date .*/
|
>>> /A valid hledger smart date is required/
|
||||||
>>>=0
|
>>>=0
|
||||||
|
|
||||||
# 2. should accept a blank date
|
# 2. should accept a blank date
|
||||||
hledgerdev -f $$-add.j add; rm -f $$-add.j
|
hledgerdev -f $$-add.j add; rm -f $$-add.j
|
||||||
<<<
|
<<<
|
||||||
|
|
||||||
>>> /date .*: description /
|
>>> /Date .*: Description:/
|
||||||
>>>=0
|
>>>=0
|
||||||
|
|
||||||
##############################################################################
|
##############################################################################
|
||||||
@ -28,7 +28,7 @@ a
|
|||||||
b
|
b
|
||||||
|
|
||||||
.
|
.
|
||||||
>>> /^date.*: description.*: account 1.*: amount 1.*: account 2.*: amount 2.*: account 3.*or \. to complete.*: Accept.*: $/
|
>>> /^Date.*: Description.*: Account 1.*: Amount 1.*: Account 2.*: Amount 2.*: Account 3.*or \. to finish.*:/
|
||||||
>>>=0
|
>>>=0
|
||||||
|
|
||||||
# 4. default commodity with greater precision
|
# 4. default commodity with greater precision
|
||||||
@ -111,7 +111,7 @@ a
|
|||||||
b
|
b
|
||||||
0.5
|
0.5
|
||||||
c
|
c
|
||||||
>>> /amount 3 \? \[-0.75\]/
|
>>> /Amount 3 \[-0.75\]:/
|
||||||
>>>=0
|
>>>=0
|
||||||
|
|
||||||
## 10. shouldn't add decimals if there aren't any
|
## 10. shouldn't add decimals if there aren't any
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user