--  Copyright (C) 2002-2005 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.Replace
    ( replace
    , defaultToks
    ) where

import Darcs.Prelude

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
import Data.Char ( isAscii, isPrint, isSpace )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( fromJust, isJust )
import Safe ( headErr, tailErr )
import Control.Monad ( unless, filterM, void, when )
import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree
                      , makeBlobBS )
import Darcs.Util.Path( AbsolutePath )
import Darcs.UI.Flags
    ( DarcsFlag, diffingOpts
    , verbosity, useCache, umask, diffAlgorithm, pathsFromArgs )
import Darcs.UI.Options ( (^), (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.Repository.Diff( treeDiff )
import Darcs.Patch ( PrimPatch, tokreplace, forceTokReplace
                   , maybeApplyToTree )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.RegChars ( regChars )
import Darcs.Repository
    ( withRepoLock
    , RepoJob(..)
    , addToPending
    , finalizeRepositoryChanges
    , applyToWorking
    , readUnrecorded
    )
import Darcs.Patch.TokenReplace ( defaultToks )
import Darcs.Repository.Prefs ( FileType(TextFile) )
import Darcs.Util.Path ( AnchoredPath, displayPath )
import Darcs.Util.Printer ( Doc, formatWords, vsep )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , concatFL
    , consGapFL
    , joinGapsFL
    , nullFL
    , (+>+)
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )

replaceDescription :: String
replaceDescription :: String
replaceDescription = String
"Substitute one word for another."

replaceHelp :: Doc
replaceHelp :: Doc
replaceHelp = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"In addition to line-based patches, Darcs supports a limited form of"
    , String
"lexical substitution.  Files are treated as sequences of words, and"
    , String
"each occurrence of the old word is replaced by the new word."
    , String
"This is intended to provide a clean way to rename a function or"
    , String
"variable.  Such renamings typically affect lines all through the"
    , String
"source code, so a traditional line-based patch would be very likely to"
    , String
"conflict with other branches, requiring manual merging."
    ]
  , [ String
"Files are tokenized according to one simple rule: words are strings of"
    , String
"valid token characters, and everything between them (punctuation and"
      -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?
    , String
"whitespace) is discarded.  By default, valid token characters are"
    , String
"letters, numbers and the underscore (i.e. `[A-Za-z0-9_]`).  However if"
    , String
"the old and/or new token contains either a hyphen or period, BOTH"
    , String
"hyphen and period are treated as valid (i.e. `[A-Za-z0-9_.-]`)."
    ]
  , [ String
"The set of valid characters can be customized using the `--token-chars`"
    , String
"option.  The argument must be surrounded by square brackets.  If a"
    , String
"hyphen occurs between two characters in the set, it is treated as a"
    , String
"set range.  For example, in most locales `[A-Z]` denotes all uppercase"
    , String
"letters.  If the first character is a caret, valid tokens are taken to"
    , String
"be the complement of the remaining characters.  For example, `[^:\\n]`"
    , String
"could be used to match fields in the passwd(5), where records and"
    , String
"fields are separated by newlines and colons respectively."
    ]
  , [ String
"If you choose to use `--token-chars`, you are STRONGLY encouraged to do"
    , String
"so consistently.  The consequences of using multiple replace patches"
    , String
"with different `--token-chars` arguments on the same file are not well"
    , String
"tested nor well understood."
    ]
  , [ String
"By default Darcs will refuse to perform a replacement if the new token"
    , String
"is already in use, because the replacements would be not be"
    , String
"distinguishable from the existing tokens.  This behaviour can be"
    , String
"overridden by supplying the `--force` option, but an attempt to `darcs"
    , String
"rollback` the resulting patch will affect these existing tokens."
    ]
  , [ String
"Limitations:"
    ]
  , [ String
"The tokenizer treats files as byte strings, so it is not possible for"
    , String
"`--token-chars` to include multi-byte characters, such as the non-ASCII"
    , String
"parts of UTF-8.  Similarly, trying to replace a \"high-bit\" character"
    , String
"from a unibyte encoding will also result in replacement of the same"
    , String
"byte in files with different encodings.  For example, an acute a from"
    , String
"ISO 8859-1 will also match an alpha from ISO 8859-7."
    ]
  , [ String
"Due to limitations in the patch file format, `--token-chars` arguments"
    , String
"cannot contain literal whitespace.  For example, `[^ \\n\\t]` cannot be"
    , String
"used to declare all characters except the space, tab and newline as"
    , String
"valid within a word, because it contains a literal space."
    ]
  , [ String
"Unlike POSIX regex(7) bracket expressions, character classes (such as"
    , String
"`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently"
    , String
"treated as a simple set of characters."
    ]
  ]

replace :: DarcsCommand
replace :: DarcsCommand
replace = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"replace"
    , commandHelp :: Doc
