--  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.

{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}

-- | /First matcher, Second matcher and Nonrange matcher/
--
-- When we match for patches, we have a PatchSet, of which we want a
-- subset. This subset is formed by the patches in a given interval
-- which match a given criterion. If we represent time going left to
-- right, then we have (up to) three 'Matcher's:
--
-- * the 'firstMatcher' is the left bound of the interval,
--
-- * the 'secondMatcher' is the right bound, and
--
-- * the 'nonrangeMatcher' is the criterion we use to select among
--   patches in the interval.
---
-- Each of these matchers can be present or not according to the
-- options. The patches we want would then be the ones that all
-- present matchers have in common.
--
-- (Implementation note: keep in mind that the PatchSet is written
-- backwards with respect to the timeline, ie., from right to left)
module Darcs.Patch.Match
    (
      matchParser
    , helpOnMatchers
    , addInternalMatcher
    , matchFirstPatchset
    , matchSecondPatchset
    , splitSecondFL
    , matchPatch
    , matchAPatch
    , getNonrangeMatchS
    , firstMatch
    , secondMatch
    , haveNonrangeMatch
    , haveNonrangeExplicitMatch
    , havePatchsetMatch
    , checkMatchSyntax
    , applyInvToMatcher
    , nonrangeMatcher
    , InclusiveOrExclusive(..)
    , matchExists
    , applyNInv
    , hasIndexRange
    , getMatchingTag
    , matchAPatchset
    , getFirstMatchS
    , nonrangeMatcherIsTag
    , MatchFlag(..)
    ) where

import Prelude ()
import Darcs.Prelude

import Text.ParserCombinators.Parsec
    ( parse
    , CharParser
    , (<?>)
    , (<|>)
    , noneOf
    , option
    , eof
    , many
    , try
    , between
    , spaces
    , char
    , oneOf
    , string
    , choice
    )
import Text.ParserCombinators.Parsec.Expr
    ( OperatorTable
    , Assoc( AssocLeft )
    , Operator ( Infix, Prefix )
    , buildExpressionParser
    )
import Text.Regex ( mkRegex, matchRegex )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad ( when )
import Data.List ( isPrefixOf, intercalate )
import Data.Char ( toLower )

import Darcs.Util.Path ( AbsolutePath )
import Darcs.Patch
    ( IsRepoType
    , hunkMatches
    , listTouchedFiles
    , invert
    , invertRL
    , apply
    )
import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname,
                          piDate )
import Darcs.Patch.Named.Wrapped
    ( WrappedNamed
    , patch2patchinfo
    )

import qualified Data.ByteString.Char8 as BC

import Darcs.Patch.Dummy ( DummyPatch )

import Darcs.Patch.Matchable ( Matchable )
import Darcs.Patch.MonadProgress ( MonadProgress )
import Darcs.Patch.Named.Wrapped ( runInternalChecker, namedIsInternal, namedInternalChecker )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, patchSet2RL, Origin )
import Darcs.Patch.Type ( PatchType(..) )
import Darcs.Patch.Apply( Apply, ApplyState )
import Darcs.Patch.ApplyPatches( applyPatches )
import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )
import Darcs.Patch.Invert( Invert )

import Darcs.Patch.Witnesses.Eq ( isIsEq )
import Darcs.Patch.Witnesses.Ordered ( RL(..), snocRLSealed, FL(..), (:>)(..) )
import Darcs.Patch.Witnesses.Sealed
    ( FlippedSeal(..), Sealed2(..),
    seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )
import Darcs.Util.Printer ( text, ($$) )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )

import Darcs.Util.DateMatcher ( parseDateMatcher )

import Darcs.Util.Tree ( Tree )

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

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

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


data MatchFlag =
                 OnePattern      String
               | SeveralPattern  String
               | AfterPattern    String
               | UpToPattern     String
               | OnePatch        String
               | OneHash         String
               | AfterHash       String
               | UpToHash        String
               | SeveralPatch    String
               | AfterPatch      String
               | UpToPatch       String
               | OneTag          String
               | AfterTag        String
               | UpToTag         String
               | LastN           Int
               | PatchIndexRange Int Int
               | Context AbsolutePath
                 deriving ( Show )


