{-# 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"

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