module Hledger.Cli.Add
where
import Control.Exception (throw)
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.UTF8 (putStr, putStrLn, appendFile)
import Hledger.Cli.Options
import Hledger.Cli.Register (postingsReportAsText)
import Hledger.Cli.Utils
data PostingState = PostingState {
psJournal :: Journal,
psAccept :: AccountName -> Bool,
psSuggestHistoricalAmount :: Bool,
psHistory :: Maybe [Posting]}
add :: CliOpts -> Journal -> IO ()
add opts j
| f == "-" = return ()
| otherwise = do
hPutStrLn stderr $
"Enter one or more transactions, which will be added to your journal file.\n"
++"To complete a transaction, enter . when prompted for an account.\n"
++"To quit, press control-d or control-c."
today <- getCurrentDay
getAndAddTransactions j opts today
`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"
(Just $ showDate defaultDate)
(Just $ \s -> null s ||
isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
description <- runInteractionDefault $ askFor "description" (Just "") Nothing
let historymatches = transactionsSimilarTo j (patterns_ $ 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
account <- runInteraction j $ askFor (printf "account %d" n) defaultaccount (Just accept)
if account=="."
then 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 maxprecisionwithpoint $ pamount $ fromJust bestmatch'
balancingamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ negate $ sum $ map pamount enteredrealps
amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount
let amount = fromparse $ runParser (someamount <|> return missingamt) ctx "" amountstr
amount' = fromparse $ runParser (someamount <|> return missingamt) nullctx "" amountstr
defaultamtused = Just (showMixedAmount amount) == defaultamountstr
commodityadded | c == cwithnodef = Nothing
| otherwise = c
where c = maybemixedamountcommodity amount
cwithnodef = maybemixedamountcommodity amount'
maybemixedamountcommodity = maybe Nothing (Just . commodity) . headMay . amounts
p = nullposting{paccount=stripbrackets account,
pamount=amount,
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 (someamount>>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 = 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
appendToJournalFile f $ showTransaction t
when (debug_ opts) $ do
putStrLn $ printf "\nAdded transaction to %s:" f
putStrLn =<< registerFromString (show t)
return j{jtxns=ts++[t]}
appendToJournalFile :: FilePath -> String -> IO ()
appendToJournalFile f s =
if f == "-"
then putStr $ sep ++ s
else appendFile f $ sep++s
where
sep = "\n\n"
registerFromString :: String -> IO String
registerFromString s = do
d <- getCurrentDay
j <- readJournal' s
return $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts d) 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 -> [String] -> String -> [(Double,Transaction)]
transactionsSimilarTo j apats 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 = jtxns $ filterJournalTransactionsByAccount apats 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