% 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 #-}
module Darcs.Match ( match_first_patchset, match_second_patchset,
match_patch,
match_a_patch, doesnt_not_match, match_a_patchread,
get_first_match, get_second_match, get_first_match_s, get_second_match_s,
get_nonrange_match_s,
first_match, second_match, have_nonrange_match,
have_patchset_match, get_one_patchset, apply_patches_to_some_files,
checkMatchSyntax,
) where
import Text.Regex ( mkRegex, matchRegex )
import Control.Monad ( liftM )
import Data.Maybe ( isJust )
import Darcs.Hopefully ( PatchInfoAnd, info, piap,
conscientiously, hopefully )
import Darcs.Patch.Info ( just_name )
import Darcs.Patch ( RepoPatch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )
import Darcs.Repository ( Repository, PatchSet, 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.Patch.Ordered ( RL(..), concatRL )
import FastPackedString ( mmapFilePS )
import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,
AfterPatch, UpToPatch, LastN,
OneTag, AfterTag, UpToTag,
OnePattern, SeveralPattern,
AfterPattern, UpToPattern ) )
import Darcs.Patch.Bundle ( scan_context )
import Darcs.Patch.Match ( Matcher, match_pattern, apply_matcher, make_matcher, parseMatch )
import Darcs.Patch.MatchData ( PatchMatch )
import Printer ( text, ($$) )
import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )
import Darcs.SlurpDirectory ( SlurpMonad(..) )
import FileName (fp2fn, FileName, super_name, norm_path, (///))
import FastPackedString (PackedString)
import Darcs.Sealed ( Sealed(..), FlippedSeal(..), unsafeUnseal, unsealM )
#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}
have_nonrange_match :: [DarcsFlag] -> Bool
have_nonrange_match fs = isJust (nonrange_matcher fs)
have_patchset_match :: [DarcsFlag] -> Bool
have_patchset_match fs = isJust (nonrange_matcher fs) || hasC fs
where hasC [] = False
hasC (Context _:_) = True
hasC (_:xs) = hasC xs
get_nonrange_match_s :: RepoPatch p => [DarcsFlag] -> PatchSet p -> SlurpMonad ()
get_nonrange_match_s fs repo =
case nonrange_matcher fs of
Just m -> if nonrange_matcher_is_tag fs
then get_tag_s repo m
else get_matcher_s repo m
Nothing -> fail "Pattern not specified in get_nonrange_match."
first_match :: [DarcsFlag] -> Bool
first_match fs = isJust (has_lastn fs) || isJust (first_matcher fs)
get_first_match :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()
get_first_match r fs =
case has_lastn fs of
Just n -> get_dropn r n
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 r m
else get_before_matcher r m
get_first_match_s :: RepoPatch p => [DarcsFlag] ->PatchSet p -> SlurpMonad ()
get_first_match_s fs repo =
case has_lastn fs of
Just n -> get_dropn_s repo n
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 repo m
else get_before_matcher_s repo m
second_match :: [DarcsFlag] -> Bool
second_match fs = isJust $ second_matcher fs
get_second_match :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()
get_second_match r fs =
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 r m
else get_matcher r m
get_second_match_s :: RepoPatch p => [DarcsFlag] -> PatchSet p -> SlurpMonad ()
get_second_match_s fs 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 repo m
else get_matcher_s repo m
checkMatchSyntax :: [DarcsFlag] -> IO ()
checkMatchSyntax opts = do
case get_match_pattern opts of
Nothing -> return ()
Just p -> either fail (const $ return ()) $ parseMatch p
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
\end{code}
\begin{code}
tagmatch :: String -> Matcher p
tagmatch r = make_matcher ("tag-name "++r) tm
where tm 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 = isJust . matchRegex (mkRegex r) . just_name . info
-- | 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).
strictJust :: a -> Maybe a
strictJust x = Just $! x
nonrange_matcher :: [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 :: [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 :: [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 :: [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
\end{code}
\begin{code}
doesnt_not_match :: [DarcsFlag] -> PatchInfoAnd p -> Bool
doesnt_not_match fs =
case nonrange_matcher fs of
Nothing -> \_ -> True
Just m -> apply_matcher m
match_a_patchread :: [DarcsFlag] -> PatchInfoAnd p -> Bool
match_a_patchread fs = case nonrange_matcher fs of
Nothing -> const True
Just m -> apply_matcher m
match_a_patch :: [DarcsFlag] -> Named p -> 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 -> Named p
match_patch fs ps = 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 -> [DarcsFlag] -> IO (PatchSet p)
get_one_patchset repository fs =
case nonrange_matcher fs of
Just m -> do Sealed 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 -> scan_context `liftM` mmapFilePS (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 :: [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
match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p -> PatchSet p
match_first_patchset fs patchset =
case has_lastn fs of
Just n -> dropn n patchset
Nothing -> case first_matcher fs of
Nothing -> bug "Couldn't match_first_patchset"
Just m -> dropn 1 $ if first_matcher_is_tag fs
then get_matching_tag m patchset
else match_a_patchset m patchset
where dropn :: Int -> PatchSet p -> PatchSet p
dropn n (NilRL:<:ps) = dropn n ps
dropn 0 ps = ps
dropn _ NilRL = NilRL:<:NilRL
dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs
match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p -> PatchSet p
match_second_patchset fs ps =
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 :: RepoPatch p => Matcher p -> PatchSet p -> 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 = hopefully p
| otherwise = find_a_patch m (ps:<:xs)
match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p -> PatchSet 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 = ((p:<:ps):<:xs)
| otherwise = match_a_patchset m (ps:<:xs)
get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p -> PatchSet 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 = unsafeUnseal $ get_patches_in_tag (info p) xxx
| otherwise = get_matching_tag m (ps:<:xs)
\end{code}
\begin{code}
match_exists :: Matcher p -> PatchSet p -> 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)
\end{code}
\begin{code}
get_matcher :: RepoPatch p => Repository p -> Matcher p -> IO ()
get_matcher r m = do Sealed repo <- read_repo r
if match_exists m repo
then do createPristineDirectoryTree r "."
apply_inv_to_matcher m repo
else fail $ "Couldn't match pattern "++ show m
get_before_matcher :: RepoPatch p => Repository p -> Matcher p -> IO ()
get_before_matcher r m =
do Sealed repo <- read_repo r
if match_exists m repo
then do createPristineDirectoryTree r "."
apply_inv_to_matcher_inclusive m repo
else fail $ "Couldn't match pattern "++ show m
apply_inv_to_matcher_inclusive :: (RepoPatch p, WriteableDirectory m) => Matcher p -> PatchSet p -> m ()
apply_inv_to_matcher_inclusive _ NilRL = impossible
apply_inv_to_matcher_inclusive m (NilRL:<:xs) = apply_inv_to_matcher m xs
apply_inv_to_matcher_inclusive m ((p:<:ps):<:xs)
| apply_matcher m p = apply_invp p
| otherwise = apply_invp p >> apply_inv_to_matcher_inclusive m (ps:<:xs)
apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => Matcher p -> PatchSet p -> m ()
apply_inv_to_matcher _ NilRL = impossible
apply_inv_to_matcher m (NilRL:<:xs) = apply_inv_to_matcher m xs
apply_inv_to_matcher m ((p:<:ps):<:xs)
| apply_matcher m p = return ()
| otherwise = apply_invp p >> apply_inv_to_matcher m (ps:<:xs)
maybe_read_file :: FileName -> SlurpMonad ([(FileName, PackedString)])
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_file_contents :: RepoPatch p => Repository p -> [FilePath] -> (PatchSet p -> SlurpMonad())
-> IO ([(FileName, PackedString)])
get_file_contents r files gf = do
s <- slurp_recorded r
Sealed repo <- read_repo r
let SM slurpFunc = gf repo >> mapM ( maybe_read_file . fp2fn) files
case (slurpFunc $ Right s) of
Left err -> fail err
Right (_, ret) -> return $ concat ret
apply_patches_to_some_files :: RepoPatch p => Repository p -> [FilePath]
-> (PatchSet p -> SlurpMonad()) -> IO ()
apply_patches_to_some_files r files gf = do
fcs <- get_file_contents r files gf
writeFiles fcs
where writeFiles [] = return ()
writeFiles ((p, c):xs) = (ensureDirectories $ super_name p) >> ( mWriteFilePS p c) >> writeFiles xs
ensureDirectories d = do
isPar <- mDoesDirectoryExist d
if isPar
then return ()
else ensureDirectories (super_name d) >> (mCreateDirectory d)
get_matcher_s :: RepoPatch p => PatchSet p -> Matcher p -> SlurpMonad ()
get_matcher_s repo m =
if match_exists m repo
then apply_inv_to_matcher m repo
else fail $ "Couldn't match pattern "++ show m
get_before_matcher_s :: RepoPatch p => PatchSet p -> Matcher p -> SlurpMonad ()
get_before_matcher_s repo m =
if match_exists m repo
then apply_inv_to_matcher_inclusive m repo
else fail $ "Couldn't match pattern "++ show m
get_dropn_s :: RepoPatch p => PatchSet p -> Int -> SlurpMonad ()
get_dropn_s repo n = applyInvRL $ safetake n $ concatRL repo
get_tag_s :: RepoPatch p => PatchSet p -> Matcher p -> SlurpMonad ()
get_tag_s repo match = do
let pinfo = patch2patchinfo $ find_a_patch match repo
case get_patches_beyond_tag pinfo repo of
FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras
_ -> impossible
applyInvRL :: (Patchy p, WriteableDirectory m) => RL (PatchInfoAnd p) -> m ()
applyInvRL NilRL = return ()
applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps
apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p -> 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."
get_dropn :: RepoPatch p => Repository p -> Int -> IO ()
get_dropn r n = do createPristineDirectoryTree r "."
read_repo r `unsealM` (apply_patches [] . invertRL . safetake n . concatRL)
safetake :: Int -> RL a -> RL a
safetake 0 _ = NilRL
safetake _ NilRL = error "There aren't that many patches..."
safetake i (a:<:as) = a :<: safetake (i-1) as
\end{code}
\begin{code}
get_tag :: RepoPatch p => Repository p -> Matcher p -> IO ()
get_tag r match = do
Sealed ps <- read_repo r
let pinfo = patch2patchinfo $ find_a_patch match ps
case get_patches_beyond_tag pinfo ps of
FlippedSeal (extras:<:NilRL) -> do createPristineDirectoryTree r "."
apply_patches [] $ invertRL extras
_ -> impossible
\end{code}