--  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 ( isSpace )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( fromJust, isJust )
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
    , verbosity, useCache, dryRun, umask, diffAlgorithm, pathsFromArgs )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdatePending(..) )
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 ( AnchoredPath, displayPath )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
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 = String
"Substitute one word for another."

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

replace :: DarcsCommand
replace :: DarcsCommand
replace = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
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
    , 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
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
replaceOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
replaceOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Bool -> Maybe String -> a)
replaceBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseIndex
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseIndex
      -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseIndex
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseIndex
   -> UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> 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 (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
flags [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
< Int
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 (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts (String
old : String
new : args :: [String]
args@(String
_ : [String]
_)) =
  DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 rt p wR 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
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 (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 (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 rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wR
repository (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 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
<$>
            (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)
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 rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository (PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
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) -> 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
  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 (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 (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 :: 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 :: * -> * -> *) 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 Tree IO
_ -> 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
          Maybe (Tree IO)
Nothing
            | 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 (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
        -- 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 (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
        replacePatch :: prim wX wY
replacePatch = 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 :: 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. 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
$ 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 (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
$
            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 (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 (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 (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. [a] -> a
head String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
|| String -> Char
forall a. [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. [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
== 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 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 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
$ String
"Bad token spec: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 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 (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