makeMatcher :: String -> MatchFun rt p -> Matcher rt p
makeMatcher = MATCH

-- | @applyMatcher@ applies a matcher to a patch.
applyMatcher :: Matcher rt p -> PatchInfoAnd rt p wX wY -> Bool
applyMatcher (MATCH _ m) = m . seal2

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

matchPattern :: Matchable p => String -> Matcher rt p
matchPattern pattern =
    case parseMatch pattern of
    Left err -> error err
    Right m -> makeMatcher pattern m

addInternalMatcher :: (IsRepoType rt) => Maybe (Matcher rt p) -> Maybe (Matcher rt p)
addInternalMatcher om =
  case namedInternalChecker of
    Nothing -> om
    Just f ->
         let matchFun = unseal2 (not . isIsEq . runInternalChecker f . hopefully)
         in case om of
            Nothing -> Just (MATCH "internal patch" matchFun)
            Just (MATCH s oldFun) -> Just (MATCH s (\p -> matchFun p && oldFun p))

matchParser :: Matchable p => CharParser st (MatchFun rt p)
matchParser = submatcher <?> helpfulErrorMsg
  where
    submatcher = do
        m <- option matchAnyPatch submatch
        eof
        return m

    -- When using <?>, Parsec prepends "expecting " to the given error message,
    -- so the phrasing below makes sense.
    helpfulErrorMsg = "valid expressions over: "
                      ++ intercalate ", " (map (\(name, _, _, _, _) -> name) ps)
                      ++ "\nfor more help, see `darcs help patterns`."

    -- This type signature is just to bind an ambiguous type var.
    ps :: [(String, String, String, [String], String -> MatchFun rt DummyPatch)]
    ps = primitiveMatchers

    -- matchAnyPatch is returned if submatch fails without consuming any
    -- input, i.e. if we pass --match '', we want to match anything.
    matchAnyPatch :: MatchFun rt p
    matchAnyPatch = const True

submatch :: Matchable p => CharParser st (MatchFun rt p)
submatch = buildExpressionParser table match

table :: OperatorTable Char st (MatchFun rt 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 (tryNameAndUseFun name fun) AssocLeft
          prefix name fun = Prefix $ tryNameAndUseFun name fun
          tryNameAndUseFun name fun = 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 :: Matchable p => CharParser st (MatchFun rt p)
match = between spaces spaces (parens submatch <|> choice matchers_)
  where
    matchers_ = map createMatchHelper primitiveMatchers

createMatchHelper :: (String, String, String, [String], String -> MatchFun rt p)
                  -> CharParser st (MatchFun rt p)
createMatchHelper (key,_,_,_,matcher) =
  do _ <- trystring key
     spaces
     q <- quoted
     return $ matcher q

-- | The string that is emitted when the user runs @darcs help patterns@.
helpOnMatchers :: [String]
helpOnMatchers =
  ["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'",
   "- --hash=HASH is a synonym for --matches='hash HASH'",
   "- --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 log --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], String -> MatchFun rt DummyPatch)]
        ps = primitiveMatchers
        keywords = [showKeyword (unwords [k,a]) d | (k,a,d,_,_) <- ps]
        examples = [showExample k e | (k,_,_,es,_) <- ps, e <- es]
        showKeyword keyword description =
            "  " ++ keyword ++ " - " ++ description ++ "."
        showExample keyword example =
            "  darcs log --match "
            ++ "'" ++ keyword ++ " " ++ example ++ "'"

primitiveMatchers :: Matchable p => [(String, String, String, [String], String -> MatchFun rt p)]
                     -- ^ keyword (operator), argument name, help description, list
                     -- of examples, matcher function
primitiveMatchers =
 [ ("exact", "STRING", "check literal STRING is equal to patch name"
           , ["\"Resolve issue17: use dynamic memory allocation.\""]
           , exactmatch )
 , ("name", "REGEX", "match REGEX against patch name"
          , ["issue17", "\"^[Rr]esolve issue17\\>\""]
          , namematch )
 , ("author", "REGEX", "match REGEX against patch author"
            , ["\"David Roundy\"", "droundy", "droundy@darcs.net"]
            , authormatch )
 , ("hunk", "REGEX", "match REGEX against contents of a hunk patch"
            , ["\"foo = 2\"", "\"^instance .* Foo where$\""]
            , hunkmatch )
 , ("comment", "REGEX", "match REGEX against the full log message"
         , ["\"prevent deadlocks\""]
         , logmatch )
 , ("hash", "HASH", "match HASH against (a prefix of) the hash of a patch"
          ,  ["c719567e92c3b0ab9eddd5290b705712b8b918ef","c7195"]
          ,  hashmatch )
 , ("date", "DATE", "match DATE against the patch date"
          , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""]
          , datematch )
 , ("touch", "REGEX", "match file paths for a patch"
          , ["src/foo.c", "src/", "\"src/*.(c|h)\""]
          , touchmatch ) ]

parens :: CharParser st (MatchFun rt p)
       -> CharParser st (MatchFun rt p)
parens = between (string "(") (string ")")

quoted :: CharParser st String
quoted = between (char '"') (char '"')
                 (many $ do { _ <- char '\\' -- allow escapes
                            ; try (oneOf "\\\"") <|> return '\\'
                            }
                         <|>  noneOf "\"")
         <|> between spaces spaces (many $ noneOf " ()")
         <?> "string"

datematch, hashmatch, authormatch, exactmatch, namematch, logmatch
  :: String -> MatchFun rt p

hunkmatch, touchmatch
  :: Matchable p => String -> MatchFun rt p

namematch 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 l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp)

