module Hledger.Cli.Add
where
import Prelude ()
import Prelude.Compat
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO)
import Data.Char (toUpper, toLower)
import Data.List.Compat
import qualified Data.Set as S
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
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.Megaparsec
import Text.Megaparsec.Text
import Text.Printf
import Hledger
import Hledger.Cli.CliOptions
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 (T.unpack . stripquotes . T.pack) $ 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=Uncleared
,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 -> Text -> 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 = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
dateandcodep :: Parser (SmartDate, Text)
dateandcodep = do
d <- smartdate
c <- optional codep
many spacenonewline
eof
return (d, T.pack $ 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) = (T.pack $ strip a, T.pack $ 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=T.pack $ stripbrackets acct
,pamount=Mixed [amt]
,pcomment=comment
,ptype=accountNamePostingType $ T.pack 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 :: String -> Bool -> String -> Maybe String
parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "."
parseAccountOrDotOrNull "" True "" = dbg1 $ Just ""
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def
parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $
either (const Nothing) validateAccount $
flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s)
where
validateAccount :: Text -> Maybe Text
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just t
dbg1 = id
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 balancingamtfirstcommodity
_ -> ""
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 s = either (const Nothing) Just $
runParser
(evalStateT (amountandcommentp <* eof) nodefcommodityj)
""
(T.pack s)
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: JournalParser (Amount, Text)
amountandcommentp = do
a <- amountp
lift (many spacenonewline)
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar)
return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
balancingamtfirstcommodity = Mixed $ take 1 $ amounts balancingamt
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 (map T.unpack $ journalDescriptions j)
accountCompleter :: Journal -> String -> CompletionFunc IO
accountCompleter j = completer (map T.unpack $ 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 $ showTransactionUnelided 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' $ T.pack 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 -> Text -> [(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 :: Text -> Text -> Double
compareDescriptions s t = compareStrings s' t'
where s' = simplify $ T.unpack s
t' = simplify $ T.unpack t
simplify = filter (not . (`elem` ("0123456789" :: String)))
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 * commonpairs / totalpairs
where
pairs1 = S.fromList $ wordLetterPairs $ uppercase s1
pairs2 = S.fromList $ wordLetterPairs $ uppercase s2
commonpairs = fromIntegral $ S.size $ S.intersection pairs1 pairs2
totalpairs = fromIntegral $ S.size pairs1 + S.size pairs2
wordLetterPairs = concatMap letterPairs . words
letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
letterPairs _ = []