--  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 Prelude ()
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 ( isSpace )
import Data.Maybe ( fromJust, isJust )
import Control.Exception ( catch, IOException )
import Control.Monad ( unless, filterM, void )
import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree
                      , makeBlobBS )
import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath )
import Darcs.UI.Flags
    ( DarcsFlag
    , verbosity, useCache, dryRun, umask, diffAlgorithm, fixSubPaths )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking(..) )
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
    , applyToWorking
    , readUnrecorded
    )
import Darcs.Patch.TokenReplace ( defaultToks )
import Darcs.Repository.Prefs ( FileType(TextFile) )
import Darcs.Util.Path ( floatSubPath )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )

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

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

replace :: DarcsCommand [DarcsFlag]
replace :: DarcsCommand [DarcsFlag]
replace = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "replace"
    , commandHelp :: String
commandHelp = String
replaceHelp
    , commandDescription :: String
commandDescription = String
replaceDescription
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [ "<OLD>"
                            , "<NEW>"
                            , "<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
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UseIndex -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UseIndex -> UMask -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
replaceAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Bool -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Bool -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Bool -> Maybe String -> a)
replaceBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
replaceOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
replaceOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
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 :: OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
replaceAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) UseIndex
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> 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 (UMask -> a)
PrimDarcsOption UMask
O.umask
    replaceOpts :: DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
replaceOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Bool -> Maybe String -> a)
replaceBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (UseIndex -> UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UseIndex
      -> UMask
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (UseIndex -> UMask -> UseCache -> HooksConfig -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (UseIndex -> UMask -> a)
replaceAdvancedOpts

replaceArgs  :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]
replaceArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
replaceArgs fps :: (AbsolutePath, AbsolutePath)
fps flags :: [DarcsFlag]
flags args :: [String]
args =
  if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2
    then [String] -> IO [String]
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 fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts (old :: String
old : new :: String
new : relfs :: [String]
relfs@(_ : _)) =
  DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock  (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$
    \repository :: Repository rt p wR wU wR
repository -> do
        [SubPath]
fs <- (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
relfs
        String
toks <- Maybe String -> String -> String -> IO String
chooseToks (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 tok :: 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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ "'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tok String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' 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 rt p wR wU wR -> Maybe [SubPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wR
repository Maybe [SubPath]
forall a. Maybe a
Nothing
        [SubPath]
files <- (SubPath -> IO Bool) -> [SubPath] -> IO [SubPath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Tree IO -> SubPath -> IO Bool
forall (m :: * -> *). Tree m -> SubPath -> IO Bool
exists Tree IO
working) [SubPath]
fs
        Sealed replacePs :: 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 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 (PrimOf p))] -> Sealed (FL (FL (PrimOf p)) wU)
forall (a :: * -> * -> *) wX. [FreeLeft a] -> Sealed (FL a wX)
toFL ([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
<$>
            (SubPath -> IO (FreeLeft (FL (PrimOf p))))
-> [SubPath] -> IO [FreeLeft (FL (PrimOf p))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Tree IO -> SubPath -> IO (FreeLeft (FL (PrimOf p)))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
String -> Tree IO -> SubPath -> IO (FreeLeft (FL prim))
doReplace String
toks Tree IO
working) [SubPath]
files
        -- Note: addToPending takes care of commuting the replace patch and
        -- everything it depends on past the diff between pending and working
        Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking FL (PrimOf p) wU wX
replacePs
        IO (Repository rt p wR wX wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository rt p wR wX wR) -> IO ())
-> IO (Repository rt p wR wX wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wX
-> IO (Repository rt p wR wX wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wR
repository (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 IO (Repository rt p wR wX wR)
-> (IOException -> IO (Repository rt p wR wX wR))
-> IO (Repository rt p wR wX wR)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
            String -> IO (Repository rt p wR wX wR)
forall a. String -> a
bug (String -> IO (Repository rt p wR wX wR))
-> String -> IO (Repository rt p wR wX wR)
forall a b. (a -> b) -> a -> b
$ "Can't do replace on working!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
  where
    exists :: Tree m -> SubPath -> IO Bool
exists tree :: Tree m
tree file :: SubPath
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 (SubPath -> AnchoredPath
floatSubPath SubPath
file)
                           then Bool -> IO Bool
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
$ SubPath -> String
forall a. FilePathLike a => a -> String
skipmsg SubPath
file
                                   Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

    doReplace :: forall prim . (PrimPatch prim,
              ApplyState prim ~ Tree) => String -> Tree IO
              -> SubPath -> IO (FreeLeft (FL prim))
    doReplace :: String -> Tree IO -> SubPath -> IO (FreeLeft (FL prim))
doReplace toks :: String
toks work :: Tree IO
work f :: SubPath
f = do
        Maybe (Tree IO)
workReplaced <- prim Any Any -> Tree IO -> IO (Maybe (Tree IO))
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree prim Any Any
forall wX wY. prim wX wY
replacePatch Tree IO
work
        case Maybe (Tree IO)
workReplaced of
          Just _ -> do
            FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
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 wZ. prim wX wY -> FL prim wY wZ -> FL prim wX wZ)
-> FreeLeft prim -> FreeLeft (FL prim) -> FreeLeft (FL prim)
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 forall wX wY wZ. prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
(:>:) ((forall wX wY. prim wX wY) -> FreeLeft prim
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap forall wX wY. prim wX wY
replacePatch) FreeLeft (FL prim)
forall (a :: * -> * -> *). FreeLeft (FL a)
gapNilFL
          Nothing
            | PrimDarcsOption Bool
O.forceReplace PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts -> SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
forall (prim :: * -> * -> *).
PrimPatch prim =>
SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
getForceReplace SubPath
f String
toks Tree IO
work
            | Bool
otherwise -> String -> IO ()
putStrLn String
existsMsg IO () -> IO (FreeLeft (FL prim)) -> IO (FreeLeft (FL prim))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
forall (m :: * -> *) a. Monad m => a -> m a
return FreeLeft (FL prim)
forall (a :: * -> * -> *). FreeLeft (FL a)
gapNilFL
      where
        existsMsg :: String
existsMsg = "Skipping file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'\nPerhaps the working"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ " version of this file already contains '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'?\nUse the --force option to override."
        gapNilFL :: FreeLeft (FL a)
gapNilFL = (forall wX. FL a wX wX) -> FreeLeft (FL a)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL a wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
        fp :: String
fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
f
        replacePatch :: prim wX wY
replacePatch = String -> String -> String -> String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> String -> String -> prim wX wY
tokreplace String
fp String
toks String
old String
new

    ftf :: p -> FileType
ftf _ = 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 => SubPath -> String -> Tree IO
                    -> IO (FreeLeft (FL prim))
    getForceReplace :: SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))
getForceReplace f :: SubPath
f toks :: String
toks tree :: Tree IO
tree = do
        let path :: AnchoredPath
path = SubPath -> AnchoredPath
floatSubPath SubPath
f
        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. HasCallStack => 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 (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 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
$ "Don't be surprised!\n"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "I've changed all instances of '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' to '"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' first\n"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "so that darcs replace can token-replace them"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ " back into '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' again."
        FreeLeft (FL prim) -> IO (FreeLeft (FL prim))
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 (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 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 (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
$
            String -> String -> String -> String -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> String -> String -> prim wX wY
tokreplace (SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath SubPath
f) 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 _ _ [_, _] = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "You need to supply a list of files to replace in!"
replaceCmd _ _ _ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Usage: darcs replace <OLD> <NEW> <FILE>..."

filenameToks :: String
filenameToks :: String
filenameToks = "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 _ "" = Bool
False
isTok toks :: String
toks s :: 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 t :: String
t) a :: String
a b :: String
b
    | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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
$ "It must contain more than 2 characters, because it"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ " should be enclosed in square brackets"
    | String -> Char
forall a. [a] -> a
head String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '[' Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
last String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ']' =
        String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
badTokenSpec "It should be enclosed in square brackets"
    | '^' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Char
forall a. [a] -> a
head String
tok Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
tok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 =
        String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
badTokenSpec "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 "Space is not allowed in the spec"
    | (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 (m :: * -> *) a. Monad m => a -> m a
return String
tok
  where
    tok :: String
tok = String -> String
forall a. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
t :: String
    badTokenSpec :: String -> m a
badTokenSpec msg :: String
msg = 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
$ "Bad token spec: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
    spaceyToken :: String -> String
spaceyToken x :: String
x = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " must not contain any space"
    notAToken :: String -> String
notAToken x :: String
x = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not a token, according to your spec"

chooseToks Nothing a :: String
a b :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
defaultToks
      else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
filenameToks