commandHelp = Doc
replaceHelp
    , commandDescription :: String
commandDescription = String
replaceDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [ String
"<OLD>"
                            , String
"<NEW>"
                            , String
"<FILE> ..."
                            ]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
replaceCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
replaceArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
replaceOpts
    }
  where
    replaceBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Bool -> Maybe String -> a)
replaceBasicOpts = PrimOptSpec
  DarcsOptDescr DarcsFlag (Bool -> Maybe String -> a) (Maybe String)
PrimDarcsOption (Maybe String)
O.tokens PrimOptSpec
  DarcsOptDescr DarcsFlag (Bool -> Maybe String -> a) (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Maybe String -> Bool -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Bool -> Maybe String -> a)
PrimDarcsOption Bool
O.forceReplace OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Maybe String -> Bool -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> Bool -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    replaceAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
replaceAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    replaceOpts :: CommandOptions
replaceOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Bool -> Maybe String -> a)
replaceBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
replaceAdvancedOpts

replaceArgs  :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]
replaceArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
replaceArgs (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [String]
args =
  if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
    then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
knownFileArgs (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [String]
args

replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
replaceCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts (String
old : String
new : args :: [String]
args@(String
_ : [String]
_)) =
  UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$
    \Repository 'RW p wU wR
_repository -> do
        [AnchoredPath]
paths <- [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort ([AnchoredPath] -> [AnchoredPath])
-> IO [AnchoredPath] -> IO [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No valid repository paths were given."
        String
toks <- Maybe String -> String -> String -> IO String
chooseToks (PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.tokens PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
old String
new
        let checkToken :: String -> f ()
checkToken String
tok = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> String -> Bool
isTok String
toks String
tok) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
                                 String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tok String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a valid token!"
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
forall {f :: * -> *}. MonadFail f => String -> f ()
checkToken [ String
old, String
new ]
        Tree IO
working <- Repository 'RW p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Maybe [AnchoredPath]
forall a. Maybe a
Nothing
        [AnchoredPath]
files <- (AnchoredPath -> IO Bool) -> [AnchoredPath] -> IO [AnchoredPath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Tree IO -> AnchoredPath -> IO Bool
forall {m :: * -> *}. Tree m -> AnchoredPath -> IO Bool
exists Tree IO
working) [AnchoredPath]
paths
        Sealed FL (PrimOf p) wU wX
replacePs <- (forall wX. FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX)
-> Sealed (FL (FL (PrimOf p)) wU) -> Sealed (FL (PrimOf p) wU)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX
forall wX. FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (Sealed (FL (FL (PrimOf p)) wU) -> Sealed (FL (PrimOf p) wU))
-> ([FreeLeft (FL (PrimOf p))] -> Sealed (FL (FL (PrimOf p)) wU))
-> [FreeLeft (FL (PrimOf p))]
-> Sealed (FL (PrimOf p) wU)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeLeft (FL (FL (PrimOf p))) -> Sealed (FL (FL (PrimOf p)) wU)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (FL (PrimOf p))) -> Sealed (FL (FL (PrimOf p)) wU))
-> ([FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (FL (PrimOf p))))
-> [FreeLeft (FL (PrimOf p))]
-> Sealed (FL (FL (PrimOf p)) wU)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (FL (PrimOf p)))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
[w p] -> w (FL p)
joinGapsFL ([FreeLeft (FL (PrimOf p))] -> Sealed (FL (PrimOf p) wU))
-> IO [FreeLeft (FL (PrimOf p))] -> IO (Sealed (FL (PrimOf p) wU))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (AnchoredPath -> IO (FreeLeft (FL (PrimOf p))))
-> [AnchoredPath] -> IO [FreeLeft (FL (PrimOf p))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Tree IO -> AnchoredPath -> IO (FreeLeft (FL (PrimOf p)))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
String -> Tree IO -> AnchoredPath -> IO (FreeLeft (FL prim))
doReplace String
toks Tree IO
working) [AnchoredPath]
files
        IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- Note: addToPending takes care of commuting the replace patch and
          -- everything it depends on past the diff between pending and working
          Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository 'RW p wU wR
_repository ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts) FL (PrimOf p) wU wX
replacePs
          Repository 'RO p wU wR
