diff --git a/ipatch.cabal b/ipatch.cabal --- a/ipatch.cabal +++ b/ipatch.cabal @@ -1,5 +1,5 @@ Name: ipatch -Version: 0.1 +Version: 0.1.1 Synopsis: interactive patch editor Description: ipatch brings the power and convenience of selecting and editing patches in @@ -18,13 +18,20 @@ Build-type: Simple Cabal-version: >=1.8 +Flag darcs-beta + Description: Use a beta release of darcs + Default: False Executable ipatch Hs-Source-Dirs: src/ Main-is: ipatch.hs - Build-depends: darcs-beta (>= 2.4.98.3) - , base >=3 && <5 - , unix, bytestring, filepath, directory + Build-depends: base >=3 && <5 + , unix, bytestring, filepath, directory, process, + hashed-storage + if flag(darcs-beta) + Build-depends: darcs-beta (>= 2.4.98.5) + else + Build-depends: darcs (>= 2.4.98.5) Other-modules: IPatch.Apply IPatch.DiffFile IPatch.Split @@ -32,3 +39,7 @@ IPatch.Common IPatch.Help IPatch.TheCommands + +source-repository head + type: darcs + location: http://darcs.nomeata.de/ipatch/ diff --git a/src/IPatch/Apply.hs b/src/IPatch/Apply.hs --- a/src/IPatch/Apply.hs +++ b/src/IPatch/Apply.hs @@ -16,21 +16,17 @@ - the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. -} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} module IPatch.Apply where import Control.Monad ( when ) import System.Exit ( exitWith, ExitCode(ExitSuccess) ) +import Data.Functor -import Darcs.Commands - ( DarcsCommand(DarcsCommand, commandAdvancedOptions, - commandArgdefaults, commandBasicOptions, commandCommand, - commandDescription, commandExtraArgHelp, commandExtraArgs, - commandGetArgPossibilities, commandHelp, commandName, - commandPrereq) ) -import Darcs.Arguments ( DarcsFlag, fixFilePathOrStd, listFiles ) +import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.Arguments ( DarcsFlag(..), fixFilePathOrStd, listFiles ) import Darcs.Repository - ( amNotInRepository, applyToWorking, withRepoLock ) + ( amNotInRepository, applyToWorking, withRepoLock, RepoJob(..), Repository ) import Darcs.RepoPath ( FilePathLike(..) ) import Darcs.Patch ( Effect(effect) ) import Workaround ( getCurrentDirectory ) @@ -42,7 +38,8 @@ selectChanges, selectionContextPrim ) import Darcs.Patch.Split ( primSplitter ) -import Darcs.Witnesses.Ordered ( (:>)(..), nullFL ) +import Darcs.Witnesses.Ordered ( (:>)(..), nullFL, FL ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(..), unsafeUnseal, unseal) import IPatch.Common ( diffToPrims, @@ -65,7 +62,8 @@ applyDescription = "Apply a diff file interactively." apply :: DarcsCommand -apply = DarcsCommand {commandName = "apply", +apply = DarcsCommand {commandProgramName = "ipatch", + commandName = "apply", commandHelp = applyHelp, commandDescription = applyDescription, commandExtraArgs = 1, @@ -86,13 +84,14 @@ files <- filesTouchedByDiff diffPS if null files then putStrLn "Patch seems to be empty" - else withTempRepository "work" $ \rdir -> do - initializeBaseState rdir maindir files + else withTempRepository "work" $ \rdir -> withRepoLock [LookForAdds] $ RepoJob $ \(repo :: Repository p r u t) -> do - patch_ps <- diffToPrims diffPS + (_, repo) <- initializeBaseState rdir maindir files repo + Sealed patch_ps <- diffToPrims diffPS repo + -- Ask the user which parts of the patch to apply - let context = selectionContextPrim "apply" [] (Just primSplitter) [] + let context = selectionContextPrim "apply" [] (Just primSplitter) Nothing Nothing let selector = selectChanges First patch_ps (wanted_ps :> _) <- runSelection selector context @@ -100,19 +99,13 @@ putStrLn "You selected nothing, so I'm exiting!" exitWith ExitSuccess debugMessage $ "Applying selected patches" - withRepoLock [] $ \repo -> do - {- wanted_patch <- namepatch "NODATE" "Chosen Patch" "NOAUTHOR" [] (fromPrims wanted_ps) - tentativelyAddPatch repo [] $ n2pia wanted_patch - invalidateIndex repo - withGutsOf repo (finalizeRepositoryChanges repo) - `clarifyErrors` "Failed to apply inital patch" - -} - applyToWorking repo opts (effect wanted_ps) `catch` \e -> - fail ("Error applying patch to working dir:\n" ++ show e) - - yorn <- promptYorn "Really apply the selected changes?" - when (yorn == 'y') $ do - clonePathsWithDeletion (toFilePath rdir) maindir files + + applyToWorking repo opts wanted_ps `catch` \e -> + fail ("Error applying patch to working dir:\n" ++ show e) + + yorn <- promptYorn "Really apply the selected changes?" + when yorn $ do + clonePathsWithDeletion (toFilePath rdir) maindir files {- debugMessage $ "Printing selected parts" diff --git a/src/IPatch/Common.hs b/src/IPatch/Common.hs --- a/src/IPatch/Common.hs +++ b/src/IPatch/Common.hs @@ -16,18 +16,21 @@ - the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. -} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, ScopedTypeVariables, TypeFamilies, GADTs #-} module IPatch.Common where import Control.Applicative ( (<$>) ) -import Control.Monad (when) +import Control.Monad ( when, unless ) import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory ) import System.Directory ( createDirectoryIfMissing, doesFileExist, removeFile ) import System.FilePath.Posix ( (), takeDirectory, normalise ) +import System.Exit ( exitWith, ExitCode(..) ) import Darcs.Arguments ( DarcsFlag(LookForAdds) ) import Darcs.Repository - ( createRepository, + ( RepoJob(..), + Repository, + createRepository, applyToWorking, finalizeRepositoryChanges, tentativelyAddPatch, @@ -35,16 +38,21 @@ withRepoLock, invalidateIndex, unrecordedChanges ) -import Darcs.Flags ( Compression(..) ) +import Darcs.Flags ( Compression(..), UseIndex(..), ScanKnown(..) ) import Darcs.RepoPath ( AbsolutePath, FilePathLike(..) ) import Darcs.External ( cloneFile ) import Darcs.Lock ( withTempDir ) -import Darcs.Patch ( invert, fromPrims, namepatch ) +import Darcs.Patch ( invert, fromPrims, namepatch, PrimOf, RepoPatch ) import Darcs.Global ( debugMessage ) -import Darcs.Hopefully ( n2pia ) -import Darcs.Utils ( clarifyErrors ) +import Darcs.Patch.PatchInfoAnd ( n2pia ) +import Darcs.Utils ( clarifyErrors, promptYorn ) +import Darcs.Witnesses.Ordered ( nullFL, FL(..) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(..) ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(..), unsafeUnseal2 ) +import Darcs.Patch.Apply ( ApplyState ) +import Storage.Hashed.Tree ( Tree ) -import IPatch.DiffFile ( applyDiff ) +import IPatch.DiffFile ( applyDiff, DiffFile ) clonePathWithDeletion :: FilePath -> FilePath -> FilePath -> IO () clonePathWithDeletion source dest path = do @@ -79,36 +87,67 @@ createRepository [] job rdir -initializeBaseState rdir sdir files = do - debugMessage $ "Copying " ++ show (length files) ++ " files to temporary repository." - clonePathsWithDeletion sdir (toFilePath rdir) files - -- Create a patch from the newly added files - debugMessage $ "Creating initial check in patch" - withRepoLock [LookForAdds] $ \repo -> do - init_ps <- unrecordedChanges [LookForAdds] repo [] -- Correct flags? +initializeBaseState + :: (FilePathLike a, RepoPatch p, ApplyState p ~ Tree) => + a -> FilePath -> [FilePath] -> Repository p r u r -> + IO (FL (PrimOf p) r r', Repository p r r' r') +initializeBaseState rdir sdir files repo = do + + -- There should be no local changes: + pend <- unrecordedChanges (IgnoreIndex, ScanAll) repo Nothing + (repo :: Repository p r r r) <- case pend of + NilFL -> return repo + _ -> fail $ "Repo passed to initializeBaseState has unrecord changes" + + debugMessage $ "Copying " ++ show (length files) ++ " files to temporary repository." + clonePathsWithDeletion sdir (toFilePath rdir) files + + -- Change the phantom type here. + (repo :: Repository p r r' r) <- return $ unsafeUnseal2 (Sealed2 repo) + + -- Create a patch from the newly added files + debugMessage $ "Creating initial check in patch" + init_ps <- unrecordedChanges (IgnoreIndex, ScanAll) repo Nothing -- Correct flags? init_patch <- n2pia <$> namepatch "NODATE" "Initial state" "NOAUTHOR" [] (fromPrims init_ps) - tentativelyAddPatch repo [] init_patch + repo <- tentativelyAddPatch repo NoCompression init_patch invalidateIndex repo withGutsOf repo (finalizeRepositoryChanges repo) `clarifyErrors` "Failed to apply inital patch" - return init_ps + return (init_ps, repo) -diffToPrims diff = do +diffToPrims + :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => + DiffFile -> Repository p r t t -> IO (Sealed (FL (PrimOf p) t)) +diffToPrims diff repo = do + debugMessage $ "Applying the user provided diff" -- Now apply the patch - applyDiff diff + ok <- applyDiff diff + -- Change the phantom type here. + (repo :: Repository p r u' t) <- return $ unsafeUnseal2 (Sealed2 repo) + debugMessage $ "Creating a patch from the user changes" - withRepoLock [LookForAdds] $ \repo -> do - -- Create another patch from the changed files - patch_ps <- unrecordedChanges [LookForAdds] repo [] - -- patch_patch <- n2pia <$> namepatch date "Patch effect" author [] (fromPrims patch_ps) - -- tentativelyAddPatch repo [] patch_patch - -- Now we obliterate the patch, undoing its effects - applyToWorking repo [] (invert patch_ps) `catch` \e -> - fail ("Couldn't undo diff effect in working dir.\n" ++ show e) - return patch_ps + -- Create another patch from the changed files + patch_ps <- unrecordedChanges (IgnoreIndex, ScanAll) repo Nothing + + unless ok $ + if nullFL patch_ps + then do + putStrLn $ "The patch did not apply cleanly. Aborting." + exitWith (ExitFailure 1) + else do + putStrLn $ "The patch did fully apply cleanly. " + yorn <- promptYorn "Do you want to continue with the partially applied patch?" + unless yorn $ do + exitWith $ ExitFailure 1 + + -- Now we obliterate the patch, undoing its effects + applyToWorking repo [] (invert patch_ps) `catch` \e -> + fail ("Couldn't undo diff effect in working dir.\n" ++ show e) + + return (Sealed patch_ps) stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] diff --git a/src/IPatch/DiffFile.hs b/src/IPatch/DiffFile.hs --- a/src/IPatch/DiffFile.hs +++ b/src/IPatch/DiffFile.hs @@ -21,22 +21,40 @@ import qualified Data.ByteString as B - ( ByteString, null, hGetContents, readFile ) + ( ByteString, null, hGetContents, readFile, hPutStr ) import qualified Data.ByteString.Char8 as BC ( unpack ) -import System.IO ( stdin ) +import System.IO ( stdin, openBinaryFile, IOMode(..), hClose ) +import System.Process ( createProcess, proc, CreateProcess(..), StdStream(..), waitForProcess ) +import System.Exit ( ExitCode(..) ) import Control.Applicative ( (<$>) ) -import Darcs.RepoPath ( FilePathLike(..), useAbsoluteOrStd ) +import Darcs.RepoPath ( FilePathLike(..), AbsolutePathOrStd, useAbsoluteOrStd ) import Darcs.External ( execDocPipe ) import Printer ( packedString, renderPS ) import ByteStringUtils ( linesPS ) newtype DiffFile = DiffFile B.ByteString +readDiffFile :: AbsolutePathOrStd -> IO DiffFile readDiffFile = fmap DiffFile . useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) +filesTouchedByDiff :: DiffFile -> IO [FilePath] filesTouchedByDiff (DiffFile bs) = map BC.unpack . filter (not . B.null) . linesPS <$> execPSPipe "diffstat" ["-l","-p1"] bs -applyDiff (DiffFile bs) = execPSPipe "patch" ["-r","-","-p1"] bs +applyDiff :: DiffFile -> IO Bool +applyDiff (DiffFile bs) = do + devNull <- openBinaryFile "/dev/null" WriteMode + (Just i,_,_,pid) <- createProcess (proc "patch" ["--reject-file","-","--strip","1"]) + { std_out = UseHandle devNull + , std_err = Inherit + , std_in = CreatePipe } + B.hPutStr i bs + hClose i + rval <- waitForProcess pid + case rval of + ExitSuccess -> return True + ExitFailure 1 -> return False + ExitFailure 127 -> fail $ "patch not found" + _ -> fail $ "patch failed" execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString diff --git a/src/IPatch/Help.lhs b/src/IPatch/Help.lhs --- a/src/IPatch/Help.lhs +++ b/src/IPatch/Help.lhs @@ -48,8 +48,6 @@ import Data.List ( groupBy ) import English ( andClauses ) import Printer ( text ) -import Ssh - ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import System.Exit ( ExitCode(..), exitWith ) import URL ( environmentHelpProxy, environmentHelpProxyPassword ) import Workaround ( getCurrentDirectory ) @@ -67,7 +65,8 @@ "`ipatch help foo' prints detailed help about the ipatch command foo.\n" help :: DarcsCommand -help = DarcsCommand {commandName = "help", +help = DarcsCommand {commandProgramName = "ipatch", + commandName = "help", commandHelp = helpHelp, commandDescription = helpDescription, commandExtraArgs = -1, diff --git a/src/IPatch/Split.hs b/src/IPatch/Split.hs --- a/src/IPatch/Split.hs +++ b/src/IPatch/Split.hs @@ -16,7 +16,7 @@ - the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. -} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} module IPatch.Split where import qualified Data.ByteString as B ( writeFile ) @@ -27,17 +27,12 @@ import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import System.FilePath ( () ) -import Darcs.Commands - ( DarcsCommand(DarcsCommand, commandAdvancedOptions, - commandArgdefaults, commandBasicOptions, commandCommand, - commandDescription, commandExtraArgHelp, commandExtraArgs, - commandGetArgPossibilities, commandHelp, commandName, - commandPrereq) ) -import Darcs.Arguments ( DarcsFlag, fixFilePathOrStd, listFiles ) -import Darcs.Repository ( amNotInRepository ) +import Darcs.Commands ( DarcsCommand(..) ) +import Darcs.Arguments ( DarcsFlag(..), fixFilePathOrStd, listFiles ) +import Darcs.Repository ( amNotInRepository, withRepoLock, RepoJob(..), Repository ) import Darcs.External ( execPipeIgnoreError ) import Darcs.Lock ( withTempDir ) -import Darcs.Patch ( Prim, apply ) +import Darcs.Patch ( apply, PrimOf ) import Printer ( empty, renderPS ) import Workaround ( getCurrentDirectory ) import Darcs.Global ( debugMessage ) @@ -50,6 +45,7 @@ selectionContextPrim ) import Darcs.Patch.Split ( primSplitter ) import Darcs.Witnesses.Ordered ( FL, (:>)(..), nullFL ) +import Darcs.Witnesses.Sealed ( Sealed(Sealed), Sealed2(..) ) import IPatch.Common ( withTempRepository, @@ -73,7 +69,8 @@ splitDescription = "Split a diff file interactively." split :: DarcsCommand -split = DarcsCommand {commandName = "split", +split = DarcsCommand {commandProgramName = "ipatch", + commandName = "split", commandHelp = splitHelp, commandDescription = splitDescription, commandExtraArgs = 1, @@ -94,36 +91,33 @@ files <- filesTouchedByDiff diffPS if null files then putStrLn "Patch seems to be empty" - else withTempRepository "work" $ \rdir -> do - init_ps <- initializeBaseState rdir maindir files - patch_ps <- diffToPrims diffPS + else withTempRepository "work" $ \rdir -> withRepoLock [LookForAdds] $ RepoJob $ \(repo :: Repository p r u r) -> do - let run :: (FL Prim -> Int -> IO [(FL Prim,String)]) -> - (FL Prim -> Int -> IO [(FL Prim,String)]) - run repeat remaining_ps n = if nullFL remaining_ps then return [] else do + (init_ps, repo) <- initializeBaseState rdir maindir files repo + Sealed patch_ps <- diffToPrims diffPS repo + + when (nullFL patch_ps) $ do + putStrLn "Patch seems to be empty" + exitWith ExitSuccess + + let run :: (Sealed2 (FL (PrimOf p)) -> Int -> IO [(Sealed2 (FL (PrimOf p)),String)]) -> + (Sealed2 (FL (PrimOf p)) -> Int -> IO [(Sealed2 (FL (PrimOf p)),String)]) + run repeat (Sealed2 remaining_ps) n = if nullFL remaining_ps then return [] else do putStrLn $ "Please select the changes for the " ++ ordinal n ++ " patch" - --putStrLn $ "To choose " ++ show remaining_ps - let context = selectionContextPrim "split" [] (Just primSplitter) [] + let context = selectionContextPrim "split" [] (Just primSplitter) Nothing Nothing let selector = selectChanges First remaining_ps (chosen_ps :> remaining_ps') <- runSelection selector context - {- we need to force chosen_ps before accessing remaining_ps', - - see pull_only_firsts in ./Darcs/Patch/Choices.hs. There is a reason - - why unsafeReadIO is called unsafe...-} - --length (show chosen_ps) `seq` return () - --length (show remaining_ps') `seq` return () if (nullFL chosen_ps) then do yorn <- promptYorn "You selected nothing. Do you want to abort?" - when (yorn == 'y') $ do + when yorn $ do exitWith ExitSuccess - repeat remaining_ps n + repeat (Sealed2 remaining_ps) n else do filename <- askUser $ "Please enter filename for the " ++ ordinal n ++ " patch: " - --putStrLn $ "Chosen " ++ show chosen_ps - --putStrLn $ "Left " ++ show remaining_ps' - ((chosen_ps,filename) :) <$> repeat remaining_ps' (succ n) + ((Sealed2 chosen_ps,filename) :) <$> repeat (Sealed2 remaining_ps') (succ n) - chunks <- fix run patch_ps 1 + chunks <- fix run (Sealed2 patch_ps) 1 when (null chunks) $ do putStrLn "No patched splitted, exiting." @@ -134,14 +128,14 @@ createDirectory "old" -- Find nicer names based on original directory name createDirectory "new" - withCurrentDirectory "new" $ apply [] init_ps - let applyAndDiff last next name = do - withCurrentDirectory "old" $ apply [] last - withCurrentDirectory "new" $ apply [] next + withCurrentDirectory "new" $ apply init_ps + let applyAndDiff (Sealed2 last) (Sealed2 next) name = do + withCurrentDirectory "old" $ apply last + withCurrentDirectory "new" $ apply next output <- renderPS <$> execPipeIgnoreError "diff" ["-Nur","old","new"] empty putStrLn $ "Writing File " ++ name ++ " .." B.writeFile (maindir name) output - sequence_ $ zipWith3 applyAndDiff (init_ps : map fst chunks) (map fst chunks) (map snd chunks) + sequence_ $ zipWith3 applyAndDiff (Sealed2 init_ps : map fst chunks) (map fst chunks) (map snd chunks) ordinal 1 = "first"