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