#include "gadts.h"
module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun,
patchMatch, matchPattern,
applyMatcher, makeMatcher,
parseMatch,
matchParser, helpOnMatchers,
) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.Regex ( mkRegex, matchRegex )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafePerformIO )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )
import Darcs.Patch ( Patchy, hunkMatches, listTouchedFiles, patchcontents )
import Darcs.Patch.Info ( justName, justAuthor, justLog, makeFilename,
piDate )
import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 )
import DateMatcher ( parseDateMatcher )
import Darcs.Patch.MatchData ( PatchMatch(..), patchMatch )
import qualified Data.ByteString.Char8 as BC
import Darcs.Patch.Dummy ( DummyPatch )
type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool
data Matcher p = MATCH String (MatchFun p)
instance Show (Matcher p) where
show (MATCH s _) = '"':s ++ "\""
makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p
makeMatcher s m = MATCH s m
applyMatcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool
applyMatcher (MATCH _ m) = m . seal2
parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)
parseMatch (PatternMatch s) =
case parse matchParser "match" s of
Left err -> Left $ "Invalid -"++"-match pattern '"++s++
"'.\n"++ unlines (map (" "++) $ lines $ show err)
Right m -> Right m
matchPattern :: Patchy p => PatchMatch -> Matcher p
matchPattern p@(PatternMatch s) =
case parseMatch p of
Left err -> error err
Right m -> makeMatcher s m
trivial :: Patchy p => MatchFun p
trivial = const True
matchParser :: Patchy p => CharParser st (MatchFun p)
matchParser = do m <- option trivial submatch
eof
return m
submatch :: Patchy p => CharParser st (MatchFun p)
submatch = buildExpressionParser table match <?> "match rule"
table :: OperatorTable Char st (MatchFun p)
table = [ [prefix "not" negate_match,
prefix "!" negate_match ]
, [binary "||" or_match,
binary "or" or_match,
binary "&&" and_match,
binary "and" and_match ]
]
where binary name fun =
Infix (do _ <- trystring name
spaces
return fun) AssocLeft
prefix name fun = Prefix $ do _ <- trystring name
spaces
return fun
negate_match a p = not (a p)
or_match m1 m2 p = (m1 p) || (m2 p)
and_match m1 m2 p = (m1 p) && (m2 p)
trystring :: String -> CharParser st String
trystring s = try $ string s
match :: Patchy p => CharParser st (MatchFun p)
match = between spaces spaces
(parens submatch
<|> choice matchers_
<?> "simple match")
where matchers_ = map createMatchHelper primitiveMatchers
createMatchHelper :: (String, String, [String], String -> MatchFun p)
-> CharParser st (MatchFun p)
createMatchHelper (key,_,_,matcher) =
do _ <- trystring key
spaces
q <- quoted
return $ matcher q
helpOnMatchers :: String
helpOnMatchers = unlines $
["Selecting Patches:",
"",
"The --patches option yields patches with names matching an `extended'",
"regular expression. See regex(7) for details. The --matches option",
"yields patches that match a logical (Boolean) expression: one or more",
"primitive expressions combined by grouping (parentheses) and the",
"complement (not), conjunction (and) and disjunction (or) operators.",
"The C notation for logic operators (!, && and ||) can also be used.",
"",
" --patches=regex is a synonym for --matches='name regex'",
" --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",
" --from-patch and --to-match can be unproblematically combined:",
" darcs changes --from-patch='html.*documentation' --to-match='date 20040212'",
"",
"The following primitive Boolean expressions are supported:"]
++ keywords
++ ["", "Here are some examples:"]
++ examples
where
ps :: [(String, String, [String], String -> MatchFun DummyPatch)]
ps = primitiveMatchers
keywords = [showKeyword k d | (k,d,_,_) <- ps]
examples = [showExample k e | (k,_,es,_) <- ps, e <- es]
showKeyword keyword description =
" " ++ keyword ++ " - " ++ description ++ "."
showExample keyword example =
" darcs annotate --summary --match "
++ "'" ++ keyword ++ " " ++ example ++ "'"
primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]
primitiveMatchers =
[ ("exact", "check a literal string against the patch name"
, ["\"Resolve issue17: use dynamic memory allocation.\""]
, exactmatch )
, ("name", "check a regular expression against the patch name"
, ["issue17", "\"^[Rr]esolve issue17\\>\""]
, mymatch )
, ("author", "check a regular expression against the author name"
, ["\"David Roundy\"", "droundy", "droundy@darcs.net"]
, authormatch )
, ("hunk", "check a regular expression against the contents of a hunk patch"
, ["\"foo = 2\"", "\"^instance .* Foo where$\""]
, hunkmatch )
, ("comment", "check a regular expression against the log message"
, ["\"prevent deadlocks\""]
, logmatch )
, ("hash", "match the darcs hash for a patch"
, ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"]
, hashmatch )
, ("date", "match the patch date"
, ["\"2006-04-02 22:41\"", "\"tea time yesterday\""]
, datematch )
, ("touch", "match file paths for a patch"
, ["src/foo.c", "src/", "\"src/*.(c|h)\""]
, touchmatch ) ]
parens :: CharParser st (MatchFun p)
-> CharParser st (MatchFun p)
parens p = between (string "(") (string ")") p
quoted :: CharParser st String
quoted = between (char '"') (char '"')
(many $ do { _ <- char '\\'
; try (oneOf ['\\', '"']) <|> return '\\'
}
<|> noneOf ['"'])
<|> between spaces spaces (many $ noneOf " ()")
<?> "string"
mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p
mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp)
exactmatch r (Sealed2 hp) = r == (justName (info hp))
authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp)
logmatch :: Patchy p => String -> MatchFun p
logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp)
hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp
regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack)
in hunkMatches regexMatcher patch
hashmatch h (Sealed2 hp) = let rh = makeFilename (info hp) in
(rh == h) || (rh == h++".gz")
datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d
in dm $ piDate (info hp)
touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp
in or $ map (isJust . matchRegex (mkRegex r)) files