% Copyright (C) 2004-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. \begin{code}

    {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
    {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}

    #include "gadts.h"

    module Darcs.Match ( matchFirstPatchset, matchSecondPatchset,
                   matchPatch,
                   matchAPatch, matchAPatchread,
                   getFirstMatch, getNonrangeMatch,
                   getPartialFirstMatch, getPartialSecondMatch,
                   getPartialNonrangeMatch,
                   firstMatch, secondMatch, haveNonrangeMatch,
                   havePatchsetMatch, getOnePatchset,
                   checkMatchSyntax, applyInvToMatcher, nonrangeMatcher,
                   InclusiveOrExclusive(..), matchExists
                 ) where

    import Text.Regex ( mkRegex, matchRegex )
    import Control.Monad ( when, unless )
    import Data.Maybe ( isJust )

    import Darcs.Hopefully ( PatchInfoAnd, info, piap,
                             conscientiously, hopefully )
    import Darcs.Patch.Info ( just_name )
    import Darcs.Patch ( RepoPatch, Patch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )
    import Darcs.Repository ( Repository, PatchSet, SealedPatchSet, read_repo,
                        slurp_recorded, createPristineDirectoryTree )
    import Darcs.Repository.ApplyPatches ( apply_patches )
    import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag )
    import Darcs.Witnesses.Ordered ( RL(..), concatRL, consRLSealed )

    import ByteStringUtils ( mmapFilePS )
    import qualified Data.ByteString as B (ByteString)

    import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,
                                   AfterPatch, UpToPatch, LastN, PatchIndexRange,
                                   OneTag, AfterTag, UpToTag,
                                   OnePattern, SeveralPattern,
                                   AfterPattern, UpToPattern ), willStoreInMemory )
    import Darcs.Patch.Bundle ( scan_context )
    import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch )
    import Darcs.Patch.MatchData ( PatchMatch )
    import Printer ( text, ($$) )

    import Darcs.RepoPath ( toFilePath )
    import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )
    import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy )
    import Darcs.Patch.FileName ( FileName, superName, norm_path, (///) )
    import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..),
                          seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )
    #include "impossible.h"

