module Darcs.Repository.Match
(
getNonrangeMatch
, getOnePatchset
) where
import Prelude ()
import Darcs.Prelude
import Control.Exception ( throw )
import Darcs.Patch.Match
( getNonrangeMatchS
, nonrangeMatcherIsTag
, getMatchingTag
, matchAPatchset
, nonrangeMatcher
, applyNInv
, hasIndexRange
, MatchFlag(..)
)
import Darcs.Patch.Bundle ( scanContextFile )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch ( RepoPatch, IsRepoType )
import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, Origin )
import Darcs.Patch.Witnesses.Sealed ( seal )
import Darcs.Repository.Flags
( WithWorkingDir (WithWorkingDir) )
import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )
import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Repository.Hashed
( readRepo, createPristineDirectoryTree )
import Darcs.Util.Tree ( Tree )
import Darcs.Util.Path ( toFilePath )
getNonrangeMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> [MatchFlag]
-> IO ()
getNonrangeMatch :: Repository rt p wR wU wT -> [MatchFlag] -> IO ()
getNonrangeMatch r :: Repository rt p wR wU wT
r = Repository rt p wR wU wT
-> (PatchSet rt p Origin wR -> DefaultIO ()) -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT
-> (PatchSet rt p Origin wR -> DefaultIO ()) -> IO ()
withRecordedMatch Repository rt p wR wU wT
r ((PatchSet rt p Origin wR -> DefaultIO ()) -> IO ())
-> ([MatchFlag] -> PatchSet rt p Origin wR -> DefaultIO ())
-> [MatchFlag]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MatchFlag] -> PatchSet rt p Origin wR -> DefaultIO ()
forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wX.
(Matchable p, ApplyMonad (ApplyState p) m, MonadProgress m,
IsRepoType rt, ApplyState p ~ Tree) =>
[MatchFlag] -> PatchSet rt p Origin wX -> m ()
getMatch where
getMatch :: [MatchFlag] -> PatchSet rt p Origin wX -> m ()
getMatch fs :: [MatchFlag]
fs = case [MatchFlag] -> Maybe (Int, Int)
hasIndexRange [MatchFlag]
fs of
Just (n :: Int
n, m :: Int
m) | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m -> Int -> PatchSet rt p Origin wX -> m ()
forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wX.
(Matchable p, ApplyMonad (ApplyState p) m) =>
Int -> PatchSet rt p Origin wX -> m ()
applyNInv (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
| Bool
otherwise -> IOError -> PatchSet rt p Origin wX -> m ()
forall a e. Exception e => e -> a
throw (IOError -> PatchSet rt p Origin wX -> m ())
-> IOError -> PatchSet rt p Origin wX -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError "Index range is not allowed for this command."
_ -> [MatchFlag] -> PatchSet rt p Origin wX -> m ()
forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wX.
(ApplyMonad (ApplyState p) m, MonadProgress m, IsRepoType rt,
Matchable p, ApplyState p ~ Tree) =>
[MatchFlag] -> PatchSet rt p Origin wX -> m ()
getNonrangeMatchS [MatchFlag]
fs
getOnePatchset :: (IsRepoType rt, RepoPatch p)
=> Repository rt p wR wU wT
-> [MatchFlag]
-> IO (SealedPatchSet rt p Origin)
getOnePatchset :: Repository rt p wR wU wT
-> [MatchFlag] -> IO (SealedPatchSet rt p Origin)
getOnePatchset repository :: Repository rt p wR wU wT
repository fs :: [MatchFlag]
fs =
case [MatchFlag] -> Maybe (Matcher rt p)
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, Matchable p) =>
[MatchFlag] -> Maybe (Matcher rt p)
nonrangeMatcher [MatchFlag]
fs of
Just m :: Matcher rt p
m -> do PatchSet rt p Origin wR
ps <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
if [MatchFlag] -> Bool
nonrangeMatcherIsTag [MatchFlag]
fs
then SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return (SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin))
-> SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin)
forall a b. (a -> b) -> a -> b
$ Matcher rt p
-> PatchSet rt p Origin wR -> SealedPatchSet rt p Origin
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX.
Matchable p =>
Matcher rt p
-> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
getMatchingTag Matcher rt p
m PatchSet rt p Origin wR
ps
else SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return (SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin))
-> SealedPatchSet rt p Origin -> IO (SealedPatchSet rt p Origin)
forall a b. (a -> b) -> a -> b
$ Matcher rt p
-> PatchSet rt p Origin wR -> SealedPatchSet rt p Origin
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX.
Matchable p =>
Matcher rt p
-> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
matchAPatchset Matcher rt p
m PatchSet rt p Origin wR
ps
Nothing -> PatchSet rt p Origin Any -> SealedPatchSet rt p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
seal (PatchSet rt p Origin Any -> SealedPatchSet rt p Origin)
-> IO (PatchSet rt p Origin Any) -> IO (SealedPatchSet rt p Origin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> IO (PatchSet rt p Origin Any)
forall (rt :: RepoType) (p :: * -> * -> *) wX.
String -> IO (PatchSet rt p Origin wX)
scanContextFile (String -> IO (PatchSet rt p Origin Any))
-> ([MatchFlag] -> String)
-> [MatchFlag]
-> IO (PatchSet rt p Origin Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath (AbsolutePath -> String)
-> ([MatchFlag] -> AbsolutePath) -> [MatchFlag] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MatchFlag] -> AbsolutePath
context_f ([MatchFlag] -> IO (PatchSet rt p Origin Any))
-> [MatchFlag] -> IO (PatchSet rt p Origin Any)
forall a b. (a -> b) -> a -> b
$ [MatchFlag]
fs)
where context_f :: [MatchFlag] -> AbsolutePath
context_f [] = String -> AbsolutePath
forall a. String -> a
bug "Couldn't match_nonrange_patchset"
context_f (Context f :: AbsolutePath
f:_) = AbsolutePath
f
context_f (_:xs :: [MatchFlag]
xs) = [MatchFlag] -> AbsolutePath
context_f [MatchFlag]
xs
withRecordedMatch :: (IsRepoType rt, RepoPatch p)
=> Repository rt p wR wU wT
-> (PatchSet rt p Origin wR -> DefaultIO ())
-> IO ()
withRecordedMatch :: Repository rt p wR wU wT
-> (PatchSet rt p Origin wR -> DefaultIO ()) -> IO ()
withRecordedMatch r :: Repository rt p wR wU wT
r job :: PatchSet rt p Origin wR -> DefaultIO ()
job
= do Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository rt p wR wU wT
r "." WithWorkingDir
WithWorkingDir
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
r IO (PatchSet rt p Origin wR)
-> (PatchSet rt p Origin wR -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (DefaultIO () -> IO ())
-> (PatchSet rt p Origin wR -> DefaultIO ())
-> PatchSet rt p Origin wR
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet rt p Origin wR -> DefaultIO ()
job