_repository <- Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IO (Repository 'RO p wX wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wX wR) -> IO ())
-> IO (Repository 'RO p wX wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR
-> Verbosity -> FL (PrimOf p) wU wX -> IO (Repository 'RO p wX wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository 'RO p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
replacePs
  where
    exists :: Tree m -> AnchoredPath -> IO Bool
exists Tree m
tree AnchoredPath
file = if Maybe (Blob m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Blob m) -> Bool) -> Maybe (Blob m) -> Bool
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
tree AnchoredPath
file
                           then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           else do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
skipmsg AnchoredPath
file
                                   Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    skipmsg :: AnchoredPath -> String
skipmsg AnchoredPath
f = String
"Skipping file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' which isn't in the repository."

    doReplace :: forall prim . (PrimPatch prim,
              ApplyState prim ~ Tree) => String -> Tree IO
              -> AnchoredPath -> IO (FreeLeft (FL prim))
    doReplace :: forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
String -> Tree IO -> AnchoredPath -> IO (FreeLeft (FL prim))
doReplace String
toks Tree IO
work AnchoredPath
f = do
        Maybe (Tree IO)
workReplaced <- prim Any Any -> Tree IO -> IO (Maybe (Tree IO))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, MonadCatch m) =>
p wX wY -> Tree m -> m (Maybe (Tree m))
maybeApplyToTree prim Any Any
forall {wX} {wY}. prim wX wY
replacePatch Tree IO
work
        case Maybe (Tree IO)
workReplaced of
          Just Tree IO
_ -> do
            FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall {wX} {wY}. prim wX wY)
-> FreeLeft (FL prim) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w (FL p) -> w (FL p)
consGapFL prim wX wY
forall {wX} {wY}. prim wX wY
replacePatch FreeLeft (FL prim)
forall {a :: * -> * -> *}. FreeLeft (FL a)
gapNilFL
          Maybe (Tree IO)
Nothing
            | PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.forceReplace PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts -> AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
forall (prim :: * -> * -> *).
PrimPatch prim =>
AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
getForceReplace AnchoredPath
f String
toks Tree IO
work
            | Bool
otherwise -> String -> IO ()
putStrLn String
existsMsg IO () -> IO (FreeLeft (FL prim)) -> IO (FreeLeft (FL prim))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FreeLeft (FL prim)
forall {a :: * -> * -> *}. FreeLeft (FL a)
gapNilFL
      where
        -- FIXME Why do we say "perhaps"? Aren't we sure? Are there other
        -- reasons maybeApplyToTree can fail and what to do about them?
        existsMsg :: String
existsMsg = String
"Skipping file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\nPerhaps the working"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" version of this file already contains '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'?\nUse the --force option to override."
        gapNilFL :: FreeLeft (FL a)
gapNilFL = (forall wX. FL a wX wX) -> FreeLeft (FL a)
forall (p :: * -> * -> *). (forall wX. p wX wX) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap FL a wX wX
forall wX. FL a wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
        replacePatch :: prim wX wY
replacePatch = AnchoredPath -> String -> String -> String -> prim wX wY
forall wX wY.
AnchoredPath -> String -> String -> String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> String -> String -> String -> prim wX wY
tokreplace AnchoredPath
f String
toks String
old String
new

    ftf :: p -> FileType
ftf p
_ = FileType
TextFile

    -- | getForceReplace returns the list of patches that consists first of
    -- hunk patches to normalise all occurences of the target token (changing
    -- them back to the source token) and then the replace patches from
    -- oldToken -> newToken.
    getForceReplace :: PrimPatch prim
                    => AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
    getForceReplace :: forall (prim :: * -> * -> *).
PrimPatch prim =>
AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
getForceReplace AnchoredPath
path String
toks Tree IO
tree = do
        ByteString
content <- Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob (Blob IO -> IO ByteString) -> Blob IO -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Maybe (Blob IO) -> Blob IO
forall a. Partial => Maybe a -> a
fromJust (Maybe (Blob IO) -> Blob IO) -> Maybe (Blob IO) -> Blob IO
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> Maybe (Blob IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree IO
tree AnchoredPath
path
        let newcontent :: ByteString
newcontent = String -> ByteString -> ByteString -> ByteString -> ByteString
forceTokReplace String
toks (String -> ByteString
BC.pack String
new) (String -> ByteString
BC.pack String
old)
                            ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
content)
            tree' :: Tree IO
tree' = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
tree AnchoredPath
path (Maybe (TreeItem IO) -> Tree IO)
-> (Blob IO -> Maybe (TreeItem IO)) -> Blob IO -> Tree IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeItem IO -> Maybe (TreeItem IO)
forall a. a -> Maybe a
Just (TreeItem IO -> Maybe (TreeItem IO))
-> (Blob IO -> TreeItem IO) -> Blob IO -> Maybe (TreeItem IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> Tree IO) -> Blob IO -> Tree IO
forall a b. (a -> b) -> a -> b
$ ByteString -> Blob IO
forall (m :: * -> *). Monad m => ByteString -> Blob m
makeBlobBS ByteString
newcontent
        FreeLeft (FL prim)
