--  Copyright (C) 2002-2004 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

module Darcs.UI.Commands.WhatsNew
    (
      whatsnew
    , status
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( void, when )
import Control.Monad.Reader ( runReaderT )
import Control.Monad.State ( evalStateT, liftIO )
import Darcs.Util.Tree ( Tree )
import System.Exit ( ExitCode (..), exitSuccess, exitWith )
import Data.List.Ordered ( nubSort )

import Darcs.Patch
    ( PrimOf, PrimPatch, RepoPatch
    , applyToTree, plainSummaryPrims, primIsHunk
    )
import Darcs.Patch.Apply ( Apply, ApplyState )
import Darcs.Patch.Choices ( mkPatchChoices, labelPatches, unLabel )
import Darcs.Patch.Commute ( Commute )
import Darcs.Patch.FileHunk ( IsHunk (..) )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Inspect ( PatchInspect (..) )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.Patch.Prim.Class ( PrimDetails (..) )
import Darcs.Patch.Show ( ShowPatch, ShowContextPatch )
import Darcs.Patch.Split ( primSplitter )
import Darcs.Patch.TouchesFiles ( choosePreTouching )
import Darcs.Patch.Witnesses.Ordered
    ( (:>) (..), FL (..), RL (..)
    , lengthFL, reverseFL, reverseRL
    )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed (..), Sealed2 (..)
    , unFreeLeft
    )
import Darcs.Patch.Witnesses.WZipper ( FZipper (..) )
import Darcs.Repository
    ( RepoJob (..), Repository
    , readRecorded
    , unrecordedChanges, withRepository
    )
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, amInRepository
    , commandAlias, nodefaults
    )
import Darcs.UI.Completion ( modifiedFileArgs )
import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )
import Darcs.UI.Flags
    ( DarcsFlag, diffAlgorithm
    , withContext, useCache, fixSubPaths
    , verbosity, isInteractive
    , lookForAdds, lookForMoves, lookForReplaces
    , scanKnown, useIndex, diffingOpts
    )
import Darcs.UI.Options
    ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.PrintPatch
    ( contextualPrintPatch, printPatch
    , printPatchPager
    )
import Darcs.UI.SelectChanges
    ( InteractiveSelectionContext (..)
    , InteractiveSelectionM, KeyPress (..)
    , WhichChanges (..), backAll
    , backOne, currentFile
    , currentPatch, decide
    , decideWholeFile, helpFor
    , keysFor, prompt
    , selectionContextPrim, skipMundane
    , skipOne, printSummary
    )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath )
import Darcs.Util.Printer
    ( putDocLn, renderString
    , text, vcat
    )
import Darcs.Util.Prompt ( PromptConfig (..), promptChar )

commonAdvancedOpts :: DarcsOption a (O.UseIndex -> O.IncludeBoring -> a)
commonAdvancedOpts = O.useIndex ^ O.includeBoring

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts flags = S.PatchSelectionOptions
    { S.verbosity = verbosity ? flags
    , S.matchFlags = []
    , S.interactive = isInteractive True flags
    , S.selectDeps = O.PromptDeps -- option not supported, use default
    , S.summary = getSummary flags
    , S.withContext = withContext ? flags
    }

-- lookForAdds and machineReadable set YesSummary
-- unless NoSummary was given expressly
-- (or by default e.g. status)
getSummary :: [DarcsFlag] -> O.Summary
getSummary flags = case O.maybeSummary Nothing ? flags of
  Just O.NoSummary -> O.NoSummary
  Just O.YesSummary -> O.YesSummary
  Nothing
    | O.yes (lookForAdds flags) -> O.YesSummary
    | O.machineReadable ? flags -> O.YesSummary
    | otherwise -> O.NoSummary

whatsnew :: DarcsCommand [DarcsFlag]
whatsnew = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "whatsnew"
    , commandHelp = whatsnewHelp
    , commandDescription = whatsnewDescription
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
    , commandCommand = whatsnewCmd
    , commandPrereq = amInRepository
    , commandCompleteArgs = modifiedFileArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc commonAdvancedOpts
    , commandBasicOptions = odesc whatsnewBasicOpts
    , commandDefaults = defaultFlags whatsnewOpts
    , commandCheckOptions = ocheck whatsnewOpts
    , commandParseOptions = onormalise whatsnewOpts
    }
  where
    whatsnewBasicOpts
      = O.maybeSummary Nothing
      ^ O.withContext
      ^ O.machineReadable
      ^ O.lookfor
      ^ O.diffAlgorithm
      ^ O.repoDir
      ^ O.interactive -- False
    whatsnewOpts = whatsnewBasicOpts `withStdOpts` commonAdvancedOpts