hunkmatch r (Sealed2 hp) = let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack
                           in hunkMatches regexMatcher hp

hashmatch h (Sealed2 hp) = let rh = show $ makePatchname (info hp)
                               lh = map toLower h
                           in (lh `isPrefixOf` rh) || (lh == rh ++ ".gz")

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

touchmatch r (Sealed2 hp) = let files = listTouchedFiles hp
                            in any (isJust . matchRegex (mkRegex r)) files

data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq

data IncludeInternalPatches = IncludeInternalPatches | ExcludeInternalPatches
                              deriving Eq

-- | @haveNonrangeMatch flags@ tells whether there is a flag in
-- @flags@ which corresponds to a match that is "non-range". Thus,
-- @--match@, @--patch@, @--hash@ and @--index@ make @haveNonrangeMatch@
-- true, but not @--from-patch@ or @--to-patch@.
haveNonrangeMatch :: forall rt p . (IsRepoType rt, Matchable p)
                  => PatchType rt p -> [MatchFlag] -> Bool
haveNonrangeMatch pt fs = haveNonrangeMatch' IncludeInternalPatches pt fs

-- | @haveNonrangeExplicitMatch flags@ is just like @haveNonrangeMatch flags@,
-- but ignores "internal matchers" used to mask "internal patches"
haveNonrangeExplicitMatch :: forall rt p . (IsRepoType rt, Matchable p)
                          => PatchType rt p -> [MatchFlag] -> Bool
haveNonrangeExplicitMatch pt fs = haveNonrangeMatch' ExcludeInternalPatches pt fs

haveNonrangeMatch' :: forall rt p . (IsRepoType rt, Matchable p)
                   => IncludeInternalPatches -> PatchType rt p -> [MatchFlag] -> Bool
haveNonrangeMatch' i _ fs =
     case hasIndexRange fs of Just (m,n) | m == n -> True; _ -> False
  || isJust (nonrangeMatch::Maybe (Matcher rt p))
    where
     nonrangeMatch | i == IncludeInternalPatches = nonrangeMatcher fs
                   | otherwise = nonrangeMatcherArgs fs

-- | @havePatchsetMatch flags@ tells whether there is a "patchset
-- match" in the flag list. A patchset match is @--match@ or
-- @--patch@, or @--context@, but not @--from-patch@ nor (!)
-- @--index@.
-- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?
havePatchsetMatch
  :: forall rt p
   . (IsRepoType rt, Matchable p)
  => PatchType rt p -> [MatchFlag] -> Bool
