Add.hs

{-| 

A history-aware add command to help with data entry.

Note: this might not be sensible, but add has some aspirations of being
both user-friendly and pipeable/scriptable and for this reason
informational messages are mostly written to stderr rather than stdout.

-}

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.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)


{- | Information used as the basis for suggested account names, amounts,
     etc in add prompt
-}
data PostingState = PostingState {
      psJournal :: Journal,
      psAccept  :: AccountName -> Bool,
      psSuggestHistoricalAmount :: Bool,
      psHistory :: Maybe [Posting]}

-- | Read transactions from the terminal, prompting for each field,
-- and append them to the journal file. If the journal came from stdin, this
-- command has no effect.
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

-- | Read a number of transactions from the command line, prompting,
-- validating, displaying and appending them to the journal file, until
-- end of input (then raise an EOF exception). Any command-line arguments
-- are used as the first transaction's description.
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

-- | Read a transaction from the command line, with history-aware prompting.
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 x `elem` existingaccts
            else True
      existingaccts = journalAccountNames 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 -- imprecise balancing
  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

-- fragile
-- | Read postings from the command line until . is entered, using any
-- provided historical postings and the journal context to guess defaults.
getPostings :: PostingState -> [Posting] -> IO [Posting]
getPostings st enteredps = do
  let bestmatch | isNothing historicalps = Nothing
                | n <= length ps = Just $ ps !! (n-1)
                | 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 !! (n-1)
                     | 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
                -- what should this be ?
                -- 1 maxprecision (show all decimal places or none) ?
                -- 2 maxprecisionwithpoint (show all decimal places or .0 - avoids some but not all confusion with thousands separators) ?
                -- 3 canonical precision for this commodity in the journal ?
                -- 4 maximum precision entered so far in this transaction ?
                -- 5 3 or 4, whichever would show the most decimal places ?
                -- I think 1 or 4, whichever would show the most decimal places
                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)

-- | Prompt for and read a string value, optionally with a default value
-- and a validator. A validator causes the prompt to repeat until the
-- input is valid. May also raise an EOF exception if control-d is pressed.
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

-- | Append this transaction to the journal's file, and to the journal's
-- transaction list.
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]}

-- | Append a string, typically one or more transactions, to a journal
-- file, or if the file is "-", dump it to stdout.  Tries to avoid
-- excess whitespace.
appendToJournalFileOrStdout :: FilePath -> String -> IO ()
appendToJournalFileOrStdout f s
  | f == "-"  = putStr s'
  | otherwise = appendFile f s'
  where s' = "\n" ++ ensureOneNewlineTerminated s

-- | Replace a string's 0 or more terminating newlines with exactly one.
ensureOneNewlineTerminated :: String -> String
ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse

-- | Convert a string of journal data into a register report.
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}

-- | Return a similarity measure, from 0 to 1, for two strings.
-- This is Simon White's letter pairs algorithm from
-- http://www.catalysoft.com/articles/StrikeAMatch.html
-- with a modification for short strings.
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

-- A precomputed list of all accounts previously entered into the journal.
type CompletionCache = [AccountName]

completionCache :: Journal -> CompletionCache
completionCache j = -- Only keep unique account names.
                    Set.toList $ Set.fromList
                        [paccount p | t <- jtxns j, p <- tpostings t]

accountCompletion :: CompletionCache -> CompletionFunc IO
accountCompletion cc = completeWord Nothing
                        "" -- don't break words on whitespace, since account names
                           -- can contain spaces.
                        $ \s -> return $ map simpleCompletion
                                        $ filter (s `isPrefixOf`) cc