whatsnewDescription :: String
whatsnewDescription = "List unrecorded changes in the working tree."

whatsnewHelp :: String
whatsnewHelp =
 "The `darcs whatsnew` command lists unrecorded changes to the working\n" ++
 "tree.  If you specify a set of files and directories, only unrecorded\n" ++
 "changes to those files and directories are listed.\n" ++
 "\n" ++
 "With the `--summary` option, the changes are condensed to one line per\n" ++
 "file, with mnemonics to indicate the nature and extent of the change.\n" ++
 "The `--look-for-adds` option causes candidates for `darcs add` to be\n" ++
 "included in the summary output.  Summary mnemonics are as follows:\n" ++
 "\n" ++
 "* `A f` and `A d/` respectively mean an added file or directory.\n" ++
 "* `R f` and `R d/` respectively mean a removed file or directory.\n" ++
 "* `M f -N +M rP` means a modified file, with `N` lines deleted, `M`\n" ++
 "  lines added, and `P` lexical replacements.\n" ++
 "* `f -> g` means a moved file or directory.\n" ++
 "* `a f` and `a d/` respectively mean a new, but unadded, file or\n" ++
 "  directory, when using `--look-for-adds`.\n" ++
 "\n" ++
 "  An exclamation mark (!) as in `R! foo.c`, means the change is known to\n" ++
 "  conflict with a change in another patch.  The phrase `duplicated`\n" ++
 "  means the change is known to be identical to a change in another patch.\n" ++
 "\n" ++
 "The `--machine-readable` option implies `--summary` while making it more\n" ++
 "parsable. Modified files are only shown as `M f`, and moves are shown in\n" ++
 "two lines: `F f` and `T g` (as in 'From f To g').\n" ++
 "\n" ++
 "By default, `darcs whatsnew` uses Darcs' internal format for changes.\n" ++
 "To see some context (unchanged lines) around each change, use the\n" ++
 "`--unified` option.  To view changes in conventional `diff` format, use\n" ++
 "the `darcs diff` command; but note that `darcs whatsnew` is faster.\n" ++
 "\n" ++
 "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++
 "there are no unrecorded changes.\n"

whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
whatsnewCmd fps opts args =
   withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository rt p wR wU wR) -> do
    let scan = scanKnown (lookForAdds opts) (O.includeBoring ? opts)
    existing_files <- do
      files <- if null args then return Nothing
               else Just . nubSort <$> fixSubPaths fps args
      when (files == Just []) $ fail "No valid arguments were given."
      files' <- traverse
        (filterExistingPaths
          repo (verbosity ? opts) (useIndex ? opts) scan (lookForMoves opts))
        files
      let files'' = fmap snd files'
      when (files'' == Just []) $
        fail "None of the files you specified exist."
      return files''

    -- get all unrecorded changes, possibly including unadded or even boring
    -- files if the appropriate options were supplied
    Sealed allInterestingChanges <-
      filteredUnrecordedChanges (diffingOpts opts)
        (lookForMoves opts) (lookForReplaces opts)
        repo existing_files

    -- get the recorded state
    pristine <- readRecorded repo

    -- the case --look-for-adds and --summary must be handled specially
    -- in order to distinguish added and unadded files

    -- TODO: it would be nice if we could return the pair
    -- (noLookChanges,unaddedNewPathsPs) in one go and also
    -- with proper witnesses (e.g. as noLookChanges +>+ unaddedNewPathsPs)
    -- This would also obviate the need for samePatchType.
    Sealed noLookChanges <-
      if haveLookForAddsAndSummary
        then
          -- do *not* look for adds here:
          filteredUnrecordedChanges (O.useIndex ? opts, O.ScanKnown, O.diffAlgorithm ? opts)
            (lookForMoves opts) (lookForReplaces opts)
            repo existing_files
        else return (Sealed NilFL)
    Sealed unaddedNewPathsPs <-
      if haveLookForAddsAndSummary
        then do
          noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine
          lookAddsTree <- applyAddPatchesToPristine allInterestingChanges pristine
          ftf <- filetypeFunction
          -- Return the patches that create files/dirs that aren't yet added.
          unFreeLeft <$> treeDiff (diffAlgorithm ? opts) ftf noLookAddsTree lookAddsTree
        else return (Sealed NilFL)
    -- avoid ambiguous typing for unaddedNewPathsPs:
    samePatchType noLookChanges unaddedNewPathsPs

    exitOnNoChanges allInterestingChanges
    announceFiles (verbosity ? opts) existing_files "What's new in"
    if maybeIsInteractive opts
      then
        runInteractive (interactiveHunks pristine) (patchSelOpts opts)
          (diffAlgorithm ? opts) pristine allInterestingChanges
      else
        if haveLookForAddsAndSummary
          then do
            printChanges pristine noLookChanges
            printUnaddedPaths unaddedNewPathsPs
          else do
            printChanges pristine allInterestingChanges
  where
    haveSummary = O.yes (getSummary opts)
    haveLookForAddsAndSummary = haveSummary && O.yes (lookForAdds opts)

    -- Filter out hunk patches (leaving add patches) and return the tree
    -- resulting from applying the filtered patches to the pristine tree.
    applyAddPatchesToPristine ps pristine = do
        adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps
        applyToTree (reverseRL adds) pristine

    exitOnNoChanges :: FL p wX wY -> IO ()
    exitOnNoChanges NilFL = do putStrLn "No changes!"
                               exitWith $ ExitFailure 1
    exitOnNoChanges _ = return ()

    -- This function does nothing. Its purpose is to enforce the
    -- same patch type for the two passed FLs. This is necessary
    -- in order to avoid ambiguous typing for unaddedNewPathsPs.
    samePatchType :: FL p wX wY -> FL p wU wV -> IO ()
    samePatchType _ _ = return ()

    printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO ()
    printUnaddedPaths NilFL = return ()
    printUnaddedPaths ps =
        putDocLn . lowercaseAs . renderString . (plainSummaryPrims False) $ ps

    -- Make any add markers lowercase, to distinguish new-but-unadded files
    -- from those that are unrecorded, but added.
    lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x
    lowercaseA ('A' : x) = 'a' : x
    lowercaseA x = x

    -- Appropriately print changes, according to the passed flags.
    -- Note this cannot make distinction between unadded and added files.
    printChanges :: ( IsHunk p, ShowPatch p, ShowContextPatch p
                    , PatchListFormat p, Apply p
                    , PrimDetails p, ApplyState p ~ Tree)
                 => Tree IO -> FL p wX wY
                 -> IO ()
    printChanges pristine changes
        | haveSummary = putDocLn $ plainSummaryPrims machineReadable changes
        | O.yes (withContext ? opts) = contextualPrintPatch pristine changes
        | otherwise = printPatch changes
     where machineReadable = parseFlags O.machineReadable opts

    -- return the unrecorded changes that affect an optional list of paths.
    filteredUnrecordedChanges :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                              => (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)
                              -> O.LookForMoves
                              -> O.LookForReplaces
                              -> Repository rt p wR wU wT -> Maybe [SubPath]
                              -> IO (Sealed (FL (PrimOf p) wT))
    filteredUnrecordedChanges diffing lfm lfr repo files =
        let filePaths = map toFilePath <$> files in
        choosePreTouching filePaths <$>
          unrecordedChanges diffing lfm lfr repo files

-- | Runs the 'InteractiveSelectionM' code
runInteractive :: PrimPatch p
               => InteractiveSelectionM p wX wY () -- Selection to run
               -> S.PatchSelectionOptions
               -> O.DiffAlgorithm
               -> Tree IO         -- Pristine
               -> FL p wX wY      -- A list of patches
               -> IO ()