havePatchsetMatch _ fs = isJust (nonrangeMatcher fs::Maybe (Matcher rt p)) || hasC fs
    where hasC [] = False
          hasC (Context _:_) = True
          hasC (_:xs) = hasC xs

getNonrangeMatchS :: ( ApplyMonad (ApplyState p) m, MonadProgress m
                     , IsRepoType rt, Matchable p, ApplyState p ~ Tree
                     )
                  => [MatchFlag]
                  -> PatchSet rt p Origin wX
                  -> m ()
getNonrangeMatchS fs repo =
    case nonrangeMatcher fs of
        Just m -> if nonrangeMatcherIsTag fs
                        then getTagS m repo
                        else getMatcherS Exclusive m repo
        Nothing -> fail "Pattern not specified in getNonrangeMatch."

-- | @firstMatch fs@ tells whether @fs@ implies a "first match", that
-- is if we match against patches from a point in the past on, rather
-- than against all patches since the creation of the repository.
firstMatch :: [MatchFlag] -> Bool
firstMatch fs = isJust (hasLastn fs)
                 || isJust (firstMatcher fs::Maybe (Matcher rt DummyPatch))
                 || isJust (hasIndexRange fs)

getFirstMatchS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p, IsRepoType rt)
               => [MatchFlag] -> PatchSet rt p Origin wX -> m ()
getFirstMatchS fs repo =
    case hasLastn fs of
    Just n -> unpullLastN repo n
    Nothing ->
     case hasIndexRange fs of
     Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a
     Nothing    ->
      case firstMatcher fs of
               Nothing -> fail "Pattern not specified in getFirstMatchS."
               Just m -> if firstMatcherIsTag fs
                         then getTagS m repo
                         else getMatcherS Inclusive m repo

-- | @secondMatch fs@ tells whether @fs@ implies a "second match", that
-- is if we match against patches up to a point in the past on, rather
-- than against all patches until now.
secondMatch :: [MatchFlag] -> Bool
secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher rt DummyPatch)) || isJust (hasIndexRange fs)

unpullLastN :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m, IsRepoType rt)
            => PatchSet rt p wX wY
            -> Int
            -> m ()
unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (patchSet2RL repo)

checkMatchSyntax :: [MatchFlag] -> IO ()
checkMatchSyntax opts =
 case getMatchPattern opts of
  Nothing -> return ()
  Just p  -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch))

getMatchPattern :: [MatchFlag] -> Maybe String
getMatchPattern [] = Nothing
getMatchPattern (OnePattern m:_) = Just m
getMatchPattern (SeveralPattern m:_) = Just m
getMatchPattern (_:fs) = getMatchPattern fs

tagmatch :: String -> Matcher rt p
tagmatch r = makeMatcher ("tag-name "++r) tm
    where tm (Sealed2 p) =
              let n = justName (info p) in
              "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n)

patchmatch :: String -> Matcher rt p
patchmatch r = makeMatcher ("patch-name "++r) (namematch r)

hashmatch' :: String -> Matcher rt p
hashmatch' r = makeMatcher ("hash "++r) (hashmatch r)


-- | 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

-- | @nonrangeMatcher@ is the criterion that is used to match against
-- patches in the interval. It is 'Just m' when the @--patch@, @--match@,
-- @--tag@ options are passed (or their plural variants).
nonrangeMatcher :: (IsRepoType rt, Matchable p) => [MatchFlag] -> Maybe (Matcher rt p)
nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)

nonrangeMatcher fs = addInternalMatcher $ nonrangeMatcherArgs fs

nonrangeMatcherArgs [] = Nothing
nonrangeMatcherArgs (OnePattern m:_) = strictJust $ matchPattern m
nonrangeMatcherArgs (OneTag t:_) = strictJust $ tagmatch t
nonrangeMatcherArgs (OnePatch p:_) = strictJust $ patchmatch p
nonrangeMatcherArgs (OneHash h:_) = strictJust $ hashmatch' h
nonrangeMatcherArgs (SeveralPattern m:_) = strictJust $ matchPattern m
nonrangeMatcherArgs (SeveralPatch p:_) = strictJust $ patchmatch p
nonrangeMatcherArgs (_:fs) = nonrangeMatcherArgs fs

