% 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.
\darcsCommand{changes}
\begin{code}
module Darcs.Commands.Changes ( changes, log ) where
import Prelude hiding ( log )
import Data.List ( intersect, sort )
import Data.Maybe ( fromMaybe )
import Control.Monad ( when, unless )
import Darcs.Hopefully ( hopefullyM, info )
import Darcs.Patch.Depends ( slightly_optimize_patchset )
import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )
import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable,
Interactive, Count,
NumberPatches, XMLOutput, Summary,
Verbose, Debug),
fixSubPaths, changesFormat,
possiblyRemoteRepoDir, getRepourl,
workingRepoDir, onlyToFiles,
summary, changesReverse,
matchSeveralOrRange,
matchMaxcount, maxCount,
allInteractive, showFriendly,
networkOptions
)
import Darcs.Flags ( doReverse, showChangesOnlyToFiles )
import Darcs.RepoPath ( toFilePath, rootDirectory )
import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path )
import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd,
withRepositoryDirectory, ($-), findRepository,
read_repo, unrecordedChanges )
import Darcs.Patch.Info ( to_xml, showPatchInfo )
import Darcs.Patch.Depends ( get_common_and_uncommon )
import Darcs.Patch.TouchesFiles ( look_touch )
import Darcs.Patch ( RepoPatch, invert, xmlSummary, description, applyToFilepaths,
listTouchedFiles, effect, identity )
import Darcs.Witnesses.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,
EqCheck(..), filterFL )
import Darcs.Match ( firstMatch, secondMatch,
matchAPatchread, haveNonrangeMatch,
matchFirstPatchset, matchSecondPatchset,
)
import Darcs.Commands.Annotate ( createdAsXml )
import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),
renderString, prefix, text, vcat, vsep,
($$), empty, errorDoc, insert_before_lastline )
import Darcs.ColorPrinter ( fancyPrinters )
import Progress ( setProgressMode, debugMessage )
import Darcs.SelectChanges ( view_changes )
import Darcs.Witnesses.Sealed ( unsafeUnseal )
#include "impossible.h"
changesDescription :: String
changesDescription = "List patches in the repository."
changesHelp :: String
changesHelp =
"The `darcs changes' command lists the patches that constitute the\n" ++
"current repository or, with --repo, a remote repository. Without\n" ++
"options or arguments, ALL patches will be listed.\n" ++
"\n" ++ changesHelp' ++
"\n" ++ changesHelp''
changes :: DarcsCommand
changes = DarcsCommand {commandName = "changes",
commandHelp = changesHelp,
commandDescription = changesDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[FILE or DIRECTORY]..."],
commandGetArgPossibilities = return [],
commandCommand = changesCmd,
commandPrereq = findRepository,
commandArgdefaults = nodefaults,
commandAdvancedOptions = networkOptions,
commandBasicOptions = [matchSeveralOrRange,
matchMaxcount,
onlyToFiles,
changesFormat,
summary,
changesReverse,
possiblyRemoteRepoDir,
workingRepoDir,
allInteractive]}
changesCmd :: [DarcsFlag] -> [String] -> IO ()
changesCmd [Context _] [] = return ()
changesCmd opts args | Context rootDirectory `elem` opts =
let repodir = fromMaybe "." (getRepourl opts) in
withRepositoryDirectory opts repodir $- \repository -> do
when (args /= []) $ fail "changes --context cannot accept other arguments"
changesContext repository opts
changesCmd opts args =
let repodir = fromMaybe "." (getRepourl opts) in
withRepositoryDirectory opts repodir $- \repository -> do
unless (Debug `elem` opts) $ setProgressMode False
files <- sort `fmap` fixSubPaths opts args
unrec <- if null files then return identity
else unrecordedChanges opts repository files
`catch` \_ -> return identity
let filez = map (fn2fp . norm_path . fp2fn) $ applyToFilepaths (invert unrec) $ map toFilePath files
filtered_changes p = maybe_reverse $ getChangesInfo opts filez p
debugMessage "About to read the repository..."
patches <- read_repo repository
debugMessage "Done reading the repository."
if Interactive `elem` opts
then do let (fp_and_fs, _, _) = filtered_changes patches
fp = map fst fp_and_fs
view_changes opts (unsafeFL fp)
else do when (not (null files) && not (XMLOutput `elem` opts)) $
putStrLn $ "Changes to "++unwords filez++":\n"
debugMessage "About to print the changes..."
let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters
ps <- read_repo repository
putDocLnWith printers $ changelog opts ps $ filtered_changes patches
where maybe_reverse (xs,b,c) = if doReverse opts
then (reverse xs, b, c)
else (xs, b, c)
changesHelp' :: String
changesHelp' =
"When given one or more files or directories as arguments, only\n" ++
"patches which affect those files or directories are listed. This\n" ++
"includes changes that happened to files before they were moved or\n" ++
"renamed.\n" ++
"\n" ++
"When given a --from-tag, --from-patch or --from-match, only changes\n" ++
"since that tag or patch are listed. Similarly, the --to-tag,\n" ++
"--to-patch and --to-match options restrict the list to older patches.\n" ++
"\n" ++
"The --last and --max-count options both limit the number of patches\n" ++
"listed. The former applies BEFORE other filters, whereas the latter\n" ++
"applies AFTER other filters. For example `darcs changes foo.c\n" ++
"--max-count 3' will print the last three patches that affect foo.c,\n" ++
"whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++
"patches, print only those that affect foo.c.\n"
getChangesInfo :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p
-> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)
getChangesInfo opts plain_fs ps =
case get_common_and_uncommon (p2s,p1s) of
(_,us:\/:_) -> filterPatchesByNames (maxCount opts) fs $ filter pf $ unsafeUnRL us
where fs = map (\x -> "./" ++ x) $ plain_fs
p1s = if firstMatch opts then unsafeUnseal $ matchFirstPatchset opts ps
else NilRL:<:NilRL
p2s = if secondMatch opts then unsafeUnseal $ matchSecondPatchset opts ps
else ps
pf = if haveNonrangeMatch opts
then matchAPatchread opts
else \_ -> True
filterPatchesByNames :: RepoPatch p =>
Maybe Int
-> [FilePath]
-> [PatchInfoAnd p]
-> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc)
filterPatchesByNames (Just 0) _ _ = ([], [], empty)
filterPatchesByNames _ _ [] = ([], [], empty)
filterPatchesByNames maxcount [] (hp:ps) =
(hp, []) -:- filterPatchesByNames (subtract 1 `fmap` maxcount) [] ps
filterPatchesByNames maxcount fs (hp:ps)
| Just p <- hopefullyM hp =
case look_touch fs (invert p) of
(True, []) -> ([(hp, fs)], fs, empty)
(True, fs') -> (hp, fs) -:- filterPatchesByNames
(subtract 1 `fmap` maxcount) fs' ps
(False, fs') -> filterPatchesByNames maxcount fs' ps
filterPatchesByNames _ _ (hp:_) =
([], [], text "Can't find changes prior to:" $$ description hp)
(-:-) :: a -> ([a],b,c) -> ([a],b,c)
x -:- ~(xs,y,z) = (x:xs,y,z)
changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)
-> Doc
changelog opts patchset (pis_and_fs, orig_fs, errstring)
| Count `elem` opts = text $ show $ length pis_and_fs
| MachineReadable `elem` opts =
if renderString errstring == ""
then vsep $ map (showPatchInfo.info) pis
else errorDoc errstring
| XMLOutput `elem` opts =
text "<changelog>"
$$ vcat xml_file_names
$$ vcat actual_xml_changes
$$ text "</changelog>"
| Summary `elem` opts || Verbose `elem` opts =
vsep (map (number_patch change_with_summary) pis_and_fs)
$$ errstring
| otherwise = vsep (map (number_patch description') pis_and_fs)
$$ errstring
where change_with_summary (hp, fs)
| Just p <- hopefullyM hp = if showChangesOnlyToFiles opts
then description hp $$ text "" $$
indent (showFriendly opts (filterFL xx $ effect p))
else showFriendly opts p
| otherwise = description hp
$$ indent (text "[this patch is unavailable]")
where xx x = case listTouchedFiles x of
ys | null $ ys `intersect` fs -> IsEq
_ -> NotEq
xml_with_summary hp
| Just p <- hopefullyM hp = insert_before_lastline
(to_xml $ info hp) (indent $ xmlSummary p)
xml_with_summary hp = to_xml (info hp)
indent = prefix " "
actual_xml_changes = if Summary `elem` opts
then map xml_with_summary pis
else map (to_xml.info) pis
xml_file_names = map (createdAsXml first_change) orig_fs
first_change = if doReverse opts
then info $ head pis
else info $ last pis
number_patch f x = if NumberPatches `elem` opts
then case get_number (fst x) of
Just n -> text (show n++":") <+> f x
Nothing -> f x
else f x
get_number :: PatchInfoAnd p -> Maybe Int
get_number y = gn 1 (concatRL patchset)
where iy = info y
gn n (b:<:bs) | seq n (info b) == iy = Just n
| otherwise = gn (n+1) bs
gn _ NilRL = Nothing
pis = map fst pis_and_fs
description' = description . fst
changesHelp'' :: String
changesHelp'' =
"Three output formats exist. The default is --human-readable. You can\n" ++
"also select --context, which is the internal format (as seen in patch\n" ++
"bundles) that can be re-read by Darcs (e.g. `darcs get --context').\n" ++
"\n" ++
"Finally, there is --xml-output, which emits valid XML... unless a the\n" ++
"patch metadata (author, name or description) contains a non-ASCII\n" ++
"character and was recorded in a non-UTF8 locale.\n" ++
"\n" ++
"Note that while the --context flag may be used in conjunction with\n" ++
"--xml-output or --human-readable, in neither case will darcs get be\n" ++
"able to read the output. On the other hand, sufficient information\n" ++
"WILL be output for a knowledgeable human to recreate the current state\n" ++
"of the repository.\n"
changesContext :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()
changesContext repository opts = do
r <- read_repo repository
putStrLn "\nContext:\n"
when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $
putDocLnWith simplePrinters $ changelog opts' NilRL $
getChangesInfo opts' []
(headRL (slightly_optimize_patchset r) :<: NilRL)
where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts
then opts
else MachineReadable : opts
headRL (x:<:_) = x
headRL NilRL = impossible
log :: DarcsCommand
log = commandAlias "log" changes
\end{code}