%  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 ( match_first_patchset, match_second_patchset,
               match_patch,
               match_a_patch, match_a_patchread,
               get_first_match, get_nonrange_match,
               get_partial_first_match, get_partial_second_match,
               get_partial_nonrange_match,
               first_match, second_match, have_nonrange_match,
               have_patchset_match, get_one_patchset,
               checkMatchSyntax,
             ) where

import Text.Regex ( mkRegex, matchRegex )
import Control.Monad ( when )
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.Ordered ( RL(..), concatRL, consRLSealed )

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

import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,
                                StoreInMemory,
                               AfterPatch, UpToPatch, LastN, PatchIndexRange,
                               OneTag, AfterTag, UpToTag,
                               OnePattern, SeveralPattern,
                               AfterPattern, UpToPattern ) )
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, super_name, norm_path, (///) )
import Darcs.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

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

-- | @have_patchset_match 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 @have_nonrange_match@?
have_patchset_match :: [DarcsFlag] -> Bool
have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs
    where hasC [] = False
          hasC (Context _:_) = True
          hasC (_:xs) = hasC xs

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

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

get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) =>
                        [DarcsFlag] -> PatchSet p C(x) -> m ()
get_nonrange_match_s fs repo =
    case nonrange_matcher fs of
        Just m -> if nonrange_matcher_is_tag fs
                        then get_tag_s m repo
                        else get_matcher_s Exclusive m repo
        Nothing -> fail "Pattern not specified in get_nonrange_match."

-- | @first_match 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.
first_match :: [DarcsFlag] -> Bool
first_match fs = isJust (has_lastn fs)
                 || isJust (first_matcher fs::Maybe (Matcher Patch))
                 || isJust (has_index_range fs)

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

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

get_first_match_s :: (MatchMonad m p, RepoPatch p) =>
                     [DarcsFlag] -> PatchSet p C(x) -> m ()
get_first_match_s fs repo =
    case has_lastn fs of
    Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo)
    Nothing -> case first_matcher fs of
               Nothing -> fail "Pattern not specified in get_first_match."
               Just m -> if first_matcher_is_tag fs
                         then get_tag_s m repo
                         else get_matcher_s Inclusive m repo


-- | @first_match 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.
second_match :: [DarcsFlag] -> Bool
second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs)

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

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

get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch
get_match_pattern [] = Nothing
get_match_pattern (OnePattern m:_) = Just m
get_match_pattern (SeveralPattern m:_) = Just m
get_match_pattern (_:fs) = get_match_pattern 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 'nonrange_matcher' is the
-- criterion we use to select among patches in the interval, the
-- 'first_matcher' 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

-- | @nonrange_matcher@ 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).
nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
nonrange_matcher [] = Nothing
nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m
nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t
nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p
nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m
nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p
nonrange_matcher (_:fs) = nonrange_matcher fs

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

-- | @first_matcher@ 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, @first_matcher@
-- returns @Nothing@.
first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
first_matcher [] = Nothing
first_matcher (OnePattern m:_) = strictJust $ match_pattern m
first_matcher (AfterPattern m:_) = strictJust $ match_pattern m
first_matcher (AfterTag t:_) = strictJust $ tagmatch t
first_matcher (OnePatch p:_) = strictJust $ mymatch p
first_matcher (AfterPatch p:_) = strictJust $ mymatch p
first_matcher (_:fs) = first_matcher fs

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

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

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

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

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

match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)
match_patch fs ps =
    case has_index_range 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 match_patch: "++
                                    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 nonrange_matcher fs of
                    Nothing -> bug "Couldn't match_patch"
                    Just m -> find_a_patch m ps

get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)
get_one_patchset repository fs =
    case nonrange_matcher fs of
        Just m -> do ps <- read_repo repository
                     if nonrange_matcher_is_tag fs
                        then return $ get_matching_tag m ps
                        else return $ match_a_patchset 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

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

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

-- | @match_first_patchset fs ps@ returns the part of @ps@ before its
-- first matcher, ie the one that comes first dependencywise. Hence,
-- patches in @match_first_patchset fs ps@ are the ones we don't want.
--
-- Question: are they really? Florent
match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
match_first_patchset fs patchset =
    case has_lastn fs of
    Just n -> dropn n patchset
    Nothing ->
        case has_index_range fs of
        Just (_,b) -> dropn b patchset
        Nothing ->
               case first_matcher fs of
               Nothing -> bug "Couldn't match_first_patchset"
               Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs
                                            then get_matching_tag m patchset
                                            else match_a_patchset 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

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

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

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

-- | @get_matching_tag 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.
get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m
get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs
get_matching_tag m xxx@((p:<:ps):<:xs)
    | apply_matcher m p = get_patches_in_tag (info p) xxx
    | otherwise = get_matching_tag m (ps:<:xs)

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

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

-- | @maybe_read_file@ recursively gets the contents of all files
-- in a directory, or just the contents of a file if called on a
-- simple file.
maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])
maybe_read_file 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 <- maybe_read_file f
                      y <- maybe_read_files fs
                      return $ concat [x,y]

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

get_tag_s :: (MatchMonad m p, RepoPatch p) =>
             Matcher p -> PatchSet p C(x) -> m ()
get_tag_s match repo = do
    let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo)
    case get_patches_beyond_tag pinfo repo of
        FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras
        _ -> impossible

-- | @apply_invp@ 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.
apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()
apply_invp 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) = apply_invp 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 StoreInMemory `elem` 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 StoreInMemory `elem` 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 maybe_read_file fs) of
             Left err -> fail err
             Right (_,fcs) -> mapM_ createAFile $ concat fcs
               where createAFile (p,c) = do ensureDirectories $ super_name p
                                            mWriteFilePS p c
                     ensureDirectories d =
                         do isPar <- mDoesDirectoryExist d
                            if isPar
                              then return ()
                              else do ensureDirectories $ super_name d
                                      mCreateDirectory d

\end{code}