1 %  Copyright (C) 2004-2005 David Roundy
    2 %
    3 %  This program is free software; you can redistribute it and/or modify
    4 %  it under the terms of the GNU General Public License as published by
    5 %  the Free Software Foundation; either version 2, or (at your option)
    6 %  any later version.
    7 %
    8 %  This program is distributed in the hope that it will be useful,
    9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 %  GNU General Public License for more details.
   12 %
   13 %  You should have received a copy of the GNU General Public License
   14 %  along with this program; see the file COPYING.  If not, write to
   15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 %  Boston, MA 02110-1301, USA.
   17 
   18 \begin{code}
   19 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
   20 {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}
   21 
   22 #include "gadts.h"
   23 
   24 module Darcs.Match ( match_first_patchset, match_second_patchset,
   25                match_patch,
   26                match_a_patch, match_a_patchread,
   27                get_first_match, get_nonrange_match,
   28                get_partial_first_match, get_partial_second_match,
   29                get_partial_nonrange_match,
   30                first_match, second_match, have_nonrange_match,
   31                have_patchset_match, get_one_patchset,
   32                checkMatchSyntax,
   33              ) where
   34 
   35 import Text.Regex ( mkRegex, matchRegex )
   36 import Control.Monad ( when )
   37 import Data.Maybe ( isJust )
   38 
   39 import Darcs.Hopefully ( PatchInfoAnd, info, piap,
   40                          conscientiously, hopefully )
   41 import Darcs.Patch.Info ( just_name )
   42 import Darcs.Patch ( RepoPatch, Patch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )
   43 import Darcs.Repository ( Repository, PatchSet, SealedPatchSet, read_repo,
   44                     slurp_recorded, createPristineDirectoryTree )
   45 import Darcs.Repository.ApplyPatches ( apply_patches )
   46 import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag )
   47 import Darcs.Ordered ( RL(..), concatRL, consRLSealed )
   48 
   49 import ByteStringUtils ( mmapFilePS )
   50 import qualified Data.ByteString as B (ByteString)
   51 
   52 import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,
   53                                 StoreInMemory,
   54                                AfterPatch, UpToPatch, LastN, PatchIndexRange,
   55                                OneTag, AfterTag, UpToTag,
   56                                OnePattern, SeveralPattern,
   57                                AfterPattern, UpToPattern ) )
   58 import Darcs.Patch.Bundle ( scan_context )
   59 import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch )
   60 import Darcs.Patch.MatchData ( PatchMatch )
   61 import Printer ( text, ($$) )
   62 
   63 import Darcs.RepoPath ( toFilePath )
   64 import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )
   65 import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy )
   66 import Darcs.Patch.FileName ( FileName, super_name, norm_path, (///) )
   67 import Darcs.Sealed ( FlippedSeal(..), Sealed2(..),
   68                       seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )
   69 #include "impossible.h"
   70 \end{code}
   71 
   72 \paragraph{Selecting patches}\label{selecting}
   73 
   74 Many commands operate on a patch or patches that have already been recorded.
   75 There are a number of options that specify which patches are selected for
   76 these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants
   77 on these, which for \verb!--patch! are \verb!--patches!,
   78 \verb!--from-patch!, and \verb!--to-patch!.  The \verb!--patch! and
   79 \verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular
   80 expressions and match them against tag and patch names.  \verb!--match!,
   81 described below, allows more powerful patterns.
   82 
   83 The plural forms of these options select all matching patches.  The singular
   84 forms select the last matching patch.  The range (from and to) forms select
   85 patches after or up to (both inclusive) the last matching patch.
   86 
   87 These options use the current order of patches in the repository.  darcs may
   88 reorder patches, so this is not necessarily the order of creation or the
   89 order in which patches were applied.  However, as long as you are just
   90 recording patches in your own repository, they will remain in order.
   91 
   92 % NOTE --no-deps is implemented in SelectChanges.lhs, but documented here
   93 % for concistency.
   94 When a patch or a group of patches is selected, all patches they depend on
   95 get silently selected too. For example: \verb!darcs pull --patches bugfix!
   96 means ``pull all the patches with `bugfix' in their name, along with any
   97 patches they require.''  If you really only want patches with `bugfix' in
   98 their name, you should use the \verb!--no-deps! option, which makes darcs
   99 exclude any matched patches from the selection which have dependencies that
  100 are themselves not explicitly matched by the selection.
  101 
  102 For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that
  103 depend on the selected patches are silently included, or if
  104 \verb!--no-deps! is used selected patches with dependencies on not selected
  105 patches are excluded from the selection.
  106 
  107 \begin{code}
  108 data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq
  109 
  110 -- | @have_nonrange_match flags@ tells whether there is a flag in
  111 -- @flags@ which corresponds to a match that is "non-range". Thus,
  112 -- @--match@, @--patch@ and @--index@ make @have_nonrange_match@
  113 -- true, but not @--from-patch@ or @--to-patch@.
  114 have_nonrange_match :: [DarcsFlag] -> Bool
  115 have_nonrange_match fs = isJust (has_index_range fs) || isJust (nonrange_matcher fs::Maybe (Matcher Patch))
  116 
  117 -- | @have_patchset_match flags@ tells whether there is a "patchset
  118 -- match" in the flag list. A patchset match is @--match@ or
  119 -- @--patch@, or @--context@, but not @--from-patch@ nor (!)
  120 -- @--index@.
  121 -- Question: Is it supposed not to be a subset of @have_nonrange_match@?
  122 have_patchset_match :: [DarcsFlag] -> Bool
  123 have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs
  124     where hasC [] = False
  125           hasC (Context _:_) = True
  126           hasC (_:xs) = hasC xs
  127 
  128 get_nonrange_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()
  129 get_nonrange_match r fs = withRecordedMatchSmart fs r (get_nonrange_match_s fs)
  130 
  131 get_partial_nonrange_match :: RepoPatch p => Repository p C(r u t)
  132                            -> [DarcsFlag] -> [FileName] -> IO ()
  133 get_partial_nonrange_match r fs files =
  134     withRecordedMatchOnlySomeSmart fs r files (get_nonrange_match_s fs)
  135 
  136 get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) =>
  137                         [DarcsFlag] -> PatchSet p C(x) -> m ()
  138 get_nonrange_match_s fs repo =
  139     case nonrange_matcher fs of
  140         Just m -> if nonrange_matcher_is_tag fs
  141                         then get_tag_s m repo
  142                         else get_matcher_s Exclusive m repo
  143         Nothing -> fail "Pattern not specified in get_nonrange_match."
  144 
  145 -- | @first_match fs@ tells whether @fs@ implies a "first match", that
  146 -- is if we match against patches from a point in the past on, rather
  147 -- than against all patches since the creation of the repository.
  148 first_match :: [DarcsFlag] -> Bool
  149 first_match fs = isJust (has_lastn fs)
  150                  || isJust (first_matcher fs::Maybe (Matcher Patch))
  151                  || isJust (has_index_range fs)
  152 
  153 get_first_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()
  154 get_first_match r fs = withRecordedMatchSmart fs r (get_first_match_s fs)
  155 
  156 get_partial_first_match :: RepoPatch p => Repository p C(r u t)
  157                         -> [DarcsFlag] -> [FileName] -> IO ()
  158 get_partial_first_match r fs files =
  159     withRecordedMatchOnlySomeSmart fs r files (get_first_match_s fs)
  160 
  161 get_first_match_s :: (MatchMonad m p, RepoPatch p) =>
  162                      [DarcsFlag] -> PatchSet p C(x) -> m ()
  163 get_first_match_s fs repo =
  164     case has_lastn fs of
  165     Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo)
  166     Nothing -> case first_matcher fs of
  167                Nothing -> fail "Pattern not specified in get_first_match."
  168                Just m -> if first_matcher_is_tag fs
  169                          then get_tag_s m repo
  170                          else get_matcher_s Inclusive m repo
  171 
  172 
  173 -- | @second_match fs@ tells whether @fs@ implies a "second match", that
  174 -- is if we match against patches up to a point in the past on, rather
  175 -- than against all patches until now.
  176 second_match :: [DarcsFlag] -> Bool
  177 second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs)
  178 
  179 get_partial_second_match :: RepoPatch p => Repository p C(r u t)
  180                         -> [DarcsFlag] -> [FileName] -> IO ()
  181 get_partial_second_match r fs files =
  182     withRecordedMatchOnlySomeSmart fs r files $ \repo ->
  183     case second_matcher fs of
  184     Nothing -> fail "Two patterns not specified in get_second_match."
  185     Just m -> if second_matcher_is_tag fs
  186               then get_tag_s m repo
  187               else get_matcher_s Exclusive m repo
  188 
  189 checkMatchSyntax :: [DarcsFlag] -> IO ()
  190 checkMatchSyntax opts = do
  191  case get_match_pattern opts of
  192   Nothing -> return ()
  193   Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch))
  194 
  195 get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch
  196 get_match_pattern [] = Nothing
  197 get_match_pattern (OnePattern m:_) = Just m
  198 get_match_pattern (SeveralPattern m:_) = Just m
  199 get_match_pattern (_:fs) = get_match_pattern fs
  200 
  201 tagmatch :: String -> Matcher p
  202 tagmatch r = make_matcher ("tag-name "++r) tm
  203     where tm (Sealed2 p) =
  204               let n = just_name (info p) in
  205               take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n)
  206 
  207 mymatch :: String -> Matcher p
  208 mymatch r = make_matcher ("patch-name "++r) mm
  209     where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p
  210 
  211 
  212 -- | strictJust is a strict version of the Just constructor, used to ensure
  213 -- that if we claim we've got a pattern match, that the pattern will
  214 -- actually match (rathern than fail to compile properly).
  215 --
  216 -- /First matcher, Second matcher and Nonrange matcher/
  217 --
  218 -- When we match for patches, we have a PatchSet, of which we want a
  219 -- subset. This subset is formed by the patches in a given interval
  220 -- which match a given criterion. If we represent time going left to
  221 -- right (which means the 'PatchSet' is written right to left), then
  222 -- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the
  223 -- criterion we use to select among patches in the interval, the
  224 -- 'first_matcher' is the left bound of the interval, and the
  225 -- 'last_matcher' is the right bound. Each of these matchers can be
  226 -- present or not according to the options.
  227 strictJust :: a -> Maybe a
  228 strictJust x = Just $! x
  229 
  230 -- | @nonrange_matcher@ is the criterion that is used to match against
  231 -- patches in the interval. It is 'Just m' when the @--patch@, @--match@,
  232 -- @--tag@ options are passed (or their plural variants).
  233 nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
  234 nonrange_matcher [] = Nothing
  235 nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m
  236 nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t
  237 nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p
  238 nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m
  239 nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p
  240 nonrange_matcher (_:fs) = nonrange_matcher fs
  241 
  242 -- | @nonrange_matcher_is_tag@ returns true if the matching option was
  243 -- '--tag'
  244 nonrange_matcher_is_tag :: [DarcsFlag] -> Bool
  245 nonrange_matcher_is_tag [] = False
  246 nonrange_matcher_is_tag (OneTag _:_) = True
  247 nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs
  248 
  249 -- | @first_matcher@ returns the left bound of the matched interval.
  250 -- This left bound is also specified when we use the singular versions
  251 -- of @--patch@, @--match@ and @--tag@. Otherwise, @first_matcher@
  252 -- returns @Nothing@.
  253 first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
  254 first_matcher [] = Nothing
  255 first_matcher (OnePattern m:_) = strictJust $ match_pattern m
  256 first_matcher (AfterPattern m:_) = strictJust $ match_pattern m
  257 first_matcher (AfterTag t:_) = strictJust $ tagmatch t
  258 first_matcher (OnePatch p:_) = strictJust $ mymatch p
  259 first_matcher (AfterPatch p:_) = strictJust $ mymatch p
  260 first_matcher (_:fs) = first_matcher fs
  261 
  262 first_matcher_is_tag :: [DarcsFlag] -> Bool
  263 first_matcher_is_tag [] = False
  264 first_matcher_is_tag (AfterTag _:_) = True
  265 first_matcher_is_tag (_:fs) = first_matcher_is_tag fs
  266 
  267 second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
  268 second_matcher [] = Nothing
  269 second_matcher (OnePattern m:_) = strictJust $ match_pattern m
  270 second_matcher (UpToPattern m:_) = strictJust $ match_pattern m
  271 second_matcher (OnePatch p:_) = strictJust $ mymatch p
  272 second_matcher (UpToPatch p:_) = strictJust $ mymatch p
  273 second_matcher (UpToTag t:_) = strictJust $ tagmatch t
  274 second_matcher (_:fs) = second_matcher fs
  275 
  276 second_matcher_is_tag :: [DarcsFlag] -> Bool
  277 second_matcher_is_tag [] = False
  278 second_matcher_is_tag (UpToTag _:_) = True
  279 second_matcher_is_tag (_:fs) = second_matcher_is_tag fs
  280 
  281 -- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in
  282 -- the flags listed in @fs@.
  283 match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool
  284 match_a_patchread fs = case nonrange_matcher fs of
  285                        Nothing -> const True
  286                        Just m -> apply_matcher m
  287 
  288 -- | @match_a_patch fs p@ tells whether @p@ matches the matchers in
  289 -- the flags @fs@
  290 match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool
  291 match_a_patch fs p =
  292     case nonrange_matcher fs of
  293     Nothing -> True
  294     Just m -> apply_matcher m (patch2patchinfo p `piap` p)
  295 
  296 match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)
  297 match_patch fs ps =
  298     case has_index_range fs of
  299     Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of
  300                              Just (Sealed2 p) -> seal2 $ hopefully p
  301                              Nothing -> error "Patch out of range!"
  302                 | otherwise -> bug ("Invalid index range match given to match_patch: "++
  303                                     show (PatchIndexRange a a'))
  304                 where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p))
  305                       myhead (NilRL:<:x) = myhead x
  306                       myhead ((x:<:_):<:_) = Just $ seal2 x
  307                       myhead NilRL = Nothing
  308     Nothing -> case nonrange_matcher fs of
  309                     Nothing -> bug "Couldn't match_patch"                                                                                                
  310                     Just m -> find_a_patch m ps
  311 
  312 get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)
  313 get_one_patchset repository fs =
  314     case nonrange_matcher fs of
  315         Just m -> do ps <- read_repo repository
  316                      if nonrange_matcher_is_tag fs
  317                         then return $ get_matching_tag m ps
  318                         else return $ match_a_patchset m ps
  319         Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs)
  320     where context_f [] = bug "Couldn't match_nonrange_patchset"                                                                                                
  321           context_f (Context f:_) = f
  322           context_f (_:xs) = context_f xs
  323 
  324 -- | @has_lastn fs@ return the @--last@ argument in @fs@, if any.
  325 has_lastn :: [DarcsFlag] -> Maybe Int
  326 has_lastn [] = Nothing
  327 has_lastn (LastN (-1):_) = error "--last requires a positive integer argument."
  328 has_lastn (LastN n:_) = Just n
  329 has_lastn (_:fs) = has_lastn fs
  330 
  331 has_index_range :: [DarcsFlag] -> Maybe (Int,Int)
  332 has_index_range [] = Nothing
  333 has_index_range (PatchIndexRange x y:_) = Just (x,y)
  334 has_index_range (_:fs) = has_index_range fs
  335 
  336 -- | @match_first_patchset fs ps@ returns the part of @ps@ before its
  337 -- first matcher, ie the one that comes first dependencywise. Hence,
  338 -- patches in @match_first_patchset fs ps@ are the ones we don't want.
  339 --
  340 -- Question: are they really? Florent
  341 match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
  342 match_first_patchset fs patchset =
  343     case has_lastn fs of
  344     Just n -> dropn n patchset
  345     Nothing ->
  346         case has_index_range fs of
  347         Just (_,b) -> dropn b patchset
  348         Nothing ->
  349                case first_matcher fs of
  350                Nothing -> bug "Couldn't match_first_patchset"                                                                                                
  351                Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs
  352                                             then get_matching_tag m patchset
  353                                             else match_a_patchset m patchset
  354 
  355 -- | @dropn n ps@ drops the @n@ last patches from @ps@.
  356 dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p
  357 dropn n ps | n <= 0 = seal ps
  358 dropn n (NilRL:<:ps) = dropn n ps
  359 dropn _ NilRL = seal $ NilRL:<:NilRL
  360 dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs
  361 
  362 -- | @match_second_patchset fs ps@ returns the part of @ps@ before its
  363 -- second matcher, ie the one that comes last dependencywise.
  364 match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
  365 match_second_patchset fs ps =
  366   case has_index_range fs of
  367   Just (a,_) -> dropn (a-1) ps
  368   Nothing ->
  369     case second_matcher fs of
  370     Nothing -> bug "Couldn't match_second_patchset"                                                                                                
  371     Just m -> if second_matcher_is_tag fs
  372               then get_matching_tag m ps
  373               else match_a_patchset m ps
  374 
  375 -- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and
  376 -- calls 'error' if there is none.
  377 find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)
  378 find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m
  379 find_a_patch m (NilRL:<:xs) = find_a_patch m xs
  380 find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p
  381                                | otherwise = find_a_patch m (ps:<:xs)
  382 
  383 -- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@
  384 -- ending in patch which matches @m@. Calls 'error' if there is none.
  385 match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
  386 match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m
  387 match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs
  388 match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)
  389                                    | otherwise = match_a_patchset m (ps:<:xs)
  390 
  391 -- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags
  392 -- returns a 'SealedPatchSet' containing all patches in the last tag which
  393 -- matches @m@. Last tag means the most recent tag in repository order,
  394 -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls
  395 -- 'error' if there is no matching tag.
  396 get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
  397 get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m
  398 get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs
  399 get_matching_tag m xxx@((p:<:ps):<:xs)
  400     | apply_matcher m p = get_patches_in_tag (info p) xxx
  401     | otherwise = get_matching_tag m (ps:<:xs)
  402 
  403 -- | @match_exists m ps@ tells whether there is a patch matching
  404 -- @m@ in @ps@
  405 match_exists :: Matcher p -> PatchSet p C(x) -> Bool
  406 match_exists _ NilRL = False
  407 match_exists m (NilRL:<:xs) = match_exists m xs
  408 match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True
  409                                | otherwise = match_exists m (ps:<:xs)
  410 
  411 apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
  412 apply_inv_to_matcher _ _ NilRL = impossible                                                                                                
  413 apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs
  414 apply_inv_to_matcher ioe m ((p:<:ps):<:xs)
  415     | apply_matcher m p = when (ioe == Inclusive) (apply_invp p)
  416     | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs)
  417 
  418 -- | @maybe_read_file@ recursively gets the contents of all files
  419 -- in a directory, or just the contents of a file if called on a
  420 -- simple file.
  421 maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])
  422 maybe_read_file file = do
  423     d <- mDoesDirectoryExist file
  424     if d
  425       then do
  426         children <- mInCurrentDirectory file mGetDirectoryContents
  427         maybe_read_files [file /// ch | ch <-  children]
  428       else do
  429          e <- mDoesFileExist file
  430          if e
  431            then do
  432              contents <- mReadFilePS file
  433              return  [(norm_path file, contents)]
  434            else return []
  435   where maybe_read_files [] =  return []
  436         maybe_read_files (f:fs) = do
  437                       x <- maybe_read_file f
  438                       y <- maybe_read_files fs
  439                       return $ concat [x,y]
  440 
  441 get_matcher_s :: (MatchMonad m p, RepoPatch p) =>
  442                  InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
  443 get_matcher_s ioe m repo =
  444     if match_exists m repo
  445     then apply_inv_to_matcher ioe m repo
  446     else fail $ "Couldn't match pattern "++ show m
  447 
  448 get_tag_s :: (MatchMonad m p, RepoPatch p) =>
  449              Matcher p -> PatchSet p C(x) -> m ()
  450 get_tag_s match repo = do
  451     let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo)
  452     case get_patches_beyond_tag pinfo repo of
  453         FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras
  454         _ -> impossible                                                                                                
  455 
  456 -- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd
  457 -- patch', and to apply its inverse. If we fail to fetch the patch
  458 -- (presumably in a partial repositiory), then we share our sorrow
  459 -- with the user.
  460 apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()
  461 apply_invp hp = apply [] (invert $ fromHopefully hp)
  462     where fromHopefully = conscientiously $ \e ->
  463                      text "Sorry, partial repository problem.  Patch not available:"
  464                      $$ e
  465                      $$ text ""
  466                      $$ text "If you think what you're trying to do is ok then"
  467                      $$ text "report this as a bug on the darcs-user list."
  468 
  469 -- | a version of 'take' for 'RL' lists that cater for contexts.
  470 safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)
  471 safetake 0 _ = flipSeal NilRL
  472 safetake _ NilRL = error "There aren't that many patches..."
  473 safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as
  474 
  475 -- | A @MatchMonad p m@ is a monad in which we match patches from @p@
  476 -- by playing with them in @m@, a 'WriteableDirectory' monad. How we
  477 -- play with the patches depends on the instance of @MatchMonad@ we're
  478 -- using. If we use @IO@, then we'll apply the patches directly in
  479 -- @m@, if we use @SlurpMonad@, then we'll apply the patches to a
  480 -- slurpy, and write to disk at the end. Note that both @IO@ and
  481 -- @SlurpMonad@ have an instance of 'WriteableDirectory' that
  482 -- implicitely writes in the current directory.
  483 class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where
  484     withRecordedMatch :: Repository p C(r u t)
  485                       -> (PatchSet p C(r) -> m ()) -> IO ()
  486     -- ^ @withRecordedMatch@ is responsible for getting the recorded state
  487     -- into the monad, and then applying the second argument, and
  488     -- finally placing the resulting state into the current directory.
  489     withRecordedMatchOnlySomeFiles
  490         :: Repository p C(r u t) -> [FileName]
  491         -> (PatchSet p C(r) -> m ()) -> IO ()
  492     -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of
  493     -- withRecordedMatch that may only return some of the files
  494     -- (e.g. if we want to run diff on just a few files).
  495     withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j
  496     applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m ()
  497     applyInvRL NilRL = return ()
  498     applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps
  499 
  500 withRecordedMatchIO :: RepoPatch p => Repository p C(r u t)
  501                     -> (PatchSet p C(r) -> IO ()) -> IO ()
  502 withRecordedMatchIO = withRecordedMatch
  503 
  504 -- | @withRecordedMatchSmart@ hides away the choice of the
  505 -- 'SlurpMonad' to use in order to apply 'withRecordedMatch'.
  506 -- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else
  507 -- use @IO@. In both case, the result is in the @IO@ monad.
  508 --
  509 -- Suggestion: shouldn't we name @withRecordedMatchSmart@
  510 -- @withRecordedMatch@, and give the monad function another name such
  511 -- as @withRecordedMatchRaw@?
  512 withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
  513                        -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
  514                        -> IO ()
  515 withRecordedMatchSmart opts r j =
  516  do if StoreInMemory `elem` opts then withSM r j
  517                                  else withRecordedMatchIO r j
  518     where withSM :: RepoPatch p => Repository p C(r u t)
  519                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
  520           withSM = withRecordedMatch
  521 
  522 -- | @withRecordedMatchOnlySomeSmart@ is the smart version of
  523 -- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome'
  524 -- either in the 'SlurpMonad' or in @IO@ according to the
  525 -- @--store-in-memory@ flag.
  526 withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
  527                        -> [FileName]
  528                        -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
  529                        -> IO ()
  530 withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j
  531 withRecordedMatchOnlySomeSmart opts r files j =
  532  do if StoreInMemory `elem` opts then withSM r files j
  533                                  else withIO r files j
  534     where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName]
  535                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
  536           withSM = withRecordedMatchOnlySomeFiles
  537           withIO :: RepoPatch p => Repository p C(r u t) -> [FileName]
  538                  -> (PatchSet p C(r) -> IO ()) -> IO ()
  539           withIO = withRecordedMatchOnlySomeFiles
  540 
  541 instance RepoPatch p => MatchMonad IO p where
  542     withRecordedMatch r job = do createPristineDirectoryTree r "."
  543                                  read_repo r >>= job
  544     applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback
  545 
  546 instance RepoPatch p => MatchMonad SlurpMonad p where
  547     withRecordedMatch r job =
  548         do ps <- read_repo r
  549            s <- slurp_recorded r
  550            case withSlurpy s (job ps) of
  551              Left err -> fail err
  552              Right (s',_) -> writeSlurpy s' "."
  553     withRecordedMatchOnlySomeFiles r fs job =
  554         do ps <- read_repo r
  555            s <- slurp_recorded r
  556            case withSlurpy s (job ps >> mapM maybe_read_file fs) of
  557              Left err -> fail err
  558              Right (_,fcs) -> mapM_ createAFile $ concat fcs
  559                where createAFile (p,c) = do ensureDirectories $ super_name p
  560                                             mWriteFilePS p c
  561                      ensureDirectories d =
  562                          do isPar <- mDoesDirectoryExist d
  563                             if isPar
  564                               then return ()
  565                               else do ensureDirectories $ super_name d
  566                                       mCreateDirectory d
  567 
  568 \end{code}