    {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
    {-|

    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 E
    import Control.Monad
    import Control.Monad.Trans (liftIO)
    import Data.Char (toUpper, toLower)
    import Data.List
    import Data.Maybe
    import Data.Typeable (Typeable)
    import Safe (headDef, tailDef, headMay)
    import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine)
    import System.Console.Haskeline.Completion
    import System.IO ( stderr, hPutStr, hPutStrLn )
    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)

    -- | Read multiple transactions from the console, 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
      hPutStr stderr $ unlines [
         "Adding transactions to journal file "++f
        ,"Provide field values at the prompts, or press enter to accept defaults."
        ,"Use readline keys to edit, use tab key to complete account names."
        ,"A code (in parentheses) may be entered following transaction dates."
        ,"A comment may be entered following descriptions or amounts."
        ,"If you make a mistake, enter < at any prompt to restart the transaction."
        ,"To complete a transaction, enter . when prompted."
        ,"To quit, press control-d or control-c."
        ]
      today <- showDate `fmap` getCurrentDay
      let args                = words' $ query_ $ reportopts_ opts
          (defdate, moredefs) = headTailDef today args
      getAndAddTransactionsLoop j opts defdate moredefs
            `E.catch` (\e -> unless (isEOFError e) $ ioError e)
          where f = journalFilePath j

    -- | Loop reading transactions from the console, prompting for,
    -- validating, displaying and appending each one to the journal file,
    -- until end of input or ctrl-c (then raise an EOF exception).
    -- If provided, command-line arguments are used as defaults for the
    -- first transaction; otherwise defaults come from the most similar
    -- recent transaction in the journal.
    getAndAddTransactionsLoop :: Journal -> CliOpts -> String -> [String] -> IO ()
    getAndAddTransactionsLoop j opts defdate moredefs = do
      hPrintf stderr "\nStarting a new transaction.\n"
      t <- getTransaction j opts defdate moredefs
      j' <- journalAddTransaction j opts t
      hPrintf stderr "Added to the journal.\n"
      let defdate' = showDate $ tdate t
      getAndAddTransactionsLoop j' opts defdate' []

    -- | Read a single transaction from the console, with history-aware prompting,
    -- allowing the user to restart and confirm at the end.
    -- A default date, and zero or more defaults for subsequent fields, are provided.
    getTransaction :: Journal -> CliOpts -> String -> [String] -> IO Transaction
    getTransaction j opts defdate moredefs = do
      mt <- getTransactionOrRestart j opts defdate moredefs
      let restart = do
            hPrintf stderr "\nRestarting this transaction.\n"
            getTransaction j opts defdate moredefs
      case mt of
        Nothing -> restart
        Just t  -> do
          hPrintf stderr "\nTransaction entered:\n%s" (show t)
          yn <- runInteractionDefault $ askFor "Accept this transaction" (Just "y") (Just $ \s -> map toLower s `elem` ["<","y","yes","n","no"])
          case headMay $ map toLower yn of
            Just 'y' -> return t
            _        -> restart

    -- | Read a single transaction from the console, with history-aware prompting,
    -- or return nothing indicating that the user wants to restart entering this transaction.
    -- A default date, and zero or more defaults for subsequent fields, are provided.
    getTransactionOrRestart :: Journal -> CliOpts -> String -> [String] -> IO (Maybe Transaction)
    getTransactionOrRestart j opts defdate moredefs = do
      let dateandcodep = do {d <- smartdate; c <- optionMaybe code; many spacenonewline; eof; return (d, fromMaybe "" c)}
      datecodestr <- runInteractionDefault $ askFor "date"
                (Just defdate)
                (Just $ \s -> null s
                             || s == "."
                             || isRight (parseWithCtx nullctx dateandcodep $ lowercase s))
      when (datecodestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing
      today <- getCurrentDay
      let (sdate,code) = fromparse $ parseWithCtx nullctx dateandcodep datecodestr
          defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
          datestr = showDate $ fixSmartDate defday sdate

      let (defdesc, moredefs') = headTailDef "" moredefs
      desc <- runInteractionDefault $ askFor "description" (Just defdesc) Nothing
      if desc == "<"
       then return Nothing
       else do
        let (description,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') desc
        getPostingsForTransactionWithHistory j opts datestr code description comment moredefs'

    data RestartEntryException = RestartEntryException deriving (Typeable,Show)
    instance Exception RestartEntryException

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

    -- | Loop reading postings from the console, until a valid balanced
    -- set of postings has been entered, then return the final transaction,
    -- or nothing indicating that the user wants to restart entering this transaction.
    getPostingsForTransactionWithHistory :: Journal -> CliOpts -> String -> String -> String -> String -> [String] -> IO (Maybe Transaction)
    getPostingsForTransactionWithHistory j opts datestr code description comment defargs = do
      today <- getCurrentDay
      let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description
          bestmatch | not (null defargs) || 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
          getvalidpostings = do
            ps <- getPostingsLoop (PostingsState j accept True bestmatchpostings) [] defargs
            let t = nulltransaction{tdate=date
                                   ,tstatus=False
                                   ,tcode=code
                                   ,tdescription=description
                                   ,tcomment=comment
                                   ,tpostings=ps
                                   }
            either retry (return . Just) $ balanceTransaction Nothing t -- imprecise balancing
              where
                retry msg = liftIO (hPutStrLn stderr $ "\n" ++ (capitalize msg) ++ "please re-enter.") >> getvalidpostings

      when (isJust bestmatch) $ liftIO $ hPrintf stderr "\nUsing this existing transaction for defaults:\n%s" (show $ fromJust bestmatch)
      getvalidpostings `E.catch` \(_::RestartEntryException) -> return Nothing

    -- | Read postings from the command line until . is entered, generating
    -- useful defaults based on historical context and postings entered so far.
    getPostingsLoop :: PostingsState -> [Posting] -> [String] -> IO [Posting]
    getPostingsLoop st enteredps defargs = do
      let bestmatch | isNothing historicalps = Nothing
                    | n <= length ps = Just $ ps !! (n-1)
                    | otherwise = Nothing
                    where Just ps = historicalps
          bestmatchacct = maybe Nothing (Just . showacctname) bestmatch
          defacct  = maybe bestmatchacct Just $ headMay defargs
          defargs' = tailDef [] defargs
          ordot | null enteredps || length enteredrealps == 1 = "" :: String
                | otherwise = " (or . to complete this transaction)"
      account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defacct (Just accept)
      when (account=="<") $ throwIO RestartEntryException
      if account=="."
        then
         if null enteredps
          then do hPutStrLn stderr $ "\nPlease enter some postings first."
                  getPostingsLoop st enteredps defargs
          else return enteredps
        else do
          let defacctused = Just account == defacct
              historicalps' = if defacctused then historicalps else Nothing
              bestmatch' | isNothing historicalps' = Nothing
                         | n <= length ps = Just $ ps !! (n-1)
                         | otherwise = Nothing
                         where Just ps = historicalps'
              defamountstr | isJust commandlineamt                  = commandlineamt
                           | isJust bestmatch' && suggesthistorical = Just historicalamountstr
                           | n > 1                                  = Just balancingamountstr
                           | otherwise                              = Nothing
                  where
                    commandlineamt      = headMay defargs'
                    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
              defargs'' = tailDef [] defargs'
          amt <- runInteractionDefault $ askFor (printf "amount  %d" n) defamountstr validateamount
          when (amt=="<") $ throwIO RestartEntryException
          let (amountstr,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amt
          let a  = fromparse $ runParser (amountp <|> return missingamt) ctx     "" amountstr
              a' = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amountstr
              wasdefamtused = Just (showAmount a) == defamountstr
              defcommodityadded | acommodity a == acommodity a' = Nothing
                                    | otherwise                     = Just $ acommodity a
              p = nullposting{paccount=stripbrackets account
                             ,pamount=mixed a
                             ,pcomment=comment
                             ,ptype=postingtype account
                             }
              st' = if wasdefamtused
                     then st
                     else st{psHistory=historicalps', psSuggestHistoricalAmount=False}
          when (isJust defcommodityadded) $
               liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defcommodityadded)
          getPostingsLoop st' (enteredps ++ [p]) defargs''
        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
          validateamount = Just $ \s -> (null s && not (null enteredrealps))
                                        || s == "<"
                                        || (isRight (runParser (amountp >> many spacenonewline >> optional (char ';' >> many anyChar) >> eof) ctx "" s)
                                            && 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 or control-c 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 "" = ""
            showdef s = "[" ++ s ++ "]"
            eofErr = E.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 > 0) $ 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 ropts (queryFromOpts d ropts) j
          where
            ropts = defreportopts{empty_=True}
            opts = defcliopts{reportopts_=ropts}

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

    capitalize :: String -> String
    capitalize "" = ""
    capitalize (c:cs) = toUpper c : cs

    headTailDef :: a -> [a] -> (a,[a])
    headTailDef defhead as = (headDef defhead as, tailDef [] as)