normaliseNewTokPatch <- DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL prim))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff (PrimOptSpec DarcsOptDescr DarcsFlag a DiffAlgorithm
PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [DarcsFlag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String -> FileType
forall {p}. p -> FileType
ftf Tree IO
tree Tree IO
tree'
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((forall wX. FL prim Any wX -> Bool) -> Sealed (FL prim Any) -> Bool
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal FL prim Any wX -> Bool
forall wX. FL prim Any wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL (FreeLeft (FL prim) -> Sealed (FL prim Any)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL prim)
normaliseNewTokPatch)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Don't be surprised!\n"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I've changed all instances of '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' to '"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' first\n"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"so that darcs replace can token-replace them"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" back into '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' again."
        FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> IO (FreeLeft (FL prim)))
-> (FreeLeft (FL prim) -> FreeLeft (FL prim))
-> FreeLeft (FL prim)
-> IO (FreeLeft (FL prim))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wX wY wZ. FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ)
-> FreeLeft (FL prim) -> FreeLeft (FL prim) -> FreeLeft (FL prim)
forall (p :: * -> * -> *) (q :: * -> * -> *) (r :: * -> * -> *).
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> FreeLeft p -> FreeLeft q -> FreeLeft r
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *)
       (q :: * -> * -> *) (r :: * -> * -> *).
Gap w =>
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> w p -> w q -> w r
joinGap FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall wX wY wZ. FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+) FreeLeft (FL prim)
normaliseNewTokPatch (FreeLeft (FL prim) -> IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap ((forall wX wY. FL prim wX wY) -> FreeLeft (FL prim))
-> (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall a b. (a -> b) -> a -> b
$
            AnchoredPath -> String -> String -> String -> prim wX wY
forall wX wY.
AnchoredPath -> String -> String -> String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> String -> String -> String -> prim wX wY
tokreplace AnchoredPath
path String
toks String
old String
new prim wX wY -> FL prim wY wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
replaceCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String
_, String
_] = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You need to supply a list of files to replace in!"
replaceCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Usage: darcs replace <OLD> <NEW> <FILE>..."

filenameToks :: String
filenameToks :: String
filenameToks = String
"A-Za-z_0-9\\-\\."

-- | Given a set of characters and a string, returns true iff the string
-- contains only characters from the set. A set beginning with a caret (@^@) is
-- treated as a complementary set.
isTok :: String -> String -> Bool
isTok :: String -> String -> Bool
isTok String
_ String
"" = Bool
False
isTok String
toks String
s = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> Char -> Bool
regChars String
toks) String
s

-- | This function checks for @--token-chars@ on the command-line. If found,
-- it validates the argument and returns it, without the surrounding square
-- brackets. Otherwise, it returns either 'defaultToks' or 'filenameToks' as
-- explained in 'replaceHelp'.
--
-- Note: Limitations in the current replace patch file format prevents tokens
-- and token-char specifiers from containing any whitespace.
chooseToks :: Maybe String -> String -> String -> IO String
chooseToks :: Maybe String -> String -> String -> IO String
chooseToks (Just String
t) String
a String
b
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"It must contain more than 2 characters, because it"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should be enclosed in square brackets"
    | String -> Char
forall a. Partial => [a] -> a
headErr String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
|| String -> Char
forall a. Partial => [a] -> a
last String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']' =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec String
"It should be enclosed in square brackets"
    | Char
'^' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Char
forall a. Partial => [a] -> a
headErr String
tok Bool -> Bool -> Bool
&& String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
tok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec String
"Must be at least one character in the complementary set"
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
t =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec String
"Space is not allowed"
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAscii) String
t =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec String
"Only ASCII characters are allowed"
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPrint) String
t =
        String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec String
"Only printable characters are allowed"
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
a = String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
spaceyToken String
a
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
b = String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
spaceyToken String
b
    | Bool -> Bool
not (String -> String -> Bool
isTok String
tok String
a) = String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
notAToken String
a
    | Bool -> Bool
not (String -> String -> Bool
isTok String
tok String
b) = String -> IO String
forall {m :: * -> *} {a}. MonadFail m => String -> m a
badTokenSpec (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
notAToken String
b
    | Bool
otherwise = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tok
  where
    tok :: String
tok = String -> String
forall a. Partial => [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Partial => [a] -> [a]
tailErr String
t :: String
    badTokenSpec :: String -> m a
badTokenSpec String
msg = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Bad token spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    spaceyToken :: String -> String
spaceyToken String
x = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must not contain any space"
    notAToken :: String -> String
notAToken String
x = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a token, according to your spec"

chooseToks Maybe String
Nothing String
a String
b =
    if String -> String -> Bool
isTok String
defaultToks String
a Bool -> Bool -> Bool
&& String -> String -> Bool
isTok String
defaultToks String
b
      then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
defaultToks
      else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
filenameToks