361 lines
17 KiB
Haskell
361 lines
17 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
|
{-|
|
|
|
|
A history-aware add command to help with data entry.
|
|
|
|
Note: this might not be sensible, but add has some aspirations of being
|
|
both user-friendly and pipeable/scriptable and for this reason
|
|
informational messages are mostly written to stderr rather than stdout.
|
|
|
|
-}
|
|
|
|
module Hledger.Cli.Add
|
|
where
|
|
import Control.Exception as E
|
|
import Control.Monad
|
|
import Control.Monad.Trans (liftIO)
|
|
import Data.Char (toUpper, toLower)
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Typeable (Typeable)
|
|
import Safe (headDef, tailDef, headMay)
|
|
import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine)
|
|
import System.Console.Haskeline.Completion
|
|
import System.IO ( stderr, hPutStr, hPutStrLn )
|
|
import System.IO.Error
|
|
import Text.ParserCombinators.Parsec
|
|
import Text.Printf
|
|
import qualified Data.Set as Set
|
|
|
|
import Hledger
|
|
import Prelude hiding (putStr, putStrLn, appendFile)
|
|
import Hledger.Utils.UTF8IOCompat (putStr, putStrLn, appendFile)
|
|
import Hledger.Cli.Options
|
|
import Hledger.Cli.Register (postingsReportAsText)
|
|
|
|
|
|
-- | Read multiple transactions from the console, prompting for each
|
|
-- field, and append them to the journal file. If the journal came
|
|
-- from stdin, this command has no effect.
|
|
add :: CliOpts -> Journal -> IO ()
|
|
add opts j
|
|
| f == "-" = return ()
|
|
| otherwise = do
|
|
hPutStr stderr $ unlines [
|
|
"Adding transactions to journal file "++f
|
|
,"Provide field values at the prompts, or press enter to accept defaults."
|
|
,"Use readline keys to edit, use tab key to complete account names."
|
|
,"A code (in parentheses) may be entered following transaction dates."
|
|
,"A comment may be entered following descriptions or amounts."
|
|
,"If you make a mistake, enter < at any prompt to restart the transaction."
|
|
,"To complete a transaction, enter . when prompted."
|
|
,"To quit, press control-d or control-c."
|
|
]
|
|
today <- showDate `fmap` getCurrentDay
|
|
let args = words' $ query_ $ reportopts_ opts
|
|
(defdate, moredefs) = headTailDef today args
|
|
getAndAddTransactionsLoop j opts defdate moredefs
|
|
`E.catch` (\e -> if isEOFError e then putStr "\n" else ioError e)
|
|
where f = journalFilePath j
|
|
|
|
-- | Loop reading transactions from the console, prompting for,
|
|
-- validating, displaying and appending each one to the journal file,
|
|
-- until end of input or ctrl-c (then raise an EOF exception).
|
|
-- If provided, command-line arguments are used as defaults for the
|
|
-- first transaction; otherwise defaults come from the most similar
|
|
-- recent transaction in the journal.
|
|
getAndAddTransactionsLoop :: Journal -> CliOpts -> String -> [String] -> IO ()
|
|
getAndAddTransactionsLoop j opts defdate moredefs = do
|
|
hPrintf stderr "\nStarting a new transaction.\n"
|
|
t <- getTransaction j opts defdate moredefs
|
|
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.
|
|
getTransaction :: Journal -> CliOpts -> String -> [String] -> IO Transaction
|
|
getTransaction j opts defdate moredefs = do
|
|
mt <- getTransactionOrRestart j opts defdate moredefs
|
|
let restart = do
|
|
hPrintf stderr "\nRestarting this transaction.\n"
|
|
getTransaction j opts defdate moredefs
|
|
case mt of
|
|
Nothing -> restart
|
|
Just t -> do
|
|
hPrintf stderr "\nTransaction entered:\n%s" (show t)
|
|
yn <- runInteraction $ askFor "Accept this transaction" (Just "y") (Just $ \s -> map toLower s `elem` ["<","y","yes","n","no"])
|
|
case headMay $ map toLower yn of
|
|
Just 'y' -> return t
|
|
_ -> restart
|
|
|
|
-- | Read a single transaction from the console, with history-aware prompting,
|
|
-- or return nothing indicating that the user wants to restart entering this transaction.
|
|
-- A default date, and zero or more defaults for subsequent fields, are provided.
|
|
getTransactionOrRestart :: Journal -> CliOpts -> String -> [String] -> IO (Maybe Transaction)
|
|
getTransactionOrRestart j opts defdate moredefs = do
|
|
let dateandcodep = do {d <- smartdate; c <- optionMaybe codep; many spacenonewline; eof; return (d, fromMaybe "" c)}
|
|
datecodestr <- runInteraction $ askFor "date"
|
|
(Just defdate)
|
|
(Just $ \s -> null s
|
|
|| s == "."
|
|
|| isRight (parseWithCtx nullctx dateandcodep $ lowercase s))
|
|
when (datecodestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing
|
|
today <- getCurrentDay
|
|
let (sdate,code) = fromparse $ parseWithCtx nullctx dateandcodep datecodestr
|
|
defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
|
|
datestr = showDate $ fixSmartDate defday sdate
|
|
|
|
let (defdesc, moredefs') = headTailDef "" moredefs
|
|
desc <- runInteraction $ askFor "description" (Just defdesc) Nothing
|
|
if desc == "<"
|
|
then return Nothing
|
|
else do
|
|
let (description,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') desc
|
|
getPostingsForTransactionWithHistory j opts datestr code description comment moredefs'
|
|
|
|
data RestartEntryException = RestartEntryException deriving (Typeable,Show)
|
|
instance Exception RestartEntryException
|
|
|
|
-- | Information used as the basis for suggested account names, amounts etc. in add prompt.
|
|
data PostingsState = PostingsState {
|
|
psJournal :: Journal
|
|
,psValidateAccount :: AccountName -> Bool
|
|
,psSuggestHistoricalAmount :: Bool
|
|
,psHistory :: Maybe [Posting]
|
|
}
|
|
|
|
-- | 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.
|
|
getPostingsForTransactionWithHistory :: Journal -> CliOpts -> String -> String -> String -> String -> [String] -> IO (Maybe Transaction)
|
|
getPostingsForTransactionWithHistory j opts datestr code description comment defargs = do
|
|
today <- getCurrentDay
|
|
let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description
|
|
bestmatch | not (null defargs) || null historymatches = Nothing
|
|
| otherwise = Just $ snd $ head historymatches
|
|
bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch
|
|
date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
|
|
validateaccount x = x == "." || (not . null) x &&
|
|
if no_new_accounts_ opts
|
|
then x `elem` existingaccts
|
|
else True
|
|
existingaccts = journalAccountNames j
|
|
getvalidpostings = do
|
|
ps <- getPostingsLoop (PostingsState j validateaccount True bestmatchpostings) [] defargs
|
|
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 :: PostingsState -> [Posting] -> [String] -> IO [Posting]
|
|
getPostingsLoop st enteredps defargs = do
|
|
let bestmatch | isNothing historicalps = Nothing
|
|
| n <= length ps = Just $ ps !! (n-1)
|
|
| otherwise = Nothing
|
|
where Just ps = historicalps
|
|
bestmatchacct = maybe Nothing (Just . showacctname) bestmatch
|
|
defacct = maybe bestmatchacct Just $ headMay defargs
|
|
defargs' = tailDef [] defargs
|
|
ordot | null enteredps || length enteredrealps == 1 = "" :: String
|
|
| otherwise = " (or . to complete this transaction)"
|
|
account <- runInteractionWithAccountCompletion j $ askFor (printf "account %d%s" n ordot) defacct (Just validateaccount)
|
|
when (account=="<") $ throwIO RestartEntryException
|
|
if account=="."
|
|
then
|
|
if null enteredps
|
|
then do hPutStrLn stderr $ "\nPlease enter some postings first."
|
|
getPostingsLoop st enteredps defargs
|
|
else return enteredps
|
|
else do
|
|
let defacctused = Just account == defacct
|
|
historicalps' = if defacctused then historicalps else Nothing
|
|
bestmatch' | isNothing historicalps' = Nothing
|
|
| n <= length ps = Just $ ps !! (n-1)
|
|
| otherwise = Nothing
|
|
where Just ps = historicalps'
|
|
defamountstr | isJust commandlineamt = commandlineamt
|
|
| isJust bestmatch' && suggesthistorical = Just historicalamountstr
|
|
| n > 1 = Just balancingamountstr
|
|
| otherwise = Nothing
|
|
where
|
|
commandlineamt = headMay defargs'
|
|
historicalamountstr = showMixedAmountWithPrecision p $ pamount $ fromJust bestmatch'
|
|
balancingamountstr = showMixedAmountWithPrecision p $ negate $ sum $ map pamount enteredrealps
|
|
-- what should this be ?
|
|
-- 1 maxprecision (show all decimal places or none) ?
|
|
-- 2 maxprecisionwithpoint (show all decimal places or .0 - avoids some but not all confusion with thousands separators) ?
|
|
-- 3 canonical precision for this commodity in the journal ?
|
|
-- 4 maximum precision entered so far in this transaction ?
|
|
-- 5 3 or 4, whichever would show the most decimal places ?
|
|
-- I think 1 or 4, whichever would show the most decimal places
|
|
p = maxprecisionwithpoint
|
|
defargs'' = tailDef [] defargs'
|
|
amt <- runInteraction $ askFor (printf "amount %d" n) defamountstr validateamount
|
|
when (amt=="<") $ throwIO RestartEntryException
|
|
let (amountstr,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amt
|
|
let a = fromparse $ runParser (amountp <|> return missingamt) ctx "" amountstr
|
|
a' = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amountstr
|
|
wasdefamtused = Just (showAmount a) == defamountstr
|
|
defcommodityadded | acommodity a == acommodity a' = Nothing
|
|
| otherwise = Just $ acommodity a
|
|
p = nullposting{paccount=stripbrackets account
|
|
,pamount=mixed a
|
|
,pcomment=comment
|
|
,ptype=postingtype account
|
|
}
|
|
st' = if wasdefamtused
|
|
then st
|
|
else st{psHistory=historicalps', psSuggestHistoricalAmount=False}
|
|
when (isJust defcommodityadded) $
|
|
liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defcommodityadded)
|
|
getPostingsLoop st' (enteredps ++ [p]) defargs''
|
|
where
|
|
j = psJournal st
|
|
historicalps = psHistory st
|
|
ctx = jContext j
|
|
validateaccount = psValidateAccount st
|
|
suggesthistorical = psSuggestHistoricalAmount st
|
|
n = length enteredps + 1
|
|
enteredrealps = filter isReal enteredps
|
|
showacctname p = showAccountName Nothing (ptype p) $ paccount p
|
|
postingtype ('[':_) = BalancedVirtualPosting
|
|
postingtype ('(':_) = VirtualPosting
|
|
postingtype _ = RegularPosting
|
|
validateamount = Just $ \s -> (null s && not (null enteredrealps))
|
|
|| s == "<"
|
|
|| (isRight (runParser (amountp >> many spacenonewline >> optional (char ';' >> many anyChar) >> eof) ctx "" s)
|
|
&& s /= ".")
|
|
|
|
-- | Prompt for and read a string value, optionally with a default value
|
|
-- 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
|
|
-- transaction list.
|
|
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
|
|
journalAddTransaction j@Journal{jtxns=ts} opts t = do
|
|
let f = journalFilePath j
|
|
appendToJournalFileOrStdout f $ showTransaction t
|
|
when (debug_ opts > 0) $ do
|
|
putStrLn $ printf "\nAdded transaction to %s:" f
|
|
putStrLn =<< registerFromString (show t)
|
|
return j{jtxns=ts++[t]}
|
|
|
|
-- | Append a string, typically one or more transactions, to a journal
|
|
-- file, or if the file is "-", dump it to stdout. Tries to avoid
|
|
-- excess whitespace.
|
|
appendToJournalFileOrStdout :: FilePath -> String -> IO ()
|
|
appendToJournalFileOrStdout f s
|
|
| f == "-" = putStr s'
|
|
| otherwise = appendFile f s'
|
|
where s' = "\n" ++ ensureOneNewlineTerminated s
|
|
|
|
-- | Replace a string's 0 or more terminating newlines with exactly one.
|
|
ensureOneNewlineTerminated :: String -> String
|
|
ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
|
|
|
|
-- | Convert a string of journal data into a register report.
|
|
registerFromString :: String -> IO String
|
|
registerFromString s = do
|
|
d <- getCurrentDay
|
|
j <- readJournal' s
|
|
return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j
|
|
where
|
|
ropts = defreportopts{empty_=True}
|
|
opts = defcliopts{reportopts_=ropts}
|
|
|
|
-- | 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
|
|
-- with a modification for short strings.
|
|
compareStrings :: String -> String -> Double
|
|
compareStrings "" "" = 1
|
|
compareStrings (_:[]) "" = 0
|
|
compareStrings "" (_:[]) = 0
|
|
compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0
|
|
compareStrings s1 s2 = 2.0 * fromIntegral i / fromIntegral u
|
|
where
|
|
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 _ = []
|
|
|
|
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)
|
|
|