#include "gadts.h"
module Darcs.Match ( matchFirstPatchset, matchSecondPatchset,
matchPatch,
matchAPatch, matchAPatchread,
getFirstMatch, getNonrangeMatch, getNonrangeMatchS,
getPartialFirstMatch, getPartialSecondMatch,
getPartialNonrangeMatch,
firstMatch, secondMatch, haveNonrangeMatch,
havePatchsetMatch, getOnePatchset,
checkMatchSyntax, applyInvToMatcher, nonrangeMatcher,
InclusiveOrExclusive(..), matchExists, applyNInv, hasIndexRange
) where
import Text.Regex ( mkRegex, matchRegex )
import Control.Monad ( when )
import Data.Maybe ( isJust )
import Data.List ( isPrefixOf )
import Darcs.MonadProgress ( MonadProgress )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, piap,
conscientiously, hopefully )
import Darcs.Patch.Info ( justName )
import Darcs.Patch ( RepoPatch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )
import Darcs.Patch.Dummy ( DummyPatch )
import Darcs.Repository ( Repository, readRepo, createPristineDirectoryTree )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )
import Darcs.Patch.Apply( ApplyState )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Repository.ApplyPatches ( applyPatches )
import Darcs.Patch.Depends ( getPatchesBeyondTag )
import Darcs.Witnesses.Ordered ( RL(..), consRLSealed )
import ByteStringUtils ( mmapFilePS )
import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,
AfterPatch, UpToPatch, LastN, PatchIndexRange,
OneTag, AfterTag, UpToTag,
OnePattern, SeveralPattern,
AfterPattern, UpToPattern ) )
import Darcs.Patch.Bundle ( scanContext )
import Darcs.Patch.Match ( Matcher, MatchFun, matchPattern, applyMatcher, makeMatcher, parseMatch )
import Darcs.Patch.MatchData ( PatchMatch )
import Printer ( text, ($$) )
import Darcs.RepoPath ( toFilePath )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )
import Darcs.Patch.FileName ( FileName )
import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..),
seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )
import Storage.Hashed.Tree ( Tree )
#include "impossible.h"
data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq
haveNonrangeMatch :: [DarcsFlag] -> Bool
haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch))
havePatchsetMatch :: [DarcsFlag] -> Bool
havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs
where hasC [] = False
hasC (Context _:_) = True
hasC (_:xs) = hasC xs
getNonrangeMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> [DarcsFlag] -> IO ()
getNonrangeMatch r fs = withRecordedMatch r (getNonrangeMatchS fs)
getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)
=> Repository p C(r u t)
-> [DarcsFlag] -> [FileName] -> IO ()
getPartialNonrangeMatch r fs _ =
withRecordedMatch r (getNonrangeMatchS fs)
getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> 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 :: [DarcsFlag] -> Bool
firstMatch fs = isJust (hasLastn fs)
|| isJust (firstMatcher fs::Maybe (Matcher DummyPatch))
|| isJust (hasIndexRange fs)
getFirstMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> [DarcsFlag] -> IO ()
getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs)
getPartialFirstMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)
=> Repository p C(r u t)
-> [DarcsFlag] -> Maybe [FileName] -> IO ()
getPartialFirstMatch r fs _ =
withRecordedMatch r (getFirstMatchS fs)
getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>
[DarcsFlag] -> PatchSet p C(Origin x) -> m ()
getFirstMatchS fs repo =
case hasLastn fs of
Just n -> unpullLastN repo n
Nothing ->
case hasIndexRange fs of
Just (_,b) -> unpullLastN repo b
Nothing ->
case firstMatcher fs of
Nothing -> fail "Pattern not specified in getFirstMatch."
Just m -> if firstMatcherIsTag fs
then getTagS m repo
else getMatcherS Inclusive m repo
secondMatch :: [DarcsFlag] -> Bool
secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs)
getPartialSecondMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)
=> Repository p C(r u t)
-> [DarcsFlag] -> Maybe [FileName] -> IO ()
getPartialSecondMatch r fs _ =
withRecordedMatch r $ \repo ->
case secondMatcher fs of
Nothing -> case hasIndexRange fs of
Just (a,_) -> unpullLastN repo (a1)
Nothing -> fail "Two patterns not specified in get_second_match."
Just m -> if secondMatcherIsTag fs
then getTagS m repo
else getMatcherS Exclusive m repo
unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => PatchSet p C(x y) -> Int -> m ()
unpullLastN repo n = applyInvRL `unsealFlipped` (safetake n $ newset2RL repo)
checkMatchSyntax :: [DarcsFlag] -> IO ()
checkMatchSyntax opts =
case getMatchPattern opts of
Nothing -> return ()
Just p -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun DummyPatch))
getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch
getMatchPattern [] = Nothing
getMatchPattern (OnePattern m:_) = Just m
getMatchPattern (SeveralPattern m:_) = Just m
getMatchPattern (_:fs) = getMatchPattern fs
tagmatch :: String -> Matcher 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)
mymatch :: String -> Matcher p
mymatch r = makeMatcher ("patch-name "++r) mm
where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . justName . info $ p
strictJust :: a -> Maybe a
strictJust x = Just $! x
nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
nonrangeMatcher [] = Nothing
nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m
nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t
nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p
nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m
nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p
nonrangeMatcher (_:fs) = nonrangeMatcher fs
nonrangeMatcherIsTag :: [DarcsFlag] -> Bool
nonrangeMatcherIsTag [] = False
nonrangeMatcherIsTag (OneTag _:_) = True
nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs
firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher 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 $ mymatch p
firstMatcher (AfterPatch p:_) = strictJust $ mymatch p
firstMatcher (_:fs) = firstMatcher fs
firstMatcherIsTag :: [DarcsFlag] -> Bool
firstMatcherIsTag [] = False
firstMatcherIsTag (AfterTag _:_) = True
firstMatcherIsTag (_:fs) = firstMatcherIsTag fs
secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
secondMatcher [] = Nothing
secondMatcher (OnePattern m:_) = strictJust $ matchPattern m
secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m
secondMatcher (OnePatch p:_) = strictJust $ mymatch p
secondMatcher (UpToPatch p:_) = strictJust $ mymatch p
secondMatcher (UpToTag t:_) = strictJust $ tagmatch t
secondMatcher (_:fs) = secondMatcher fs
secondMatcherIsTag :: [DarcsFlag] -> Bool
secondMatcherIsTag [] = False
secondMatcherIsTag (UpToTag _:_) = True
secondMatcherIsTag (_:fs) = secondMatcherIsTag fs
matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool
matchAPatchread fs = case nonrangeMatcher fs of
Nothing -> const True
Just m -> applyMatcher m
matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool
matchAPatch fs p =
case nonrangeMatcher fs of
Nothing -> True
Just m -> applyMatcher m (patch2patchinfo p `piap` p)
matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> Sealed2 (Named p)
matchPatch fs ps =
case hasIndexRange fs of
Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a1) 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 p C(start x) -> Maybe (Sealed2 (PatchInfoAnd p))
myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = 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
getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> [DarcsFlag] ->
IO (SealedPatchSet p C(Origin))
getOnePatchset repository fs =
case nonrangeMatcher fs of
Just m -> do ps <- readRepo repository
if nonrangeMatcherIsTag fs
then return $ getMatchingTag m ps
else return $ matchAPatchset m ps
Nothing -> (seal . scanContext) `fmap` mmapFilePS (toFilePath $ context_f fs)
where context_f [] = bug "Couldn't match_nonrange_patchset"
context_f (Context f:_) = f
context_f (_:xs) = context_f xs
hasLastn :: [DarcsFlag] -> Maybe Int
hasLastn [] = Nothing
hasLastn (LastN (1):_) = error "--last requires a positive integer argument."
hasLastn (LastN n:_) = Just n
hasLastn (_:fs) = hasLastn fs
hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int)
hasIndexRange [] = Nothing
hasIndexRange (PatchIndexRange x y:_) = Just (x,y)
hasIndexRange (_:fs) = hasIndexRange fs
matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)
-> SealedPatchSet p C(start)
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 :: Int -> PatchSet p C(start x) -> SealedPatchSet p C(start)
dropn n ps | n <= 0 = seal ps
dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts
dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL
dropn n (PatchSet (_:<:ps) ts) = dropn (n1) $ PatchSet ps ts
matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)
-> SealedPatchSet p C(start)
matchSecondPatchset fs ps =
case hasIndexRange fs of
Just (a,_) -> dropn (a1) ps
Nothing ->
case secondMatcher fs of
Nothing -> bug "Couldn't matchSecondPatchset"
Just m -> if secondMatcherIsTag fs
then getMatchingTag m ps
else matchAPatchset m ps
findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> Sealed2 (Named p)
findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m
findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts)
findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p
| otherwise = findAPatch m (PatchSet ps ts)
matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(start x)
-> SealedPatchSet p C(start)
matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m
matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts)
matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts)
| otherwise = matchAPatchset m (PatchSet ps ts)
getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> SealedPatchSet p C(start)
getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m
getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts)
getMatchingTag m (PatchSet (p:<:ps) ts)
| applyMatcher m p = seal $ PatchSet (p:<:ps) ts
| otherwise = getMatchingTag m (PatchSet ps ts)
matchExists :: Matcher p -> PatchSet p C(start x) -> Bool
matchExists _ (PatchSet NilRL NilRL) = False
matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts)
matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m $ p = True
| otherwise = matchExists m (PatchSet ps ts)
applyInvToMatcher :: (RepoPatch p, ApplyMonad m (ApplyState p))
=> InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()
applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible
applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m
(PatchSet (t:<:ps) ts)
applyInvToMatcher ioe m (PatchSet (p:<:ps) xs)
| applyMatcher m p = when (ioe == Inclusive) (applyInvp p)
| otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs)
applyNInv :: (RepoPatch p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p C(Origin x) -> m ()
applyNInv n _ | n <= 0 = return ()
applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."
applyNInv n (PatchSet NilRL (Tagged t _ ps :<: ts)) =
applyNInv n (PatchSet (t :<: ps) ts)
applyNInv n (PatchSet (p :<: ps) xs) =
applyInvp p >> applyNInv (n 1) (PatchSet ps xs)
getMatcherS :: (ApplyMonad m (ApplyState p), RepoPatch p) =>
InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()
getMatcherS ioe m repo =
if matchExists m repo
then applyInvToMatcher ioe m repo
else fail $ "Couldn't match pattern "++ show m
getTagS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>
Matcher p -> PatchSet p C(Origin x) -> m ()
getTagS match repo = do
let pinfo = patch2patchinfo `unseal2` (findAPatch match repo)
case getPatchesBeyondTag pinfo repo of
FlippedSeal extras -> applyInvRL extras
applyInvp :: (Patchy p, ApplyMonad m (ApplyState p)) => PatchInfoAnd p C(x y) -> m ()
applyInvp 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."
safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)
safetake 0 _ = flipSeal NilRL
safetake _ NilRL = error "There aren't that many patches..."
safetake i (a:<:as) = a `consRLSealed` safetake (i1) as
withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)
-> (PatchSet p C(Origin r) -> IO ()) -> IO ()
withRecordedMatch r job = do createPristineDirectoryTree r "."
readRepo r >>= job
applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) C(x r) -> m ()
applyInvRL = applyPatches . invertRL