-- | @nonrangeMatcherIsTag@ returns true if the matching option was
-- '--tag'
nonrangeMatcherIsTag :: [MatchFlag] -> Bool
nonrangeMatcherIsTag [] = False
nonrangeMatcherIsTag (OneTag _:_) = True
nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs

-- | @firstMatcher@ returns the left bound of the matched interval.
-- This left bound is also specified when we use the singular versions
-- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@
-- returns @Nothing@.
firstMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)
firstMatcher [] = Nothing
firstMatcher (OnePattern m:_) = strictJust $ matchPattern m
firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m
firstMatcher (AfterTag t:_) = strictJust $ tagmatch t
firstMatcher (OnePatch p:_) = strictJust $ patchmatch p
firstMatcher (AfterPatch p:_) = strictJust $ patchmatch p
firstMatcher (OneHash h:_) = strictJust $ hashmatch' h
firstMatcher (AfterHash h:_) = strictJust $ hashmatch' h
firstMatcher (_:fs) = firstMatcher fs

firstMatcherIsTag :: [MatchFlag] -> Bool
firstMatcherIsTag [] = False
firstMatcherIsTag (AfterTag _:_) = True
firstMatcherIsTag (_:fs) = firstMatcherIsTag fs

secondMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher rt p)
secondMatcher [] = Nothing
secondMatcher (OnePattern m:_) = strictJust $ matchPattern m
secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m
secondMatcher (OnePatch p:_) = strictJust $ patchmatch p
secondMatcher (UpToPatch p:_) = strictJust $ patchmatch p
secondMatcher (OneHash h:_) = strictJust $ hashmatch' h
secondMatcher (UpToHash h:_) = strictJust $ hashmatch' h
secondMatcher (UpToTag t:_) = strictJust $ tagmatch t
secondMatcher (_:fs) = secondMatcher fs

secondMatcherIsTag :: [MatchFlag] -> Bool
secondMatcherIsTag [] = False
secondMatcherIsTag (UpToTag _:_) = True
secondMatcherIsTag (_:fs) = secondMatcherIsTag fs

-- | @matchAPatch fs p@ tells whether @p@ matches the matchers in
-- the flags @fs@
matchAPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchInfoAnd rt p wX wY -> Bool
matchAPatch fs p =
  case nonrangeMatcher fs of
    Nothing -> True
    Just m -> applyMatcher m p

