src/Darcs/Match.lhs

   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 -- | @first_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 \end{code}
 201
 202 \begin{code}
 203 tagmatch :: String -> Matcher p
 204 tagmatch r = make_matcher ("tag-name "++r) tm
 205     where tm (Sealed2 p) =
 206               let n = just_name (info p) in
 207               take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n)
 208
 209 mymatch :: String -> Matcher p
 210 mymatch r = make_matcher ("patch-name "++r) mm
 211     where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p
 212
 213
 214 -- | strictJust is a strict version of the Just constructor, used to ensure
 215 -- that if we claim we've got a pattern match, that the pattern will
 216 -- actually match (rathern than fail to compile properly).
 217 --
 218 -- /First matcher, Second matcher and Nonrange matcher/
 219 --
 220 -- When we match for patches, we have a PatchSet, of which we want a
 221 -- subset. This subset is formed by the patches in a given interval
 222 -- which match a given criterion. If we represent time going left to
 223 -- right (which means the 'PatchSet' is written right to left), then
 224 -- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the
 225 -- criterion we use to select among patches in the interval, the
 226 -- 'first_matcher' is the left bound of the interval, and the
 227 -- 'last_matcher' is the right bound. Each of these matchers can be
 228 -- present or not according to the options.
 229 strictJust :: a -> Maybe a
 230 strictJust x = Just $! x
 231
 232 -- | @nonrange_matcher@ is the criterion that is used to match against
 233 -- patches in the interval. It is 'Just m' when the @--patch@, @--match@,
 234 -- @--tag@ options are passed (or their plural variants).
 235 nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
 236 nonrange_matcher [] = Nothing
 237 nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m
 238 nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t
 239 nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p
 240 nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m
 241 nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p
 242 nonrange_matcher (_:fs) = nonrange_matcher fs
 243
 244 -- | @nonrange_matcher_is_tag@ returns true if the matching option was
 245 -- '--tag'
 246 nonrange_matcher_is_tag :: [DarcsFlag] -> Bool
 247 nonrange_matcher_is_tag [] = False
 248 nonrange_matcher_is_tag (OneTag _:_) = True
 249 nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs
 250
 251 -- | @first_matcher@ returns the left bound of the matched interval.
 252 -- This left bound is also specified when we use the singular versions
 253 -- of @--patch@, @--match@ and @--tag@. Otherwise, @first_matcher@
 254 -- returns @Nothing@.
 255 first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
 256 first_matcher [] = Nothing
 257 first_matcher (OnePattern m:_) = strictJust $ match_pattern m
 258 first_matcher (AfterPattern m:_) = strictJust $ match_pattern m
 259 first_matcher (AfterTag t:_) = strictJust $ tagmatch t
 260 first_matcher (OnePatch p:_) = strictJust $ mymatch p
 261 first_matcher (AfterPatch p:_) = strictJust $ mymatch p
 262 first_matcher (_:fs) = first_matcher fs
 263
 264 first_matcher_is_tag :: [DarcsFlag] -> Bool
 265 first_matcher_is_tag [] = False
 266 first_matcher_is_tag (AfterTag _:_) = True
 267 first_matcher_is_tag (_:fs) = first_matcher_is_tag fs
 268
 269 second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
 270 second_matcher [] = Nothing
 271 second_matcher (OnePattern m:_) = strictJust $ match_pattern m
 272 second_matcher (UpToPattern m:_) = strictJust $ match_pattern m
 273 second_matcher (OnePatch p:_) = strictJust $ mymatch p
 274 second_matcher (UpToPatch p:_) = strictJust $ mymatch p
 275 second_matcher (UpToTag t:_) = strictJust $ tagmatch t
 276 second_matcher (_:fs) = second_matcher fs
 277
 278 second_matcher_is_tag :: [DarcsFlag] -> Bool
 279 second_matcher_is_tag [] = False
 280 second_matcher_is_tag (UpToTag _:_) = True
 281 second_matcher_is_tag (_:fs) = second_matcher_is_tag fs
 282 \end{code}
 283
 284 \begin{code}
 285 -- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in
 286 -- the flags listed in @fs@.
 287 match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool
 288 match_a_patchread fs = case nonrange_matcher fs of
 289                        Nothing -> const True
 290                        Just m -> apply_matcher m
 291
 292 -- | @match_a_patch fs p@ tells whether @p@ matches the matchers in
 293 -- the flags @fs@
 294 match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool
 295 match_a_patch fs p =
 296     case nonrange_matcher fs of
 297     Nothing -> True
 298     Just m -> apply_matcher m (patch2patchinfo p `piap` p)
 299
 300 match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)
 301 match_patch fs ps =
 302     case has_index_range fs of
 303     Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of
 304                              Just (Sealed2 p) -> seal2 $ hopefully p
 305                              Nothing -> error "Patch out of range!"
 306                 | otherwise -> bug ("Invalid index range match given to match_patch: "++
 307                                     show (PatchIndexRange a a'))
 308                 where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p))
 309                       myhead (NilRL:<:x) = myhead x
 310                       myhead ((x:<:_):<:_) = Just $ seal2 x
 311                       myhead NilRL = Nothing
 312     Nothing -> case nonrange_matcher fs of
 313                     Nothing -> bug "Couldn't match_patch"
 314                     Just m -> find_a_patch m ps
 315
 316 get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)
 317 get_one_patchset repository fs =
 318     case nonrange_matcher fs of
 319         Just m -> do ps <- read_repo repository
 320                      if nonrange_matcher_is_tag fs
 321                         then return $ get_matching_tag m ps
 322                         else return $ match_a_patchset m ps
 323         Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs)
 324     where context_f [] = bug "Couldn't match_nonrange_patchset"
 325           context_f (Context f:_) = f
 326           context_f (_:xs) = context_f xs
 327
 328 -- | @has_lastn fs@ return the @--last@ argument in @fs@, if any.
 329 has_lastn :: [DarcsFlag] -> Maybe Int
 330 has_lastn [] = Nothing
 331 has_lastn (LastN (-1):_) = error "--last requires a positive integer argument."
 332 has_lastn (LastN n:_) = Just n
 333 has_lastn (_:fs) = has_lastn fs
 334
 335 has_index_range :: [DarcsFlag] -> Maybe (Int,Int)
 336 has_index_range [] = Nothing
 337 has_index_range (PatchIndexRange x y:_) = Just (x,y)
 338 has_index_range (_:fs) = has_index_range fs
 339
 340 -- | @match_first_patchset fs ps@ returns the part of @ps@ before its
 341 -- first matcher, ie the one that comes first dependencywise. Hence,
 342 -- patches in @match_first_patchset fs ps@ are the ones we don't want.
 343 --
 344 -- Question: are they really? Florent
 345 match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
 346 match_first_patchset fs patchset =
 347     case has_lastn fs of
 348     Just n -> dropn n patchset
 349     Nothing ->
 350         case has_index_range fs of
 351         Just (_,b) -> dropn b patchset
 352         Nothing ->
 353                case first_matcher fs of
 354                Nothing -> bug "Couldn't match_first_patchset"
 355                Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs
 356                                             then get_matching_tag m patchset
 357                                             else match_a_patchset m patchset
 358
 359 -- | @dropn n ps@ drops the @n@ last patches from @ps@.
 360 dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p
 361 dropn n ps | n <= 0 = seal ps
 362 dropn n (NilRL:<:ps) = dropn n ps
 363 dropn _ NilRL = seal $ NilRL:<:NilRL
 364 dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs
 365
 366 -- | @match_second_patchset fs ps@ returns the part of @ps@ before its
 367 -- second matcher, ie the one that comes last dependencywise.
 368 match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p
 369 match_second_patchset fs ps =
 370   case has_index_range fs of
 371   Just (a,_) -> dropn (a-1) ps
 372   Nothing ->
 373     case second_matcher fs of
 374     Nothing -> bug "Couldn't match_second_patchset"
 375     Just m -> if second_matcher_is_tag fs
 376               then get_matching_tag m ps
 377               else match_a_patchset m ps
 378
 379 -- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and
 380 -- calls 'error' if there is none.
 381 find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)
 382 find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m
 383 find_a_patch m (NilRL:<:xs) = find_a_patch m xs
 384 find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p
 385                                | otherwise = find_a_patch m (ps:<:xs)
 386
 387 -- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@
 388 -- ending in patch which matches @m@. Calls 'error' if there is none.
 389 match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
 390 match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m
 391 match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs
 392 match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)
 393                                    | otherwise = match_a_patchset m (ps:<:xs)
 394
 395 -- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags
 396 -- returns a 'SealedPatchSet' containing all patches in the last tag which
 397 -- matches @m@. Last tag means the most recent tag in repository order,
 398 -- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls
 399 -- 'error' if there is no matching tag.
 400 get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p
 401 get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m
 402 get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs
 403 get_matching_tag m xxx@((p:<:ps):<:xs)
 404     | apply_matcher m p = get_patches_in_tag (info p) xxx
 405     | otherwise = get_matching_tag m (ps:<:xs)
 406 \end{code}
 407
 408 \begin{code}
 409 -- | @match_exists m ps@ tells whether there is a patch matching
 410 -- @m@ in @ps@
 411 match_exists :: Matcher p -> PatchSet p C(x) -> Bool
 412 match_exists _ NilRL = False
 413 match_exists m (NilRL:<:xs) = match_exists m xs
 414 match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True
 415                                | otherwise = match_exists m (ps:<:xs)
 416 \end{code}
 417
 418 \begin{code}
 419 apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
 420 apply_inv_to_matcher _ _ NilRL = impossible
 421 apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs
 422 apply_inv_to_matcher ioe m ((p:<:ps):<:xs)
 423     | apply_matcher m p = when (ioe == Inclusive) (apply_invp p)
 424     | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs)
 425
 426 -- | @maybe_read_file@ recursively gets the contents of all files
 427 -- in a directory, or just the contents of a file if called on a
 428 -- simple file.
 429 maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])
 430 maybe_read_file file = do
 431     d <- mDoesDirectoryExist file
 432     if d
 433       then do
 434         children <- mInCurrentDirectory file mGetDirectoryContents
 435         maybe_read_files [file /// ch | ch <-  children]
 436       else do
 437          e <- mDoesFileExist file
 438          if e
 439            then do
 440              contents <- mReadFilePS file
 441              return  [(norm_path file, contents)]
 442            else return []
 443   where maybe_read_files [] =  return []
 444         maybe_read_files (f:fs) = do
 445                       x <- maybe_read_file f
 446                       y <- maybe_read_files fs
 447                       return $ concat [x,y]
 448
 449 get_matcher_s :: (MatchMonad m p, RepoPatch p) =>
 450                  InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()
 451 get_matcher_s ioe m repo =
 452     if match_exists m repo
 453     then apply_inv_to_matcher ioe m repo
 454     else fail $ "Couldn't match pattern "++ show m
 455
 456 get_tag_s :: (MatchMonad m p, RepoPatch p) =>
 457              Matcher p -> PatchSet p C(x) -> m ()
 458 get_tag_s match repo = do
 459     let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo)
 460     case get_patches_beyond_tag pinfo repo of
 461         FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras
 462         _ -> impossible
 463
 464 -- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd
 465 -- patch', and to apply its inverse. If we fail to fetch the patch
 466 -- (presumably in a partial repositiory), then we share our sorrow
 467 -- with the user.
 468 apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()
 469 apply_invp hp = apply [] (invert $ fromHopefully hp)
 470     where fromHopefully = conscientiously $ \e ->
 471                      text "Sorry, partial repository problem.  Patch not available:"
 472                      $$ e
 473                      $$ text ""
 474                      $$ text "If you think what you're trying to do is ok then"
 475                      $$ text "report this as a bug on the darcs-user list."
 476
 477 -- | a version of 'take' for 'RL' lists that cater for contexts.
 478 safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)
 479 safetake 0 _ = flipSeal NilRL
 480 safetake _ NilRL = error "There aren't that many patches..."
 481 safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as
 482
 483 \end{code}
 484
 485 \begin{code}
 486 -- | A @MatchMonad p m@ is a monad in which we match patches from @p@
 487 -- by playing with them in @m@, a 'WriteableDirectory' monad. How we
 488 -- play with the patches depends on the instance of @MatchMonad@ we're
 489 -- using. If we use @IO@, then we'll apply the patches directly in
 490 -- @m@, if we use @SlurpMonad@, then we'll apply the patches to a
 491 -- slurpy, and write to disk at the end. Note that both @IO@ and
 492 -- @SlurpMonad@ have an instance of 'WriteableDirectory' that
 493 -- implicitely writes in the current directory.
 494 class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where
 495     withRecordedMatch :: Repository p C(r u t)
 496                       -> (PatchSet p C(r) -> m ()) -> IO ()
 497     -- ^ @withRecordedMatch@ is responsible for getting the recorded state
 498     -- into the monad, and then applying the second argument, and
 499     -- finally placing the resulting state into the current directory.
 500     withRecordedMatchOnlySomeFiles
 501         :: Repository p C(r u t) -> [FileName]
 502         -> (PatchSet p C(r) -> m ()) -> IO ()
 503     -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of
 504     -- withRecordedMatch that may only return some of the files
 505     -- (e.g. if we want to run diff on just a few files).
 506     withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j
 507     applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m ()
 508     applyInvRL NilRL = return ()
 509     applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps
 510
 511 withRecordedMatchIO :: RepoPatch p => Repository p C(r u t)
 512                     -> (PatchSet p C(r) -> IO ()) -> IO ()
 513 withRecordedMatchIO = withRecordedMatch
 514
 515 -- | @withRecordedMatchSmart@ hides away the choice of the
 516 -- 'SlurpMonad' to use in order to apply 'withRecordedMatch'.
 517 -- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else
 518 -- use @IO@. In both case, the result is in the @IO@ monad.
 519 --
 520 -- Suggestion: shouldn't we name @withRecordedMatchSmart@
 521 -- @withRecordedMatch@, and give the monad function another name such
 522 -- as @withRecordedMatchRaw@?
 523 withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
 524                        -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
 525                        -> IO ()
 526 withRecordedMatchSmart opts r j =
 527  do if StoreInMemory `elem` opts then withSM r j
 528                                  else withRecordedMatchIO r j
 529     where withSM :: RepoPatch p => Repository p C(r u t)
 530                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
 531           withSM = withRecordedMatch
 532
 533 -- | @withRecordedMatchOnlySomeSmart@ is the smart version of
 534 -- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome'
 535 -- either in the 'SlurpMonad' or in @IO@ according to the
 536 -- @--store-in-memory@ flag.
 537 withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
 538                        -> [FileName]
 539                        -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())
 540                        -> IO ()
 541 withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j
 542 withRecordedMatchOnlySomeSmart opts r files j =
 543  do if StoreInMemory `elem` opts then withSM r files j
 544                                  else withIO r files j
 545     where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName]
 546                  -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()
 547           withSM = withRecordedMatchOnlySomeFiles
 548           withIO :: RepoPatch p => Repository p C(r u t) -> [FileName]
 549                  -> (PatchSet p C(r) -> IO ()) -> IO ()
 550           withIO = withRecordedMatchOnlySomeFiles
 551
 552 instance RepoPatch p => MatchMonad IO p where
 553     withRecordedMatch r job = do createPristineDirectoryTree r "."
 554                                  read_repo r >>= job
 555     applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback
 556
 557 instance RepoPatch p => MatchMonad SlurpMonad p where
 558     withRecordedMatch r job =
 559         do ps <- read_repo r
 560            s <- slurp_recorded r
 561            case withSlurpy s (job ps) of
 562              Left err -> fail err
 563              Right (s',_) -> writeSlurpy s' "."
 564     withRecordedMatchOnlySomeFiles r fs job =
 565         do ps <- read_repo r
 566            s <- slurp_recorded r
 567            case withSlurpy s (job ps >> mapM maybe_read_file fs) of
 568              Left err -> fail err
 569              Right (_,fcs) -> mapM_ createAFile $ concat fcs
 570                where createAFile (p,c) = do ensureDirectories $ super_name p
 571                                             mWriteFilePS p c
 572                      ensureDirectories d =
 573                          do isPar <- mDoesDirectoryExist d
 574                             if isPar
 575                               then return ()
 576                               else do ensureDirectories $ super_name d
 577                                       mCreateDirectory d
 578
 579 \end{code}