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)
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 -> unless (isEOFError e) $ ioError e)
where f = journalFilePath j
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' []
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 <- runInteractionDefault $ 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
getTransactionOrRestart :: Journal -> CliOpts -> String -> [String] -> IO (Maybe Transaction)
getTransactionOrRestart j opts defdate moredefs = do
let dateandcodep = do {d <- smartdate; c <- optionMaybe code; many spacenonewline; eof; return (d, fromMaybe "" c)}
datecodestr <- runInteractionDefault $ 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 <- runInteractionDefault $ 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
data PostingsState = PostingsState {
psJournal :: Journal
,psAccept :: AccountName -> Bool
,psSuggestHistoricalAmount :: Bool
,psHistory :: Maybe [Posting]
}
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
accept 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 accept 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
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
getPostingsLoop :: PostingsState -> [Posting] -> [String] -> IO [Posting]
getPostingsLoop st enteredps defargs = do
let bestmatch | isNothing historicalps = Nothing
| n <= length ps = Just $ ps !! (n1)
| 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 <- runInteraction j $ askFor (printf "account %d%s" n ordot) defacct (Just accept)
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 !! (n1)
| 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
p = maxprecisionwithpoint
defargs'' = tailDef [] defargs'
amt <- runInteractionDefault $ 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
accept = psAccept 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 /= ".")
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
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) $ do
putStrLn $ printf "\nAdded transaction to %s:" f
putStrLn =<< registerFromString (show t)
return j{jtxns=ts++[t]}
appendToJournalFileOrStdout :: FilePath -> String -> IO ()
appendToJournalFileOrStdout f s
| f == "-" = putStr s'
| otherwise = appendFile f s'
where s' = "\n" ++ ensureOneNewlineTerminated s
ensureOneNewlineTerminated :: String -> String
ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
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}
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 :: Journal -> InputT IO a -> IO a
runInteraction j m = do
let cc = completionCache j
runInputT (setComplete (accountCompletion cc) defaultSettings) m
runInteractionDefault :: InputT IO a -> IO a
runInteractionDefault m = do
runInputT (setComplete noCompletion defaultSettings) m
type CompletionCache = [AccountName]
completionCache :: Journal -> CompletionCache
completionCache j =
Set.toList $ Set.fromList
[paccount p | t <- jtxns j, p <- tpostings t]
accountCompletion :: CompletionCache -> CompletionFunc IO
accountCompletion cc = completeWord Nothing
""
$ \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)