matchPatch :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p)
matchPatch fs ps =
    case hasIndexRange fs of
    Just (a,a') | a == a' -> case unseal myhead $ dropn (a-1) ps of
                             Just (Sealed2 p) -> seal2 $ hopefully p
                             Nothing -> error "Patch out of range!"
                | otherwise -> bug ("Invalid index range match given to matchPatch: "++
                                    show (PatchIndexRange a a'))
                where myhead :: PatchSet rt p wStart wX -> Maybe (Sealed2 (PatchInfoAnd rt p))
                      myhead (PatchSet (_ :<: Tagged t _ _) NilRL) = Just $ seal2 t
                      myhead (PatchSet _ (_:<:x)) = Just $ seal2 x
                      myhead _ = Nothing
    Nothing -> case nonrangeMatcher fs of
                    Nothing -> bug "Couldn't matchPatch"
                    Just m -> findAPatch m ps

-- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.
hasLastn :: [MatchFlag] -> Maybe Int
hasLastn [] = Nothing
hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."
hasLastn (LastN n:_) = Just n
hasLastn (_:fs) = hasLastn fs

hasIndexRange :: [MatchFlag] -> Maybe (Int,Int)
hasIndexRange [] = Nothing
hasIndexRange (PatchIndexRange x y:_) = Just (x,y)
hasIndexRange (_:fs) = hasIndexRange fs

-- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its
-- first matcher, ie the one that comes first dependencywise. Hence,
-- patches in @matchFirstPatchset fs ps@ are the context for the ones
-- we don't want.
matchFirstPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX
                   -> SealedPatchSet rt p wStart
matchFirstPatchset fs patchset =
    case hasLastn fs of
    Just n -> dropn n patchset
    Nothing ->
        case hasIndexRange fs of
        Just (_,b) -> dropn b patchset
        Nothing ->
               case firstMatcher fs of
               Nothing -> bug "Couldn't matchFirstPatchset"
               Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs
                                            then getMatchingTag m patchset
                                            else matchAPatchset m patchset

-- | @dropn n ps@ drops the @n@ last patches from @ps@.
dropn :: IsRepoType rt => Int -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
dropn n ps | n <= 0 = seal ps
dropn n (PatchSet (ts :<: Tagged t _ ps) NilRL) = dropn n $ PatchSet ts (ps:<:t)
dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL
dropn n (PatchSet ts (ps:<:p))
    | isIsEq (namedIsInternal (hopefully p))
   = dropn n $ PatchSet ts ps
dropn n (PatchSet ts (ps:<:_)) = dropn (n-1) $ PatchSet ts ps

-- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its
-- second matcher, ie the one that comes last dependencywise.
matchSecondPatchset :: (IsRepoType rt, Matchable p) => [MatchFlag] -> PatchSet rt p wStart wX
                    -> SealedPatchSet rt p wStart
matchSecondPatchset fs ps =
  case hasIndexRange fs of
  Just (a,_) -> dropn (a-1) ps
  Nothing ->
    case secondMatcher fs of
    Nothing -> bug "Couldn't matchSecondPatchset"
    Just m -> if secondMatcherIsTag fs
              then getMatchingTag m ps
              else matchAPatchset m ps

-- | Split on the second matcher. Note that this picks up the first match starting from
-- the earliest patch in a sequence, as opposed to 'matchSecondPatchset' which picks up the
-- first match starting from the latest patch
splitSecondFL :: Matchable p
              => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p))
              -> [MatchFlag]
              -> FL q wX wY
              -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher,
                                      --  the second element is the patches after it
splitSecondFL extract fs ps =
   case hasIndexRange fs of
   Just _ -> -- selecting the last n doesn't really make sense if we're starting from the earliest patches
             bug "index matches not supported by splitSecondPatchesFL"
   Nothing ->
     case secondMatcher fs of
     Nothing -> bug "Couldn't splitSecondPatches"
     Just m -> splitMatchFL extract m ps

-- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and
-- calls 'error' if there is none.
findAPatch :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> Sealed2 (WrappedNamed rt p)
findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m
findAPatch m (PatchSet (ts :<: Tagged t _ ps) NilRL) = findAPatch m (PatchSet ts (ps:<:t))
findAPatch m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal2 $ hopefully p
                                    | otherwise = findAPatch m (PatchSet ts ps)

-- | @matchAPatchset m ps@ returns a prefix of @ps@
-- ending in a patch matching @m@, and calls 'error' if there is none.
matchAPatchset :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX
               -> SealedPatchSet rt p wStart
matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m
matchAPatchset m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchAPatchset m (PatchSet ts (ps:<:t))
matchAPatchset m (PatchSet ts (ps:<:p)) | applyMatcher m p = seal (PatchSet ts (ps:<:p))
                                        | otherwise = matchAPatchset m (PatchSet ts ps)

-- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags
-- returns a 'SealedPatchSet' containing all patches in the last tag which
-- matches @m@. Last tag means the most recent tag in repository order,
-- i.e. the last one you'd see if you ran darcs log -t @m@. Calls
-- 'error' if there is no matching tag.
getMatchingTag :: Matchable p => Matcher rt p -> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m
getMatchingTag m (PatchSet (ts :<: Tagged t _ ps) NilRL) = getMatchingTag m (PatchSet ts (ps:<:t))
getMatchingTag m (PatchSet ts (ps:<:p))
    | applyMatcher m p =
        -- found a non-clean tag, need to commute out the things that it doesn't depend on
        case splitOnTag (info p) (PatchSet ts (ps:<:p)) of
            Nothing -> bug "splitOnTag couldn't find tag we explicitly provided!"
            Just (patchSet :> _) -> seal patchSet
    | otherwise = getMatchingTag m (PatchSet ts ps)

splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd rt p)) -> Matcher rt p -> FL q wX wY -> (FL q :> FL q) wX wY
splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m
splitMatchFL extract m (p :>: ps)
   | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps
   | otherwise = case splitMatchFL extract m ps of
                    before :> after -> (p :>: before) :> after

