module Hledger.Cli.Add
where
import Control.Exception as C
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Char (toUpper)
import Data.List
import Data.Maybe
import Data.Time.Calendar
import Safe (headMay)
import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine)
import System.Console.Haskeline.Completion
import System.IO ( stderr, hPutStrLn, hPutStr )
import System.IO.Error
import Text.ParserCombinators.Parsec
import Text.Printf
import qualified Data.Foldable as Foldable (find)
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)
data PostingState = PostingState {
psJournal :: Journal,
psAccept :: AccountName -> Bool,
psSuggestHistoricalAmount :: Bool,
psHistory :: Maybe [Posting]}
add :: CliOpts -> Journal -> IO ()
add opts j
| f == "-" = return ()
| otherwise = do
hPrintf stderr "Adding transactions to journal file \"%s\".\n" f
hPutStrLn stderr $
"To complete a transaction, enter . (period) at an account prompt.\n"
++"To stop adding transactions, enter . at a date prompt, or control-d/control-c."
today <- getCurrentDay
getAndAddTransactions j opts today
`C.catch` (\e -> unless (isEOFError e) $ ioError e)
where f = journalFilePath j
getAndAddTransactions :: Journal -> CliOpts -> Day -> IO ()
getAndAddTransactions j opts defaultDate = do
(t, d) <- getTransaction j opts defaultDate
j <- journalAddTransaction j opts t
getAndAddTransactions j opts d
getTransaction :: Journal -> CliOpts -> Day
-> IO (Transaction,Day)
getTransaction j opts defaultDate = do
today <- getCurrentDay
datestr <- runInteractionDefault $ askFor "date, or . to end"
(Just $ showDate defaultDate)
(Just $ \s -> null s
|| s == "."
|| isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
when (datestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing
description <- runInteractionDefault $ askFor "description" (Just "") Nothing
let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description
bestmatch | 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 isJust $ Foldable.find (== x) ant
else True
where (ant,_,_,_) = groupPostings $ journalPostings j
getpostingsandvalidate = do
ps <- getPostings (PostingState j accept True bestmatchpostings) []
let t = nulltransaction{tdate=date
,tstatus=False
,tdescription=description
,tpostings=ps
}
retry msg = do
liftIO $ hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter."
getpostingsandvalidate
either retry (return . flip (,) date) $ balanceTransaction Nothing t
unless (null historymatches)
(liftIO $ do
hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"
hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)
getpostingsandvalidate
getPostings :: PostingState -> [Posting] -> IO [Posting]
getPostings st enteredps = do
let bestmatch | isNothing historicalps = Nothing
| n <= length ps = Just $ ps !! (n1)
| otherwise = Nothing
where Just ps = historicalps
defaultaccount = maybe Nothing (Just . showacctname) bestmatch
ordot | null enteredps || length enteredrealps == 1 = ""
| otherwise = ", or . to record"
account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defaultaccount (Just accept)
if account=="."
then
if null enteredps
then do hPutStrLn stderr $ "\nPlease enter some postings first."
getPostings st enteredps
else return enteredps
else do
let defaultacctused = Just account == defaultaccount
historicalps' = if defaultacctused then historicalps else Nothing
bestmatch' | isNothing historicalps' = Nothing
| n <= length ps = Just $ ps !! (n1)
| otherwise = Nothing
where Just ps = historicalps'
defaultamountstr | isJust bestmatch' && suggesthistorical = Just historicalamountstr
| n > 1 = Just balancingamountstr
| otherwise = Nothing
where
historicalamountstr = showMixedAmountWithPrecision p $ pamount $ fromJust bestmatch'
balancingamountstr = showMixedAmountWithPrecision p $ negate $ sum $ map pamount enteredrealps
p = maxprecisionwithpoint
amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount
let a = fromparse $ runParser (amount <|> return missingmixedamt) ctx "" amountstr
a' = fromparse $ runParser (amount <|> return missingmixedamt) nullctx "" amountstr
defaultamtused = Just (showMixedAmount a) == defaultamountstr
commodityadded | c == cwithnodef = Nothing
| otherwise = c
where c = maybemixedamountcommodity a
cwithnodef = maybemixedamountcommodity a'
maybemixedamountcommodity = maybe Nothing (Just . commodity) . headMay . amounts
p = nullposting{paccount=stripbrackets account,
pamount=a,
ptype=postingtype account}
st' = if defaultamtused then st
else st{psHistory = historicalps',
psSuggestHistoricalAmount = False}
when (isJust commodityadded) $
liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (symbol $ fromJust commodityadded)
getPostings st' (enteredps ++ [p])
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
stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse
validateamount = Just $ \s -> (null s && not (null enteredrealps))
|| isRight (runParser (amount>>many spacenonewline>>eof) ctx "" 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 s = " [" ++ s ++ "]"
eofErr = C.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 opts (queryFromOpts d opts) j
where opts = defreportopts{empty_=True}
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