{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

#include "gadts.h"

module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun,
                    patch_match, match_pattern,
                    apply_matcher, make_matcher,
                    parseMatch,
                    match_parser, 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.Hopefully ( PatchInfoAnd, hopefully, info )
import Darcs.Patch ( Patch, Patchy, hunkMatches, listTouchedFiles, patchcontents )
import Darcs.Patch.Info ( just_name, just_author, make_filename,
                          pi_date )
import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 )
import DateMatcher ( parseDateMatcher )

import Darcs.Patch.MatchData ( PatchMatch(..), patch_match )
import qualified Data.ByteString.Char8 as BC

-- | A type for predicates over patches which do not care about
-- contexts
type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool

-- | A @Matcher@ is made of a 'MatchFun' which we will use to match
-- patches and a @String@ representing it.
data Matcher p = MATCH String (MatchFun p)

instance Show (Matcher p) where
    show (MATCH s _) = '"':s ++ "\""

make_matcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p
make_matcher s m = MATCH s m

-- | @apply_matcher@ applies a matcher to a patch.
apply_matcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool
apply_matcher (MATCH _ m) = m . seal2

parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)
parseMatch (PatternMatch s) =
    case parse match_parser "match" s of
    Left err -> Left $ "Invalid -"++"-match pattern '"++s++
                "'.\n"++ unlines (map ("    "++) $ lines $ show err) -- indent
    Right m -> Right m

match_pattern :: Patchy p => PatchMatch -> Matcher p
match_pattern p@(PatternMatch s) =
    case parseMatch p of
    Left err -> error err
    Right m -> make_matcher s m

trivial :: Patchy p => MatchFun p
trivial = const True

match_parser :: Patchy p => CharParser st (MatchFun p)
match_parser = 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

-- FIXME: would this be better defined in Darcs.Commands.Help?
-- | The string that is emitted when the user runs @darcs help --match@.
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 -- This type signature exists to appease GHC.
        ps :: [(String, String, [String], String -> MatchFun Patch)]
        ps = primitiveMatchers
        keywords = [showKeyword k d | (k,d,_,_) <- ps]
        examples = [showExample k e | (k,_,es,_) <- ps, e <- es]
        showKeyword keyword description =
            -- FIXME: it would be nice to have a variable name here:
            -- "author REGEX - match against author (email address)"
            -- or "exact STRING - match against exact patch name".
            "  " ++ keyword ++ " - " ++ description ++ "."
        showExample keyword example =
            -- FIXME: this string is long, and its not a use case I've
            -- ever seen in practice.  Can we use something else,
            -- like "darcs changes --matches"? --twb, 2008-12-28
            "  darcs annotate --summary --match "
            ++ "'" ++ keyword ++ " " ++ example ++ "'"

primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]
                     -- ^ keyword (operator), help description, list
                     -- of examples, matcher function
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 )
 , ("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 '\\' -- allow escapes
                            ; 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) $ just_name (info hp)

exactmatch r (Sealed2 hp) = r == (just_name (info hp))

authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (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 = make_filename (info hp) in
                                  (rh == h) || (rh == h++".gz")

datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d
                                  in dm $ pi_date (info hp)

touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp
                            in or $ map (isJust . matchRegex (mkRegex r)) files