-- Copyright (C) 2003-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.Diff ( diffCommand, getDiffDoc ) where import Prelude () import Darcs.Prelude hiding ( all ) import System.FilePath.Posix ( takeFileName, () ) import Darcs.Util.Workaround ( getCurrentDirectory ) import Darcs.Util.File ( withCurrentDirectory ) import Darcs.Util.Prompt ( askEnter ) import Control.Monad ( when ) import Data.List ( (\\) ) import Darcs.Util.Tree.Plain( writePlainTree ) import Darcs.Util.Tree.Hashed( hashedTreeIO ) import Data.Maybe ( isJust ) import System.Directory ( findExecutable ) import Darcs.Util.CommandLine ( parseCmd ) import Darcs.UI.External ( diffProgram , execPipeIgnoreError ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository ) import Darcs.UI.Completion ( knownFileArgs ) import Darcs.UI.Flags ( DarcsFlag, wantGuiPause, useCache, fixSubPaths ) import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Repository.Flags ( WantGuiPause (..), DiffAlgorithm(MyersDiff) ) import Darcs.Patch.PatchInfoAnd ( info, n2pia ) import Darcs.Util.Path ( toFilePath, SubPath, simpleSubPath, isSubPathOf, AbsolutePath ) import Darcs.Util.Global ( darcsdir ) import Darcs.Patch.Match ( firstMatch , secondMatch , matchFirstPatchset , matchSecondPatchset ) import Darcs.Repository ( withRepository, RepoJob(..), readRepo ) import Darcs.Repository.State ( readUnrecorded, restrictSubpaths , readRecorded, unrecordedChanges , UseIndex(..), ScanKnown(..), applyTreeFilter ) import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal ) import Darcs.Patch ( RepoPatch, IsRepoType, apply, listTouchedFiles, invert, fromPrims ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Patch.Named.Wrapped ( anonymous ) import Darcs.Patch.Set ( PatchSet(..), patchSet2RL ) import Darcs.Patch.Info ( PatchInfo, displayPatchInfo ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Util.Printer ( Doc, putDoc, vcat, empty, ($$) ) diffDescription :: String diffDescription = "Create a diff between two versions of the repository." diffHelp :: String diffHelp = "The `darcs diff` command compares two versions of the working tree of\n" ++ "the current repository. Without options, the pristine (recorded) and\n" ++ "unrecorded working trees are compared. This is lower-level than\n" ++ "the `darcs whatsnew` command, since it outputs a line-by-line diff,\n" ++ "and it is also slower. As with `darcs whatsnew`, if you specify\n" ++ "files or directories, changes to other files are not listed.\n" ++ "The command always uses an external diff utility.\n" ++ "\n" ++ "With the `--patch` option, the comparison will be made between working\n" ++ "trees with and without that patch. Patches *after* the selected patch\n" ++ "are not present in either of the compared working trees. The\n" ++ "`--from-patch` and `--to-patch` options allow the set of patches in the\n" ++ "`old' and `new' working trees to be specified separately.\n" ++ "\n" ++ "The associated tag and match options are also understood, e.g. `darcs\n" ++ "diff --from-tag 1.0 --to-tag 1.1`. All these options assume an\n" ++ "ordering of the patch set, so results may be affected by operations\n" ++ "such as `darcs optimize reorder`.\n" ++ "\n" ++ "diff(1) is called with the arguments `-rN`. The `--unified` option causes\n" ++ "`-u` to be passed to diff(1). An additional argument can be passed\n" ++ "using `--diff-opts`, such as `--diff-opts=-ud` or `--diff-opts=-wU9`.\n" ++ "\n" ++ "The `--diff-command` option can be used to specify an alternative\n" ++ "utility. Arguments may be included, separated by whitespace. The value\n" ++ "is not interpreted by a shell, so shell constructs cannot be used. The\n" ++ "arguments %1 and %2 MUST be included, these are substituted for the two\n" ++ "working trees being compared. For instance:\n" ++ "\n" ++ " darcs diff -p . --diff-command \"meld %1 %2\"\n" ++ "\n" ++ "If this option is used, `--diff-opts` is ignored.\n" diffCommand :: DarcsCommand [DarcsFlag] diffCommand = DarcsCommand { commandProgramName = "darcs" , commandName = "diff" , commandHelp = diffHelp , commandDescription = diffDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = diffCmd , commandPrereq = amInHashedRepository , commandCompleteArgs = knownFileArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc diffAdvancedOpts , commandBasicOptions = odesc diffBasicOpts , commandDefaults = defaultFlags diffOpts , commandCheckOptions = ocheck diffOpts , commandParseOptions = onormalise diffOpts } where diffBasicOpts = O.matchRange ^ O.extDiff ^ O.repoDir ^ O.storeInMemory diffAdvancedOpts = O.pauseForGui diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts getDiffOpts :: O.ExternalDiff -> [String] getDiffOpts O.ExternalDiff {O.diffOpts=os,O.diffUnified=u} = addUnified os where addUnified = if u then ("-u":) else id -- | Returns the command we should use for diff as a tuple (command, arguments). -- This will either be whatever the user specified via --diff-command or the -- default 'diffProgram'. Note that this potentially involves parsing the -- user's diff-command, hence the possibility for failure with an exception. getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String -> Either String (String, [String]) getDiffCmdAndArgs cmd opts f1 f2 = helper (O.extDiff ? opts) where helper extDiff = case O.diffCmd extDiff of Just c -> case parseCmd [ ('1', f1) , ('2', f2) ] c of Left err -> Left $ show err Right ([],_) -> bug "parseCmd should never return empty list" Right (h:t,_) -> Right (h,t) Nothing -> -- if no command specified, use 'diff' Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2]) diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () diffCmd fps opts args | not (null (O.matchLast ? opts)) && not (null (O.matchFrom ? opts)) = fail $ "using --patch and --last at the same time with the 'diff'" ++ " command doesn't make sense. Use --from-patch to create a diff" ++ " from this patch to the present, or use just '--patch' to view" ++ " this specific patch." | null args = doDiff opts Nothing | otherwise = doDiff opts . Just =<< fixSubPaths fps args doDiff :: [DarcsFlag] -> Maybe [SubPath] -> IO () doDiff opts msubpaths = getDiffDoc opts msubpaths >>= putDoc getDiffDoc :: [DarcsFlag] -> Maybe [SubPath] -> IO Doc getDiffDoc opts msubpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do formerdir <- getCurrentDirectory let thename = takeFileName formerdir patchset <- readRepo repository unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) O.NoLookForMoves O.NoLookForReplaces repository msubpaths unrecorded' <- n2pia `fmap` anonymous unrecorded let matchFlags = parseFlags O.matchRange opts Sealed all <- return $ case (secondMatch matchFlags, patchset) of (True, _) -> seal patchset (False, PatchSet tagged untagged) -> seal $ PatchSet tagged (untagged :<: unrecorded') Sealed ctx <- return $ if firstMatch matchFlags then matchFirstPatchset matchFlags patchset else seal patchset Sealed match <- return $ if secondMatch matchFlags then matchSecondPatchset matchFlags patchset else seal all (_ :> todiff) <- return $ findCommonWithThem match ctx (_ :> tounapply) <- return $ findCommonWithThem all match base <- if secondMatch matchFlags then readRecorded repository else readUnrecorded repository Nothing let touched = map (fromJust . simpleSubPath) $ listTouchedFiles todiff files = case msubpaths of Nothing -> touched Just subpaths -> concatMap (\s -> filter (isSubPathOf s) touched) subpaths relevant <- restrictSubpaths repository files let filt = applyTreeFilter relevant . snd ppath = darcsdir "pristine.hashed" oldtree <- filt `fmap` hashedTreeIO (apply . invert $ unsafeCoercePEnd todiff +>+ tounapply) base ppath newtree <- filt `fmap` hashedTreeIO (apply . invert $ tounapply) base ppath withTempDir ("old-"++thename) $ \odir -> withTempDir ("new-"++thename) $ \ndir -> withCurrentDirectory formerdir $ do writePlainTree oldtree (toFilePath odir) writePlainTree newtree (toFilePath ndir) thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $ rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir) morepatches <- readRepo repository return $ changelog (getDiffInfo opts morepatches) $$ thediff where rundiff :: String -> String -> IO Doc rundiff f1 f2 = do cmd <- diffProgram case getDiffCmdAndArgs cmd opts f1 f2 of Left err -> fail err Right (d_cmd, d_args) -> do if length (filter (==f1) d_args) /= 1 || length (filter (==f2) d_args) /= 1 then fail $ "Invalid argument (%1 or %2) in --diff-command" else return () cmdExists <- findExecutable d_cmd if isJust cmdExists then return () else fail $ d_cmd ++ " is not an executable in --diff-command" let pausingForGui = (wantGuiPause opts == YesWantGuiPause) in do when pausingForGui $ putStrLn $ "Running command '" ++ unwords (d_cmd:d_args) ++ "'" output <- execPipeIgnoreError d_cmd d_args empty when pausingForGui $ askEnter "Hit return to move on..." return output getDiffInfo :: (IsRepoType rt, RepoPatch p) => [DarcsFlag] -> PatchSet rt p wStart wX -> [PatchInfo] getDiffInfo opts ps = let matchFlags = parseFlags O.matchRange opts infos = mapRL info . patchSet2RL handle (match_cond, do_match) | match_cond matchFlags = unseal infos (do_match matchFlags ps) | otherwise = infos ps in handle (secondMatch, matchSecondPatchset) \\ handle (firstMatch, matchFirstPatchset) changelog :: [PatchInfo] -> Doc changelog pis = vcat $ map displayPatchInfo pis