\end{code} \paragraph{Selecting patches}\label{selecting} Many commands operate on a patch or patches that have already been recorded. There are a number of options that specify which patches are selected for these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants on these, which for \verb!--patch! are \verb!--patches!, \verb!--from-patch!, and \verb!--to-patch!. The \verb!--patch! and \verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular expressions and match them against tag and patch names. \verb!--match!, described below, allows more powerful patterns. The plural forms of these options select all matching patches. The singular forms select the last matching patch. The range (from and to) forms select patches after or up to (both inclusive) the last matching patch. These options use the current order of patches in the repository. darcs may reorder patches, so this is not necessarily the order of creation or the order in which patches were applied. However, as long as you are just recording patches in your own repository, they will remain in order. % NOTE --no-deps is implemented in SelectChanges.lhs, but documented here % for concistency. When a patch or a group of patches is selected, all patches they depend on get silently selected too. For example: \verb!darcs pull --patches bugfix! means ``pull all the patches with `bugfix' in their name, along with any patches they require.'' If you really only want patches with `bugfix' in their name, you should use the \verb!--no-deps! option, which makes darcs exclude any matched patches from the selection which have dependencies that are themselves not explicitly matched by the selection. For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that depend on the selected patches are silently included, or if \verb!--no-deps! is used selected patches with dependencies on not selected patches are excluded from the selection. \begin{code}

    data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq

    -- | @haveNonrangeMatch flags@ tells whether there is a flag in
    -- @flags@ which corresponds to a match that is "non-range". Thus,
    -- @--match@, @--patch@ and @--index@ make @haveNonrangeMatch@
    -- true, but not @--from-patch@ or @--to-patch@.
    haveNonrangeMatch :: [DarcsFlag] -> Bool
    haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher Patch))

    -- | @havePatchsetMatch flags@ tells whether there is a "patchset
    -- match" in the flag list. A patchset match is @--match@ or
    -- @--patch@, or @--context@, but not @--from-patch@ nor (!)
    -- @--index@.
    -- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?
    havePatchsetMatch :: [DarcsFlag] -> Bool
    havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher Patch)) || hasC fs
        where hasC [] = False
              hasC (Context _:_) = True
              hasC (_:xs) = hasC xs

    getNonrangeMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()
    getNonrangeMatch r fs = withRecordedMatchSmart fs r (getNonrangeMatchS fs)

    getPartialNonrangeMatch :: RepoPatch p => Repository p C(r u t)
                               -> [DarcsFlag] -> [FileName] -> IO ()
    getPartialNonrangeMatch r fs files =
        withRecordedMatchOnlySomeSmart fs r files (getNonrangeMatchS fs)

    getNonrangeMatchS :: (MatchMonad m p, RepoPatch p) =>
                            [DarcsFlag] -> PatchSet p C(x) -> m ()
    getNonrangeMatchS fs repo =
        case nonrangeMatcher fs of
            Just m -> if nonrangeMatcherIsTag fs
                            then getTagS m repo
                            else getMatcherS Exclusive m repo
            Nothing -> fail "Pattern not specified in getNonrangeMatch."

    -- | @firstMatch fs@ tells whether @fs@ implies a "first match", that
    -- is if we match against patches from a point in the past on, rather
    -- than against all patches since the creation of the repository.
    firstMatch :: [DarcsFlag] -> Bool
    firstMatch fs = isJust (hasLastn fs)
                     || isJust (firstMatcher fs::Maybe (Matcher Patch))
                     || isJust (hasIndexRange fs)

    getFirstMatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()
    getFirstMatch r fs = withRecordedMatchSmart fs r (getFirstMatchS fs)

    getPartialFirstMatch :: RepoPatch p => Repository p C(r u t)
                            -> [DarcsFlag] -> [FileName] -> IO ()
    getPartialFirstMatch r fs files =
        withRecordedMatchOnlySomeSmart fs r files (getFirstMatchS fs)

    getFirstMatchS :: (MatchMonad m p, RepoPatch p) =>
                         [DarcsFlag] -> PatchSet p C(x) -> m ()
    getFirstMatchS fs repo =
        case hasLastn fs of
        Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo)
        Nothing -> case firstMatcher fs of
                   Nothing -> fail "Pattern not specified in getFirstMatch."
                   Just m -> if firstMatcherIsTag fs
                             then getTagS m repo
                             else getMatcherS Inclusive m repo

    -- | @secondMatch fs@ tells whether @fs@ implies a "second match", that
    -- is if we match against patches up to a point in the past on, rather
    -- than against all patches until now.
    secondMatch :: [DarcsFlag] -> Bool
    secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher Patch)) || isJust (hasIndexRange fs)

    getPartialSecondMatch :: RepoPatch p => Repository p C(r u t)
                            -> [DarcsFlag] -> [FileName] -> IO ()
    getPartialSecondMatch r fs files =
        withRecordedMatchOnlySomeSmart fs r files $ \repo ->
        case secondMatcher fs of
        Nothing -> fail "Two patterns not specified in get_second_match."
        Just m -> if secondMatcherIsTag fs
                  then getTagS m repo
                  else getMatcherS Exclusive m repo

    checkMatchSyntax :: [DarcsFlag] -> IO ()
    checkMatchSyntax opts = do
     case getMatchPattern opts of
      Nothing -> return ()
      Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch))

    getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch
    getMatchPattern [] = Nothing
    getMatchPattern (OnePattern m:_) = Just m
    getMatchPattern (SeveralPattern m:_) = Just m
    getMatchPattern (_:fs) = getMatchPattern fs

    tagmatch :: String -> Matcher p
    tagmatch r = make_matcher ("tag-name "++r) tm
        where tm (Sealed2 p) =
                  let n = just_name (info p) in
                  take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n)

    mymatch :: String -> Matcher p
    mymatch r = make_matcher ("patch-name "++r) mm
        where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p

    -- | strictJust is a strict version of the Just constructor, used to ensure
    -- that if we claim we've got a pattern match, that the pattern will
    -- actually match (rathern than fail to compile properly).
    --
    -- /First matcher, Second matcher and Nonrange matcher/
    --
    -- When we match for patches, we have a PatchSet, of which we want a
    -- subset. This subset is formed by the patches in a given interval
    -- which match a given criterion. If we represent time going left to
    -- right (which means the 'PatchSet' is written right to left), then
    -- we have (up to) three 'Matcher's: the 'nonrangeMatcher' is the
    -- criterion we use to select among patches in the interval, the
    -- 'firstMatcher' is the left bound of the interval, and the
    -- 'last_matcher' is the right bound. Each of these matchers can be
    -- present or not according to the options.
    strictJust :: a -> Maybe a
    strictJust x = Just $! x

    -- | @nonrangeMatcher@ is the criterion that is used to match against
    -- patches in the interval. It is 'Just m' when the @--patch@, @--match@,
    -- @--tag@ options are passed (or their plural variants).
    nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
    nonrangeMatcher [] = Nothing
    nonrangeMatcher (OnePattern m:_) = strictJust $ match_pattern m
    nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t
    nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p
    nonrangeMatcher (SeveralPattern m:_) = strictJust $ match_pattern m
    nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p
    nonrangeMatcher (_:fs) = nonrangeMatcher fs

    -- | @nonrangeMatcherIsTag@ returns true if the matching option was
    -- '--tag'
    nonrangeMatcherIsTag :: [DarcsFlag] -> Bool
    nonrangeMatcherIsTag [] = False
    nonrangeMatcherIsTag (OneTag _:_) = True
    nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs

    -- | @firstMatcher@ returns the left bound of the matched interval.
    -- This left bound is also specified when we use the singular versions
    -- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@
    -- returns @Nothing@.
    firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
    firstMatcher [] = Nothing
    firstMatcher (OnePattern m:_) = strictJust $ match_pattern m
    firstMatcher (AfterPattern m:_) = strictJust $ match_pattern m
    firstMatcher (AfterTag t:_) = strictJust $ tagmatch t
    firstMatcher (OnePatch p:_) = strictJust $ mymatch p
    firstMatcher (AfterPatch p:_) = strictJust $ mymatch p
    firstMatcher (_:fs) = firstMatcher fs

    firstMatcherIsTag :: [DarcsFlag] -> Bool
    firstMatcherIsTag [] = False
    firstMatcherIsTag (AfterTag _:_) = True
    firstMatcherIsTag (_:fs) = firstMatcherIsTag fs

    secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
    secondMatcher [] = Nothing
    secondMatcher (OnePattern m:_) = strictJust $ match_pattern m
    secondMatcher (UpToPattern m:_) = strictJust $ match_pattern m
    secondMatcher (OnePatch p:_) = strictJust $ mymatch p
    secondMatcher (UpToPatch p:_) = strictJust $ mymatch p
    secondMatcher (UpToTag t:_) = strictJust $ tagmatch t
    secondMatcher (_:fs) = secondMatcher fs

    secondMatcherIsTag :: [DarcsFlag] -> Bool
    secondMatcherIsTag [] = False
    secondMatcherIsTag (UpToTag _:_) = True
    secondMatcherIsTag (_:fs) = secondMatcherIsTag fs

    -- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in
    -- the flags listed in @fs@.
    matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool
    matchAPatchread fs = case nonrangeMatcher fs of
                           Nothing -> const True
                           Just m -> apply_matcher m

    -- | @matchAPatch fs p@ tells whether @p@ matches the matchers in
    -- the flags @fs@
    matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool
    matchAPatch fs p =
        case nonrangeMatcher fs of
        Nothing -> True
        Just m -> apply_matcher m (patch2patchinfo p `piap` p)

    matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)
    matchPatch fs ps =
        case hasIndexRange fs of
        Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of
                                 Just (Sealed2 p) -> seal2 $ hopefully p
                                 Nothing -> error "Patch out of range!"
                    | otherwise -> bug ("Invalid index range match given to matchPatch: "++
                                        show (PatchIndexRange a a'))
                    where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p))
                          myhead (NilRL:<:x) = myhead x
                          myhead ((x:<:_):<:_) = Just $ seal2 x
                          myhead NilRL = Nothing
        Nothing -> case nonrangeMatcher fs of
                        Nothing -> bug "Couldn't matchPatch"
                        Just m -> findAPatch m ps

    getOnePatchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)
    getOnePatchset repository fs =
        case nonrangeMatcher fs of
            Just m -> do ps <- read_repo repository
                         if nonrangeMatcherIsTag fs
                            then return $ getMatchingTag m ps
                            else return $ matchAPatchset m ps
            Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs)
        where context_f [] = bug "Couldn't match_nonrange_patchset"
              context_f (Context f:_) = f
              context_f (_:xs) = context_f xs

    -- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.
    hasLastn :: [DarcsFlag] -> Maybe Int
    hasLastn [] = Nothing
    hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."
    hasLastn (LastN n:_) = Just n
    hasLastn (_:fs) = hasLastn fs

    hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int)
    hasIndexRange [] = Nothing
    hasIndexRange (PatchIndexRange x y:_) = Just (x,y)
    hasIndexRange (_:fs) = hasIndexRange fs

    -- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its
    -- first matcher, ie the one that comes first dependencywise. Hence,
    -- patches in @matchFirstPatchset fs ps@ are the ones we don't want.
    --
    -- Question: are they really? Florent
    matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
    matchFirstPatchset fs patchset =
        case hasLastn fs of
        Just n -> dropn n patchset
        Nothing ->
            case hasIndexRange fs of
            Just (_,b) -> dropn b patchset
            Nothing ->
                   case firstMatcher fs of
                   Nothing -> bug "Couldn't matchFirstPatchset"
                   Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs
                                                then getMatchingTag m patchset
                                                else matchAPatchset m patchset

    -- | @dropn n ps@ drops the @n@ last patches from @ps@.
    dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p
    dropn n ps | n <= 0 = seal ps
    dropn n (NilRL:<:ps) = dropn n ps
    dropn _ NilRL = seal $ NilRL:<:NilRL
    dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs

    -- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its
    -- second matcher, ie the one that comes last dependencywise.
    matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
    matchSecondPatchset fs ps =
      case hasIndexRange fs of
      Just (a,_) -> dropn (a-1) ps
      Nothing ->
        case secondMatcher fs of
        Nothing -> bug "Couldn't matchSecondPatchset"
        Just m -> if secondMatcherIsTag fs
                  then getMatchingTag m ps
                  else matchAPatchset m ps

    -- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and
    -- calls 'error' if there is none.
    findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)
    findAPatch m NilRL = error $ "Couldn't find patch matching " ++ show m
    findAPatch m (NilRL:<:xs) = findAPatch m xs
    findAPatch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p
                                   | otherwise = findAPatch m (ps:<:xs)

    -- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@
    -- ending in patch which matches @m@. Calls 'error' if there is none.
    matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
    matchAPatchset m NilRL = error $ "Couldn't find patch matching " ++ show m
    matchAPatchset m (NilRL:<:xs) = matchAPatchset m xs
    matchAPatchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)
                                       | otherwise = matchAPatchset m (ps:<:xs)

    -- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags
    -- returns a 'SealedPatchSet' containing all patches in the last tag which
    -- matches @m@. Last tag means the most recent tag in repository order,
    -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls
    -- 'error' if there is no matching tag.
    getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
    getMatchingTag m NilRL = error $ "Couldn't find a tag matching " ++ show m
    getMatchingTag m (NilRL:<:xs) = getMatchingTag m xs
    getMatchingTag m xxx@((p:<:ps):<:xs)
        | apply_matcher m p = get_patches_in_tag (info p) xxx
        | otherwise = getMatchingTag m (ps:<:xs)

    -- | @matchExists m ps@ tells whether there is a patch matching
    -- @m@ in @ps@
    matchExists :: Matcher p -> PatchSet p C(x) -> Bool
    matchExists _ NilRL = False
    matchExists m (NilRL:<:xs) = matchExists m xs
    matchExists m ((p:<:ps):<:xs) | apply_matcher m $ p = True
                                   | otherwise = matchExists m (ps:<:xs)

    applyInvToMatcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
    applyInvToMatcher _ _ NilRL = impossible
    applyInvToMatcher ioe m (NilRL:<:xs) = applyInvToMatcher ioe m xs
    applyInvToMatcher ioe m ((p:<:ps):<:xs)
        | apply_matcher m p = when (ioe == Inclusive) (applyInvp p)
        | otherwise = applyInvp p >> applyInvToMatcher ioe m (ps:<:xs)

    -- | @maybeReadFile@ recursively gets the contents of all files
    -- in a directory, or just the contents of a file if called on a
    -- simple file.
    maybeReadFile :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])
    maybeReadFile file = do
        d <- mDoesDirectoryExist file
        if d
          then do
            children <- mInCurrentDirectory file mGetDirectoryContents
            maybe_read_files [file /// ch | ch <-  children]
          else do
             e <- mDoesFileExist file
             if e
               then do
                 contents <- mReadFilePS file
                 return  [(norm_path file, contents)]
               else return []
      where maybe_read_files [] =  return []
            maybe_read_files (f:fs) = do
                          x <- maybeReadFile f
                          y <- maybe_read_files fs
                          return $ concat [x,y]

    getMatcherS :: (MatchMonad m p, RepoPatch p) =>
                     InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
    getMatcherS ioe m repo =
        if matchExists m repo
        then applyInvToMatcher ioe m repo
        else fail $ "Couldn't match pattern "++ show m

    getTagS :: (MatchMonad m p, RepoPatch p) =>
                 Matcher p -> PatchSet p C(x) -> m ()
    getTagS match repo = do
        let pinfo = patch2patchinfo `unseal2` (findAPatch match repo)
        case get_patches_beyond_tag pinfo repo of
            FlippedSeal extras -> applyInvRL extras

    -- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd
    -- patch', and to apply its inverse. If we fail to fetch the patch
    -- (presumably in a partial repositiory), then we share our sorrow
    -- with the user.
    applyInvp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()
    applyInvp hp = apply [] (invert $ fromHopefully hp)
        where fromHopefully = conscientiously $ \e ->
                         text "Sorry, partial repository problem.  Patch not available:"
                         $$ e
                         $$ text ""
                         $$ text "If you think what you're trying to do is ok then"
                         $$ text "report this as a bug on the darcs-user list."

    -- | a version of 'take' for 'RL' lists that cater for contexts.
    safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)
    safetake 0 _ = flipSeal NilRL
    safetake _ NilRL = error "There aren't that many patches..."
    safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as

    -- | A @MatchMonad p m@ is a monad in which we match patches from @p@
    -- by playing with them in @m@, a 'WriteableDirectory' monad. How we
    -- play with the patches depends on the instance of @MatchMonad@ we're
    -- using. If we use @IO@, then we'll apply the patches directly in
    -- @m@, if we use @SlurpMonad@, then we'll apply the patches to a
    -- slurpy, and write to disk at the end. Note that both @IO@ and
    -- @SlurpMonad@ have an instance of 'WriteableDirectory' that
    -- implicitely writes in the current directory.
    class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where
        withRecordedMatch :: Repository p C(r u t)
                          -> (PatchSet p C(r) -> m ()) -> IO ()
        -- ^ @withRecordedMatch@ is responsible for getting the recorded state
        -- into the monad, and then applying the second argument, and
        -- finally placing the resulting state into the current directory.
        withRecordedMatchOnlySomeFiles
            :: Repository p C(r u t) -> [FileName]
            -> (PatchSet p C(r) -> m ()) -> IO ()
        -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of
        -- withRecordedMatch that may only return some of the files
        -- (e.g. if we want to run diff on just a few files).
        withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j
        applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m ()
        applyInvRL NilRL = return ()
        applyInvRL (p:<:ps) = applyInvp p >> applyInvRL ps

    withRecordedMatchIO :: RepoPatch p => Repository p C(r u t)
                        -> (PatchSet p C(r) -> IO ()) -> IO ()
    withRecordedMatchIO = withRecordedMatch

    -- | @withRecordedMatchSmart@ hides away the choice of the
    -- 'SlurpMonad' to use in order to apply 'withRecordedMatch'.
    -- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else
    -- use @IO@. In both case, the result is in the @IO@ monad.
    --
    -- Suggestion: shouldn't we name @withRecordedMatchSmart@
    -- @withRecordedMatch@, and give the monad function another name such
    -- as @withRecordedMatchRaw@?
    withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
                           -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
                           -> IO ()
    withRecordedMatchSmart opts r j =
     do if willStoreInMemory opts then withSM r j
                                  else withRecordedMatchIO r j
        where withSM :: RepoPatch p => Repository p C(r u t)
                     -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
              withSM = withRecordedMatch

    -- | @withRecordedMatchOnlySomeSmart@ is the smart version of
    -- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome'
    -- either in the 'SlurpMonad' or in @IO@ according to the
    -- @--store-in-memory@ flag.
    withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
                           -> [FileName]
                           -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
                           -> IO ()
    withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j
    withRecordedMatchOnlySomeSmart opts r files j =
     do if willStoreInMemory opts then withSM r files j
                                  else withIO r files j
        where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName]
                     -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
              withSM = withRecordedMatchOnlySomeFiles
              withIO :: RepoPatch p => Repository p C(r u t) -> [FileName]
                     -> (PatchSet p C(r) -> IO ()) -> IO ()
              withIO = withRecordedMatchOnlySomeFiles

    instance RepoPatch p => MatchMonad IO p where
        withRecordedMatch r job = do createPristineDirectoryTree r "."
                                     read_repo r >>= job
        applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback

    instance RepoPatch p => MatchMonad SlurpMonad p where
        withRecordedMatch r job =
            do ps <- read_repo r
               s <- slurp_recorded r
               case withSlurpy s (job ps) of
                 Left err -> fail err
                 Right (s',_) -> writeSlurpy s' "."
        withRecordedMatchOnlySomeFiles r fs job =
            do ps <- read_repo r
               s <- slurp_recorded r
               case withSlurpy s (job ps >> mapM maybeReadFile fs) of
                 Left err -> fail err
                 Right (_,fcs) -> mapM_ createAFile $ concat fcs
                   where createAFile (p,c) = do ensureDirectories $ superName p
                                                mWriteFilePS p c
                         ensureDirectories d =
                             do isPar <- mDoesDirectoryExist d
                                unless isPar $ do
                                   ensureDirectories $ superName d
                                   mCreateDirectory d

\end{code}