WhatsNew.hs

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

{-# LANGUAGE CPP #-}


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

import Prelude hiding ( (^), catch )

import Control.Applicative ( (<$>) )
import Control.Monad ( void )
import Control.Monad.Reader ( runReaderT )
import Control.Monad.State ( evalStateT, liftIO )
import Storage.Hashed.Tree ( Tree )
import System.Exit ( ExitCode (..), exitSuccess, exitWith )

import Darcs.Patch
    ( PrimOf, PrimPatch, RepoPatch
    , applyToTree, plainSummaryPrims, primIsHunk
    )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Choices ( patchChoicesLps, lpPatch )
import Darcs.Patch.FileHunk ( IsHunk (..) )
import Darcs.Patch.Format ( PatchListFormat (..) )
import Darcs.Patch.Inspect ( PatchInspect (..) )
import Darcs.Patch.Patchy ( Patchy )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.Patch.Prim.Class ( PrimDetails (..) )
import Darcs.Patch.Show ( ShowPatch )
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.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Witnesses.WZipper ( FZipper (..) )
import Darcs.Repository
    ( RepoJob (..), Repository
    , listRegisteredFiles, readRecorded
    , unrecordedChangesWithPatches, withRepository
    )
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Util ( getMovesPs, getReplaces )
import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, amInRepository
    , commandAlias, nodefaults
    )
import Darcs.UI.Commands.Util ( announceFiles )
import Darcs.UI.Flags
    ( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts
    , isUnified, useCache, fixSubPaths
    , verbosity, isInteractive, isUnified, lookForAdds, lookForMoves, lookForReplaces, hasSummary
    )
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, RenderMode(..)
    , text, vcat
    )
import Darcs.Util.Prompt ( PromptConfig (..), promptChar )


whatsnewBasicOpts :: DarcsOption a
                     (Maybe O.Summary
                      -> O.WithContext
                      -> O.LookFor
                      -> O.DiffAlgorithm
                      -> Maybe String
                      -> Maybe Bool
                      -> a)
whatsnewBasicOpts
    = O.summary
    ^ O.withContext
    ^ O.lookfor
    ^ O.diffAlgorithm
    ^ O.workingRepoDir
    ^ O.interactive -- False

whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> Bool -> a)
whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring

whatsnewOpts :: DarcsOption a
                (Maybe O.Summary
                 -> O.WithContext
                 -> O.LookFor
                 -> O.DiffAlgorithm
                 -> Maybe String
                 -> Maybe Bool
                 -> Maybe O.StdCmdAction
                 -> Bool
                 -> Bool
                 -> O.Verbosity
                 -> Bool
                 -> O.UseIndex
                 -> Bool
                 -> O.UseCache
                 -> Maybe String
                 -> Bool
                 -> Maybe String
                 -> Bool
                 -> a)
whatsnewOpts = whatsnewBasicOpts `withStdOpts` whatsnewAdvancedOpts

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts flags = S.PatchSelectionOptions
    { S.verbosity = verbosity flags
    , S.matchFlags = []
    , S.diffAlgorithm = diffAlgorithm flags
    , S.interactive = isInteractive True flags
    , S.selectDeps = O.PromptDeps -- option not supported, use default
    , S.summary = hasSummary (defaultSummary flags) flags
    , S.withContext = isUnified flags
    }

