module Darcs.Commands.Replace ( replace, defaultToks ) where
import Data.Maybe ( isJust )
import Control.Monad ( unless, filterM )
import Control.Applicative( (<$>) )
import Darcs.Commands ( DarcsCommand(..),
nodefaults )
import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles,
ignoretimes, umaskOption, tokens, forceReplace,
workingRepoDir, fixSubPaths )
import Darcs.Repository ( withRepoLock, RepoJob(..),
addToPending,
amInHashedRepository,
applyToWorking,
readUnrecorded, readRecordedAndPending
)
import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace, applyToTree, fromPrim )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.FileName( fn2fp )
import Darcs.Patch.Patchy ( Apply )
import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, mapFL_FL )
import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..) )
import Darcs.Patch.RegChars ( regChars )
import Data.Char ( isSpace )
import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )
import Darcs.Repository.Prefs ( FileType(TextFile) )
import Darcs.Diff( treeDiff )
import Storage.Hashed.Tree( readBlob, modifyTree , findFile, TreeItem(..), Tree, makeBlobBS )
import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath )
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
#include "impossible.h"
#include "gadts.h"
replaceDescription :: String
replaceDescription = "Substitute one word for another."
replaceHelp :: String
replaceHelp =
"In addition to line-based patches, Darcs supports a limited form of\n" ++
"lexical substitution. Files are treated as sequences of words, and\n" ++
"each occurrence of the old word is replaced by the new word.\n" ++
"This is intended to provide a clean way to rename a function or\n" ++
"variable. Such renamings typically affect lines all through the\n" ++
"source code, so a traditional line-based patch would be very likely to\n" ++
"conflict with other branches, requiring manual merging.\n" ++
"\n" ++
"Files are tokenized according to one simple rule: words are strings of\n" ++
"valid token characters, and everything between them (punctuation and\n" ++
"whitespace) is discarded. By default, valid token characters are\n" ++
"letters, numbers and the underscore (i.e. [A-Za-z0-9_]). However if\n" ++
"the old and/or new token contains either a hyphen or period, BOTH\n" ++
"hyphen and period are treated as valid (i.e. [A-Za-z0-9_.-]).\n" ++
"\n" ++
"The set of valid characters can be customized using the --token-chars\n" ++
"option. The argument must be surrounded by square brackets. If a\n" ++
"hyphen occurs between two characters in the set, it is treated as a\n" ++
"set range. For example, in most locales [A-Z] denotes all uppercase\n" ++
"letters. If the first character is a caret, valid tokens are taken to\n" ++
"be the complement of the remaining characters. For example, [^:\\n]\n" ++
"could be used to match fields in the passwd(5), where records and\n" ++
"fields are separated by newlines and colons respectively.\n" ++
"\n" ++
"If you choose to use --token-chars, you are STRONGLY encouraged to do\n" ++
"so consistently. The consequences of using multiple replace patches\n" ++
"with different --token-chars arguments on the same file are not well\n" ++
"tested nor well understood.\n" ++
"\n" ++
"By default Darcs will refuse to perform a replacement if the new token\n" ++
"is already in use, because the replacements would be not be\n" ++
"distinguishable from the existing tokens. This behaviour can be\n" ++
"overridden by supplying the --force option, but an attempt to `darcs\n" ++
"rollback' the resulting patch will affect these existing tokens.\n" ++
"\n" ++
"Limitations:\n" ++
"\n" ++
"The tokenizer treats files as byte strings, so it is not possible for\n" ++
"--token-chars to include multi-byte characters, such as the non-ASCII\n" ++
"parts of UTF-8. Similarly, trying to replace a `high-bit' character\n" ++
"from a unibyte encoding will also result in replacement of the same\n" ++
"byte in files with different encodings. For example, an acute a from\n" ++
"ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++
"\n" ++
"Due to limitations in the patch file format, --token-chars arguments\n" ++
"cannot contain literal whitespace. For example, [^ \\n\\t] cannot be\n" ++
"used to declare all characters except the space, tab and newline as\n" ++
"valid within a word, because it contains a literal space.\n" ++
"\n" ++
"Unlike POSIX regex(7) bracket expressions, character classes (such as\n" ++
"[[:alnum:]]) are NOT supported by --token-chars, and will be silently\n" ++
"treated as a simple set of characters.\n"
replace :: DarcsCommand
replace = DarcsCommand {commandProgramName = "darcs",
commandName = "replace",
commandHelp = replaceHelp,
commandDescription = replaceDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["<OLD>","<NEW>",
"<FILE> ..."],
commandCommand = replaceCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = listRegisteredFiles,
commandArgdefaults = nodefaults,
commandAdvancedOptions = [ignoretimes, umaskOption],
commandBasicOptions =
[tokens, forceReplace, workingRepoDir]}
replaceCmd :: [DarcsFlag] -> [String] -> IO ()
replaceCmd opts (old:new:relfs) = withRepoLock opts $ RepoJob $ \repository -> do
fs <- fixSubPaths opts relfs
toks <- chooseToks opts old new
let checkToken tok =
unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!"
checkToken old
checkToken new
work <- readUnrecorded repository Nothing
cur <- readRecordedAndPending repository
files <- filterM (exists work) fs
Sealed pswork <- mapSeal concatFL . toFL <$> mapM (repl toks cur work) files
addToPending repository pswork
_ <- applyToWorking repository opts pswork `catch` \e ->
fail $ "Can't do replace on working!\n"
++ "Perhaps one of the files already contains '"++ new++"'?\n"
++ show e
return ()
where ftf _ = TextFile
skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository."
exists tree file = if isJust $ findFile tree (floatSubPath file)
then return True
else do putStrLn $ skipmsg file
return False
repl :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)
=> String -> Tree IO -> Tree IO -> SubPath -> IO (FreeLeft (FL prim))
repl toks cur work f =
do work_replaced <- maybeApplyToTree replace_patch work
cur_replaced <- maybeApplyToTree replace_patch cur
if ForceReplace `elem` opts || isJust work_replaced || isJust cur_replaced
then get_force_replace f toks work
else do putStrLn $ "Skipping file '"++f_fp++"'"
putStrLn $ "Perhaps the recorded version of this " ++
"file already contains '" ++new++"'?"
putStrLn $ "Use the --force option to override."
return (emptyGap NilFL)
where f_fp = toFilePath f
replace_patch :: prim C(x y)
replace_patch = tokreplace f_fp toks old new
get_force_replace :: PrimPatch prim => SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
get_force_replace f toks tree = do
let path = floatSubPath f
content <- readBlob $ fromJust $ findFile tree path
let newcontent = forceTokReplace toks new old (BS.concat $ BL.toChunks content)
tree' = modifyTree tree path (File . makeBlobBS <$> newcontent)
case newcontent of
Nothing -> bug "weird forcing bug in replace."
Just _ -> do pfix <- treeDiff ftf tree tree'
putStrLn $ "Don't be surprised!"
putStrLn $ "I've changed all instances of '" ++ new ++ "' to '" ++ old ++ "' first"
putStrLn $ "so that darcs replace can token-replace them back into '" ++ new ++ "' again."
return $ joinGap (+>+) pfix (freeGap (tokreplace f_fp toks old new :>: NilFL))
where f_fp = toFilePath f
replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]"
floatSubPath :: SubPath -> AnchoredPath
floatSubPath = floatPath . fn2fp . sp2fn
maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p C(x y) -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree)
(\_ -> return Nothing)
defaultToks :: String
defaultToks = "A-Za-z_0-9"
filenameToks :: String
filenameToks = "A-Za-z_0-9\\-\\."
isTok :: String -> String -> Bool
isTok _ "" = False
isTok toks s = and $ map (regChars toks) s
chooseToks :: [DarcsFlag] -> String -> String -> IO String
chooseToks (Toks t:_) a b
| length t <= 2 =
bad_token_spec $ "It must contain more than 2 characters, because " ++
"it should be enclosed in square brackets"
| head t /= '[' || last t /= ']' =
bad_token_spec "It should be enclosed in square brackets"
| '^' == head tok && length tok == 1 =
bad_token_spec "Must be at least one character in the complementary set"
| any isSpace t =
bad_token_spec "Space is not allowed in the spec"
| any isSpace a = bad_token_spec $ spacey_token a
| any isSpace b = bad_token_spec $ spacey_token b
| not (isTok tok a) = bad_token_spec $ not_a_token a
| not (isTok tok b) = bad_token_spec $ not_a_token b
| otherwise = return tok
where tok = init $ tail t :: String
bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")"
spacey_token x = x ++ " must not contain any space"
not_a_token x = x ++ " is not a token, according to your spec"
chooseToks (_:fs) a b = chooseToks fs a b
chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b
then return defaultToks
else return filenameToks