-- | @matchExists m ps@ tells whether there is a patch matching
-- @m@ in @ps@
matchExists :: Matcher rt p -> PatchSet rt p wStart wX -> Bool
matchExists _ (PatchSet NilRL NilRL) = False
matchExists m (PatchSet (ts :<: Tagged t _ ps) NilRL) = matchExists m (PatchSet ts (ps:<:t))
matchExists m (PatchSet ts (ps:<:p)) | applyMatcher m p = True
                                     | otherwise = matchExists m (PatchSet ts ps)

applyInvToMatcher :: (Matchable p, ApplyMonad (ApplyState p) m)
                  => InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m ()
applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible
applyInvToMatcher ioe m (PatchSet (ts :<: Tagged t _ ps) NilRL) = applyInvToMatcher ioe m
                                                                  (PatchSet ts (ps:<:t))
applyInvToMatcher ioe m (PatchSet xs (ps:<:p))
    | applyMatcher m p = when (ioe == Inclusive) (applyInvp p)
    | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet xs ps)

-- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.
applyNInv :: (Matchable p, ApplyMonad (ApplyState p) m) => Int -> PatchSet rt p Origin wX -> m ()
applyNInv n _ | n <= 0 = return ()
applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."
applyNInv n (PatchSet (ts :<: Tagged t _ ps) NilRL) =
  applyNInv n (PatchSet ts (ps :<: t))
applyNInv n (PatchSet xs (ps :<: p)) =
  applyInvp p >> applyNInv (n - 1) (PatchSet xs ps)


getMatcherS :: (ApplyMonad (ApplyState p) m, Matchable p) =>
                 InclusiveOrExclusive -> Matcher rt p -> PatchSet rt p Origin wX -> m ()
getMatcherS ioe m repo =
    if matchExists m repo
    then applyInvToMatcher ioe m repo
    else fail $ "Couldn't match pattern "++ show m

getTagS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p) =>
             Matcher rt p -> PatchSet rt p Origin wX -> m ()
getTagS matcher repo = do
    let pinfo = patch2patchinfo `unseal2` findAPatch matcher repo
    case getPatchesBeyondTag pinfo repo of
        FlippedSeal extras -> applyInvRL extras

-- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd
-- patch', and to apply its inverse. If we fail to fetch the patch
-- then we share our sorrow with the user.
applyInvp :: (Apply p, Invert p, ApplyMonad (ApplyState p) m) => PatchInfoAnd rt p wX wY -> m ()
applyInvp hp = apply (invert $ fromHopefully hp)
    where fromHopefully = conscientiously $ \e ->
                     text "Sorry, 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."

-- | a version of 'take' for 'RL' lists that cater for contexts.
safetake :: IsRepoType rt => Int -> RL (PatchInfoAnd rt p) wX wY -> FlippedSeal (RL (PatchInfoAnd rt p)) wY
safetake 0 _ = flipSeal NilRL
safetake _ NilRL = error "There aren't that many patches..."
safetake i (as:<:a) | isIsEq (namedIsInternal (hopefully a)) = safetake i as `snocRLSealed` a
safetake i (as:<:a) = safetake (i-1) as `snocRLSealed` a

applyInvRL :: (Apply p, Invert p, ApplyMonad (ApplyState p) m, MonadProgress m) => RL (PatchInfoAnd rt p) wX wR -> m ()
applyInvRL = applyPatches . invertRL -- this gives nicer feedback