runInteractive i patchsel diffalg pristine ps' = do
    let lps' = labelPatches Nothing ps'
        choices' = mkPatchChoices lps'
        ps = evalStateT i $
             ISC { total   = lengthFL lps'
                 , current = 0
                 , lps     = FZipper NilRL lps'
                 , choices = choices'
                 }
    void $ runReaderT ps $
           selectionContextPrim First "view" patchsel
             (Just (primSplitter diffalg))
             Nothing (Just pristine)

-- | The interactive part of @darcs whatsnew@
interactiveHunks :: (IsHunk p, ShowPatch p, ShowContextPatch p, Commute p,
                     PatchInspect p, PrimDetails p, ApplyState p ~ Tree)
                 => Tree IO -> InteractiveSelectionM p wX wY ()
interactiveHunks pristine = do
    c <- currentPatch
    case c of
        Nothing -> liftIO $ putStrLn "No more changes!"
        Just (Sealed2 lp) -> do
            liftIO $ printPatch (unLabel lp)
            repeatThis lp
  where
    repeatThis lp = do
        thePrompt <- prompt -- "Shall I view this change? (n/m)"
        yorn <- liftIO $ promptChar
                (PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options)
                 (Just 'n') "?h")
        case yorn of
            -- View change in context
            'v' -> liftIO (contextualPrintPatch pristine (unLabel lp))
                   >> repeatThis lp
            -- View summary of the change
            'x' -> liftIO (printSummary (unLabel lp))
                   >> repeatThis lp
            -- View change and move on
            'y' -> liftIO (contextualPrintPatch pristine (unLabel lp))
                   >> decide True lp >> next_hunk
            -- Go to the next patch
            'n' -> decide False lp >> next_hunk
            -- Skip the whole file
            's' -> do
                currentFile >>= maybe
                    (return ())
                    (\f -> decideWholeFile f False)
                next_hunk
            -- View change in a pager
            'p' -> liftIO (printPatchPager $ unLabel lp)
                   >> repeatThis lp
            -- Next change
            'j' -> next_hunk
            -- Previous change
            'k' -> prev_hunk
            -- Start from the first change
            'g' -> start_over
            -- Quit whatsnew
            'q' -> liftIO $ exitSuccess
            _ -> do liftIO . putStrLn $
                        helpFor "whatsnew" basic_options adv_options
                    repeatThis lp
    start_over = backAll >> interactiveHunks pristine
    next_hunk  = skipOne >> skipMundane >> interactiveHunks pristine
    prev_hunk  = backOne >> interactiveHunks pristine
    options_yn =
        [ KeyPress 'v' "view this change in a context"
        , KeyPress 'y' "view this change in a context and go to the next one"
        , KeyPress 'n' "skip this change and its dependencies" ]
    optionsView =
        [ KeyPress 'p' "view this change in context wih pager "
        , KeyPress 'x' "view a summary of this change"
        ]
    optionsNav =
        [ KeyPress 'q' "quit whatsnew"
        , KeyPress 's' "skip the rest of the changes to this file"
        , KeyPress 'j' "go to the next change"
        , KeyPress 'k' "back up to previous change"
        , KeyPress 'g' "start over from the first change"
        ]
    basic_options = [ options_yn ]
    adv_options = [ optionsView, optionsNav ]


-- | status is an alias for whatsnew, with implicit Summary and LookForAdds
-- flags. We override the default description, to include the implicit flags.
status :: DarcsCommand [DarcsFlag]
status = statusAlias
    { commandDescription = statusDesc
    , commandAdvancedOptions = odesc commonAdvancedOpts
    , commandBasicOptions = odesc statusBasicOpts
    , commandDefaults = defaultFlags statusOpts
    , commandCheckOptions = ocheck statusOpts
    , commandParseOptions = onormalise statusOpts
    }
  where
    statusAlias = commandAlias "status" Nothing whatsnew
    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."
    statusBasicOpts
      = O.maybeSummary (Just O.YesSummary)
      ^ O.withContext
      ^ O.machineReadable
      ^ O.lookforadds O.YesLookForAdds
      ^ O.lookforreplaces
      ^ O.lookformoves
      ^ O.diffAlgorithm
      ^ O.repoDir
      ^ O.interactive
    statusOpts = statusBasicOpts `withStdOpts` commonAdvancedOpts

maybeIsInteractive :: [DarcsFlag] -> Bool
maybeIsInteractive = maybe False id . parseFlags O.interactive