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.Time.Calendar (Day)
import Data.Typeable (Typeable)
import Safe (headDef, headMay)
import System.Console.CmdArgs.Explicit
import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
import System.Console.Haskeline.Completion
import System.Console.Wizard
import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.ParserCombinators.Parsec hiding (Line)
import Text.Printf
import Hledger
import Hledger.Cli.Options
import Hledger.Cli.Register (postingsReportAsText)
addmode = (defCommandMode ["add"]) {
modeHelp = "prompt for transactions and add them to the journal"
,modeHelpSuffix = ["Defaults come from previous similar transactions; use query patterns to restrict these."]
,modeGroupFlags = Group {
groupUnnamed = [
flagNone ["no-new-accounts"] (\opts -> setboolopt "no-new-accounts" opts) "don't allow creating new accounts"
]
,groupHidden = []
,groupNamed = [generalflagsgroup2]
}
}
data EntryState = EntryState {
esOpts :: CliOpts
,esArgs :: [String]
,esToday :: Day
,esDefDate :: Day
,esJournal :: Journal
,esSimilarTransaction :: Maybe Transaction
,esPostings :: [Posting]
} 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
add :: CliOpts -> Journal -> IO ()
add opts j
| journalFilePath j == "-" = return ()
| otherwise = do
hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j)
showHelp
today <- getCurrentDay
let es = defEntryState{esOpts=opts
,esArgs=map stripquotes $ listofstringopt "args" $ rawopts_ opts
,esToday=today
,esDefDate=today
,esJournal=j
}
getAndAddTransactions es `E.catch` (\(_::UnexpectedEOF) -> putStr "")
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."
,"To end a transaction, enter . when prompted."
,"To quit, enter . at a date prompt or press control-d or control-c."
]
getAndAddTransactions :: EntryState -> IO ()
getAndAddTransactions es@EntryState{..} = (do
mt <- runInputT (setComplete noCompletion defaultSettings) (run $ haskeline $ confirmedTransactionWizard es)
case mt of
Nothing -> fail "urk ?"
Just t -> do
j <- if debug_ esOpts > 0
then do hPrintf stderr "Skipping journal add due to debug mode.\n"
return esJournal
else do j' <- journalAddTransaction esJournal esOpts t
hPrintf stderr "Saved.\n"
return j'
hPrintf stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)\n"
getAndAddTransactions es{esJournal=j, esDefDate=tdate t}
)
`E.catch` (\(_::RestartTransactionException) ->
hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es)
confirmedTransactionWizard es@EntryState{..} = do
t <- transactionWizard es
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 $ green $ 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
Right t' -> return t'
Left err -> liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ "please re-enter.") >> balancedPostingsWizard
balancedPostingsWizard
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 $
maybeExit $
maybeRestartTransaction $
line $ green $ 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
c <- optionMaybe codep
many spacenonewline
eof
return (d, fromMaybe "" c)
descriptionAndCommentWizard EntryState{..} = do
let def = headDef "" esArgs
s <- withCompletion (descriptionCompleter esJournal def) $
defaultTo' def $ nonEmpty $
maybeRestartTransaction $
line $ green $ printf "Description%s: " (showDefault def)
let (desc,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') s
return (desc,comment)
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 `elem` [".",""]
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
let es1 = es{esArgs=drop 1 esArgs}
(amt,comment) <- amountAndCommentWizard es1
return $ Just nullposting{paccount=stripbrackets acct
,pamount=mixed amt
,pcomment=comment
,ptype=accountNamePostingType acct
}
postingsBalanced :: [Posting] -> Bool
postingsBalanced ps = isRight $ balanceTransaction Nothing nulltransaction{tpostings=ps}
accountWizard EntryState{..} = do
let pnum = length esPostings + 1
historicalp = maybe Nothing (Just . (!! (pnum1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction
historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p)
Nothing -> ""
def = headDef historicalacct esArgs
endmsg | canfinish && null def = " (or . or enter to finish this transaction)"
| canfinish = " (or . to finish this transaction)"
| otherwise = ""
retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $
parser (parseAccountOrDotOrNull def canfinish) $
withCompletion (accountCompleter esJournal def) $
defaultTo' def $
maybeRestartTransaction $
line $ green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)
where
canfinish = not (null esPostings) && postingsBalanced esPostings
parseAccountOrDotOrNull _ _ "." = dbg $ Just "."
parseAccountOrDotOrNull "" True "" = dbg $ Just ""
parseAccountOrDotOrNull def@(_:_) _ "" = dbg $ Just def
parseAccountOrDotOrNull _ _ s = dbg $ either (const Nothing) validateAccount $ parseWithCtx (jContext esJournal) accountnamep s
dbg = id
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s
amountAndCommentWizard EntryState{..} = do
let pnum = length esPostings + 1
(mhistoricalp,followedhistoricalsofar) =
case esSimilarTransaction of
Nothing -> (Nothing,False)
Just Transaction{tpostings=ps} -> (if length ps >= pnum then Just (ps !! (pnum1)) else Nothing
,all (\(a,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 $ green $ printf "Amount %d%s: " pnum (showDefault def)
where
parseAmountAndComment = either (const Nothing) Just . parseWithCtx nodefcommodityctx amountandcommentp
nodefcommodityctx = (jContext esJournal){ctxCommodityAndStyle=Nothing}
amountandcommentp = do
a <- amountp
many spacenonewline
c <- fromMaybe "" `fmap` optionMaybe (char ';' >> many anyChar)
return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
showamt = showMixedAmountWithPrecision
maxprecisionwithpoint
maybeExit = parser (\s -> if s=="." then throw UnexpectedEOF else Just s)
maybeRestartTransaction = parser (\s -> if s=="<" then throw RestartTransactionException else Just s)
dateCompleter :: String -> CompletionFunc IO
dateCompleter = completer ["today","tomorrow","yesterday"]
descriptionCompleter :: Journal -> String -> CompletionFunc IO
descriptionCompleter j = completer (journalDescriptions j)
accountCompleter :: Journal -> String -> CompletionFunc IO
accountCompleter j = completer (journalAccountNamesUsed j)
amountCompleter :: String -> CompletionFunc IO
amountCompleter = completer []
completer :: [String] -> String -> CompletionFunc IO
completer completions def = completeWord Nothing "" completionsFor
where
simpleCompletion' s = (simpleCompletion s){isFinished=False}
completionsFor "" = return [simpleCompletion' def]
completionsFor i = return (map simpleCompletion' ciprefixmatches)
where
ciprefixmatches = [c | c <- completions, i `isPrefixOf` c]
defaultTo' = flip defaultTo
withCompletion f = withSettings (setComplete f defaultSettings)
green s = "\ESC[1;32m\STX"++s++"\ESC[0m\STX"
showDefault "" = ""
showDefault s = " [" ++ s ++ "]"
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]}
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}
capitalize :: String -> String
capitalize "" = ""
capitalize (c:cs) = toUpper c : cs
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"))
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 _ = []