ipatch 0.1 → 0.1.1
raw patch · 6 files changed
+156/−102 lines, 6 filesdep +darcsdep +hashed-storagedep +processdep ~darcs-beta
Dependencies added: darcs, hashed-storage, process
Dependency ranges changed: darcs-beta
Files
- ipatch.cabal +15/−4
- src/IPatch/Apply.hs +21/−28
- src/IPatch/Common.hs +67/−28
- src/IPatch/DiffFile.hs +22/−4
- src/IPatch/Help.lhs +2/−3
- src/IPatch/Split.hs +29/−35
ipatch.cabal view
@@ -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/
src/IPatch/Apply.hs view
@@ -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"
src/IPatch/Common.hs view
@@ -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 ["-"]
src/IPatch/DiffFile.hs view
@@ -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
src/IPatch/Help.lhs view
@@ -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,
src/IPatch/Split.hs view
@@ -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"