defaultSummary :: [DarcsFlag] -> O.Summary
defaultSummary flags = if lookForAdds flags == O.YesLookForAdds then O.YesSummary else 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
    , commandGetArgPossibilities = listRegisteredFiles
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc whatsnewAdvancedOpts
    , commandBasicOptions = odesc whatsnewBasicOpts
    , commandDefaults = defaultFlags whatsnewOpts
    , commandCheckOptions = ocheck whatsnewOpts
    , commandParseOptions = onormalise whatsnewOpts
    }

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 hunk is known to\n" ++
 "  conflict with a hunk in another patch.  The phrase `duplicated`\n" ++
 "  means the hunk is known to be identical to a hunk in another patch.\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 p wR wU wR) -> do
    files <- if null args
                 then return Nothing
                 else Just <$> fixSubPaths fps args
    let isLookForMoves = lookForMoves opts == O.YesLookForMoves && parseFlags O.summary opts /= Just O.NoSummary
        isLookForAdds = lookForAdds opts == O.YesLookForAdds && parseFlags O.summary opts /= Just O.NoSummary
        isLookForReplaces = lookForReplaces opts == O.YesLookForReplaces
        -- LookForAdds and LookForMoves implies Summary, unless it's explcitly disabled.
        optsModifier = if isLookForAdds
                           then (Summary :) . filter (\o -> LookForAdds /= o &&
                                                            LookForMoves /= o )
                           else id
        opts' = optsModifier opts
    movesPs <- if isLookForMoves
        then getMovesPs repo files
        else return NilFL
    Sealed replacePs <- if isLookForReplaces
        then getReplaces (diffingOpts opts) repo files
        else return (Sealed NilFL)
    Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files movesPs
                                                                       (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)
    pristine <- readRecorded repo
    -- If we are looking for moves, return the corresponding FL of changes.
    -- If we are looking for adds, return the corresponding FL of changes.
    Sealed unaddedNewPathsPs <- if isLookForAdds
        then do
            -- Use opts not opts', here, since we *do* want to look for adds.
            Sealed lookChanges <- filteredUnrecordedChanges opts repo files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)
            noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine
            lookAddsTree <- applyAddPatchesToPristine lookChanges 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)
    announceFiles files "What's new in"
    exitOnNoChanges (unaddedNewPathsPs, noLookChanges)
    if maybeIsInteractive opts
      then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges
      else do
        printChanges opts' pristine noLookChanges
        printUnaddedPaths unaddedNewPathsPs
  where
    -- |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, FL p wU wV) -> IO ()
    exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"
                                        exitWith $ ExitFailure 1
    exitOnNoChanges _ = return ()

    printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO ()
    printUnaddedPaths NilFL = return ()
    printUnaddedPaths ps =
        putDocLn . lowercaseAs . renderString Encode . plainSummaryPrims $ 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.
    printChanges :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PrimDetails p,
                 ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p wX wY
                 -> IO ()
    printChanges opts' pristine changes
        | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes
        | isUnified opts' == O.YesContext = contextualPrintPatch pristine changes
        | otherwise = printPatch changes

    -- |return the unrecorded changes that affect an optional list of paths.
    filteredUnrecordedChanges :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree,
                              ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]
                              -> Repository p wR wU wT -> Maybe [SubPath]
                              -> FL (PrimOf p) wR wT -- look-for-moves patches
                              -> FL (PrimOf p) wT wT -- look-for-replaces patches
                              -> IO (Sealed (FL (PrimOf p) wT))
    filteredUnrecordedChanges  opts' repo files movesPs replacesPs =
        let filePaths = map toFilePath <$> files in
        choosePreTouching filePaths <$> unrecordedChangesWithPatches (diffingOpts opts') repo files movesPs replacesPs

-- | Runs the 'InteractiveSelectionM' code
runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p,
                     PrimPatch p, PatchInspect p, PrimDetails p,
                     ApplyState p ~ Tree)
               => InteractiveSelectionM p wX wY () -- Selection to run
               -> [DarcsFlag]     -- Command-line options
               -> Tree IO         -- Pristine
               -> FL p wX wY      -- A list of patches
               -> IO ()
runInteractive i opts pristine ps' = do
    let (choices',lps') = patchChoicesLps ps'
    let ps = evalStateT i $
             ISC { total   = lengthFL lps'
                 , current = 0
                 , lps     = FZipper NilRL lps'
                 , choices = choices'
                 }
    void $ runReaderT ps $
           selectionContextPrim First "view" (patchSelOpts opts) (Just primSplitter)
             Nothing (Just pristine)

-- | The interactive part of @darcs whatsnew@
interactiveHunks :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch 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 (lpPatch 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 hunk in context
            'v' -> liftIO (contextualPrintPatch pristine (lpPatch lp))
                   >> repeatThis lp
            -- View summary of the change
            'x' -> liftIO (printSummary (lpPatch lp))
                   >> repeatThis lp
            -- View hunk and move on
            'y' -> liftIO (contextualPrintPatch pristine (lpPatch 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 hunk in a pager
            'p' -> liftIO (printPatchPager $ lpPatch lp)
                   >> repeatThis lp
            -- Next hunk
            'j' -> next_hunk
            -- Previous hunk
            '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 hunk in a context"
        , KeyPress 'y'
          "view this hunk in a context and go to the next one"
        , KeyPress 'n' "go to the next hunk" ]
    optionsView =
        [ KeyPress 'p' "view this hunk in context wih pager "
        , KeyPress 'x' "view a summary of this patch"
        ]
    optionsNav =
        [ KeyPress 'q' "quit whatsnew"
        , KeyPress 's' "skip the rest of the changes to this file"
        , KeyPress 'j' "skip to the next hunk"
        , KeyPress 'k' "back up to previous hunk"
        , KeyPress 'g' "start over from the first hunk"
        ]
    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 { commandCommand = statusCmd
                     , commandDescription = statusDesc
                     }
  where
    statusAlias = commandAlias "status" Nothing whatsnew
    statusCmd fps fs = commandCommand whatsnew fps (Summary : LookForAdds : fs)
    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."

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