Initial check-in
authorJoachim Breitner <mail@joachim-breitner.de>
Tue, 3 Aug 2010 20:05:01 +0000 (20:05 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Tue, 3 Aug 2010 20:05:01 +0000 (20:05 +0000)
Apply.hs [new file with mode: 0644]
Common.hs [new file with mode: 0644]
DiffFile.hs [new file with mode: 0644]
Help.lhs [new file with mode: 0644]
Split.hs [new file with mode: 0644]
TheCommands.hs [new file with mode: 0644]
Version.hs [new file with mode: 0644]
ipatch.hs [new file with mode: 0644]

diff --git a/Apply.hs b/Apply.hs
new file mode 100644 (file)
index 0000000..c95377a
--- /dev/null
+++ b/Apply.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE Rank2Types #-}
+module Apply where
+
+import Control.Monad ( when )
+import System.Exit ( exitWith, ExitCode(ExitSuccess) )
+
+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, applyToWorking, withRepoLock )
+import Darcs.RepoPath ( FilePathLike(..) )
+import Darcs.External ( clonePaths )
+import Darcs.Patch ( Effect(effect) )
+import Workaround ( getCurrentDirectory )
+import Darcs.Global ( debugMessage )
+import Darcs.Utils ( promptYorn )
+import Darcs.SelectChanges
+    ( WhichChanges(First),
+      runSelection,
+      selectChanges,
+      selectionContextPrim )
+import Darcs.Patch.Split ( primSplitter )
+import Darcs.Witnesses.Ordered ( (:>)(..), nullFL )
+
+import Common
+    ( diffToPrims,
+      initializeBaseState,
+      withTempRepository,
+      stdindefault )
+import DiffFile ( filesTouchedByDiff, readDiffFile )
+
+applyHelp :: String
+applyHelp = "apply help"
+
+applyDescription :: String
+applyDescription = "Apply a diff file interactively."
+
+apply :: DarcsCommand
+apply = DarcsCommand {commandName = "apply",
+                      commandHelp = applyHelp,
+                      commandDescription = applyDescription,
+                      commandExtraArgs = 1,
+                      commandExtraArgHelp = ["<PATCHFILE>"],
+                      commandCommand = applyCmd,
+                      commandPrereq = amNotInRepository,
+                      commandGetArgPossibilities = listFiles,
+                      commandArgdefaults = const stdindefault,
+                      commandAdvancedOptions = [],
+                      commandBasicOptions = []}
+
+applyCmd :: [DarcsFlag] -> [String] -> IO ()
+applyCmd _ [""] = fail "Empty filename argument given to apply!"
+applyCmd opts [unfixed_patchesfile] = do
+    maindir <- getCurrentDirectory
+    patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
+    diffPS <- readDiffFile patchesfile
+    files <- filesTouchedByDiff diffPS
+    if null files
+      then putStrLn "Patch seems to be empty"
+      else withTempRepository "work" $ \rdir -> do
+        initializeBaseState rdir maindir files
+
+        patch_ps <- diffToPrims diffPS
+
+        -- Ask the user which parts of the patch to apply
+        let context = selectionContextPrim "apply" [] (Just primSplitter) []
+        let selector = selectChanges First patch_ps
+        (wanted_ps :> _) <- runSelection selector context
+
+        when (nullFL patch_ps) $ do
+            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
+                clonePaths (toFilePath rdir) maindir files
+
+        {-
+        debugMessage $ "Printing selected parts"
+        withTempDir "ipatch-repo-old" $ \opath -> do
+          withTempDir "ipatch-repo-new" $ \npath -> do
+            setCurrentDirectory (toFilePath rdir)
+
+            debugMessage $ "Write out patched state"
+            withRepoLock (testByDefault []) $ \repo -> do
+                n <- slurp_recorded repo
+                withCurrentDirectory npath $ writeSlurpy n "."
+
+            withRepoLock (testByDefault []) $ \repo -> do
+                debugMessage $ "Return to unpatched state"
+                withGutsOf repo $ do
+                    -- How to wrap wanted_patch in FL wanted_patch?
+                    (_ :> top_patch) <- splitAtFL 1 . patchSetToPatches  <$> read_repo repo
+                    tentativelyRemovePatches repo [] top_patch
+                    tentativelyAddToPending repo [] $ invert $ effect top_patch
+                    finalizeRepositoryChanges repo
+                    applyToWorking repo [] (invert wanted_ps) `catch`
+                        \e -> fail ("Couldn't undo patch in working dir.\n" ++ show e)
+
+            debugMessage $ "Write out unpatched state"
+            withRepoLock (testByDefault []) $ \repo -> do
+                o <- slurp_recorded repo
+                withCurrentDirectory opath $ writeSlurpy o "."
+
+            output <- execPipeIgnoreError "diff" ["-u","-r",toFilePath opath,toFilePath npath] empty
+            putDoc output
+        -}
+
+        return ()
diff --git a/Common.hs b/Common.hs
new file mode 100644 (file)
index 0000000..8fa2242
--- /dev/null
+++ b/Common.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE Rank2Types #-}
+module Common where
+
+import Control.Applicative ( (<$>) )
+
+import Darcs.Arguments ( DarcsFlag(LookForAdds) )
+import Darcs.Repository
+    ( createRepository,
+      applyToWorking,
+      finalizeRepositoryChanges,
+      tentativelyAddPatch,
+      withGutsOf,
+      withRepoLock,
+      invalidateIndex,
+      unrecordedChanges )
+import Darcs.Flags ( UseIndex(..), ScanKnown(..), Compression(..) )
+import Darcs.RepoPath ( AbsolutePath, FilePathLike(..) )
+import Darcs.External ( clonePaths )
+import Darcs.Lock ( withTempDir )
+import Darcs.Patch ( invert, fromPrims, namepatch )
+import Darcs.Global ( debugMessage )
+import Darcs.Hopefully ( n2pia )
+import Darcs.Utils ( clarifyErrors )
+
+import DiffFile ( applyDiff )
+
+withTempRepository :: String -> (AbsolutePath -> IO a) -> IO a
+withTempRepository name job =
+    withTempDir ("ipatch-repo-" ++ name) $ \rdir -> do
+        debugMessage $ "Creating temporary repository in directory " ++ show rdir
+        createRepository []
+        job rdir
+
+initializeBaseState rdir sdir files = do
+    debugMessage $ "Copying " ++ show (length files) ++ " files to temporary repository."  
+    clonePaths 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 (IgnoreIndex,ScanAll) repo [] -- Correct flags?
+        init_patch <- n2pia <$> namepatch "NODATE" "Initial state" "NOAUTHOR" [] (fromPrims init_ps)
+        tentativelyAddPatch repo NoCompression init_patch
+        invalidateIndex repo
+        withGutsOf repo (finalizeRepositoryChanges repo)
+            `clarifyErrors` "Failed to apply inital patch"
+        return init_ps
+
+
+diffToPrims diff = do
+    debugMessage $ "Applying the user provided diff"
+    -- Now apply the patch
+    applyDiff diff
+
+    debugMessage $ "Creating a patch from the user changes"
+    withRepoLock [LookForAdds] $ \repo -> do
+        -- Create another patch from the changed files
+        patch_ps <- unrecordedChanges (IgnoreIndex,ScanAll) 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
+      
+stdindefault :: a -> [String] -> IO [String]
+stdindefault _ [] = return ["-"]
+stdindefault _ x = return x
diff --git a/DiffFile.hs b/DiffFile.hs
new file mode 100644 (file)
index 0000000..fbca163
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE Rank2Types #-}
+module DiffFile where
+
+
+import qualified Data.ByteString as B
+    ( ByteString, null, hGetContents, readFile )
+import qualified Data.ByteString.Char8 as BC ( unpack )
+import System.IO ( stdin )
+import Control.Applicative ( (<$>) )
+import Darcs.RepoPath ( FilePathLike(..), useAbsoluteOrStd )
+import Darcs.External ( execDocPipe )
+import Printer ( packedString, renderPS )
+import ByteStringUtils ( linesPS )
+
+newtype DiffFile = DiffFile B.ByteString
+
+readDiffFile = fmap DiffFile . useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) 
+
+filesTouchedByDiff (DiffFile bs) = map BC.unpack . filter (not . B.null) . linesPS <$> execPSPipe "diffstat" ["-l","-p1"] bs
+
+applyDiff (DiffFile bs) = execPSPipe "patch" ["-r","-","-p1"] bs
+
+
+execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString
+execPSPipe c args ps = fmap renderPS
+                     $ execDocPipe c args
+                     $ packedString ps
+
diff --git a/Help.lhs b/Help.lhs
new file mode 100644 (file)
index 0000000..2ffbdf4
--- /dev/null
+++ b/Help.lhs
@@ -0,0 +1,305 @@
+%  Copyright (C) 2002-2004 David Roundy
+%  Copyright (C) 2010 Joachim Breitner
+%
+%  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.
+
+\darcsCommand{help}
+\begin{code}
+module Help (
+ helpCmd,
+ commandControlList, environmentHelp,          -- these are for preproc.hs
+ printVersion,
+ listAvailableCommands ) where
+
+import Darcs.Arguments
+    ( DarcsFlag(..), environmentHelpEmail, environmentHelpSendmail )
+import Darcs.Commands
+    ( CommandArgs(..),
+      CommandControl(..),
+      DarcsCommand(..),
+      disambiguateCommands,
+      extractCommands,
+      getCommandHelp,
+      nodefaults,
+      usageHelper )
+import Darcs.External ( viewDoc )
+import Darcs.Lock
+    ( environmentHelpTmpdir, environmentHelpKeepTmpdir )
+import Darcs.Repository.Prefs
+    ( binariesFileHelp, environmentHelpHome )
+import Darcs.Utils
+    ( withCurrentDirectory,
+      environmentHelpEditor,
+      environmentHelpPager )
+import Data.Char ( isAlphaNum, toLower )
+import Data.List ( groupBy )
+import English ( andClauses )
+import Printer ( text )
+import Ssh
+    ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort )
+import System.Exit ( ExitCode(..), exitWith )
+import Version ( version )
+import URL ( environmentHelpProxy, environmentHelpProxyPassword )
+import Workaround ( getCurrentDirectory )
+import qualified TheCommands as TheCommands ( commandControlList )
+
+helpDescription :: String
+helpDescription = "Display help about ipatch and ipatch commands."
+
+helpHelp :: String
+helpHelp =
+ "Without arguments, `ipatch help' prints a categorized list of ipatch\n" ++
+ "commands and a short description of each one.  With an extra argument,\n" ++
+ "`ipatch help foo' prints detailed help about the ipatch command foo.\n"
+
+help :: DarcsCommand
+help = DarcsCommand {commandName = "help",
+                     commandHelp = helpHelp,
+                     commandDescription = helpDescription,
+                     commandExtraArgs = -1,
+                     commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "],
+                     commandCommand = \ x y -> helpCmd x y >> exitWith ExitSuccess,
+                     commandPrereq = \_ -> return $ Right (),
+                     commandGetArgPossibilities = return [],
+                     commandArgdefaults = nodefaults,
+                     commandAdvancedOptions = [],
+                     commandBasicOptions = []}
+
+usage :: [CommandControl] -> String
+usage cs = "Usage: ipatch COMMAND ...\n\nCommands:\n" ++
+           usageHelper cs ++ "\n" ++
+           "Use 'ipatch COMMAND --help' for help on a single command.\n" ++
+           "Use 'ipatch --version' to see the ipatch version number.\n" ++
+           "Use 'ipatch --exact-version' to get the exact version of this ipatch instance.\n"
+           -- "Use 'ipatch help environment' for help on environment variables.\n" ++
+           --"\n" ++
+           --"Check bug reports at http://bugs.darcs.net/\n"
+
+
+helpCmd :: [DarcsFlag] -> [String] -> IO ()
+helpCmd _ ["manpage"] = putStr $ unlines manpageLines
+-- helpCmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment
+helpCmd _ [] = viewDoc $ text $ usage commandControlList
+
+helpCmd _ (cmd:args) =
+    let disambiguated = disambiguateCommands commandControlList cmd args
+    in case disambiguated of
+         Left err -> fail err
+         Right (cmds,_) ->
+             let msg = case cmds of
+                         CommandOnly c       -> getCommandHelp Nothing  c
+                         SuperCommandOnly c  -> getCommandHelp Nothing  c
+                         SuperCommandSub c s -> getCommandHelp (Just c) s
+             in viewDoc $ text msg
+
+listAvailableCommands :: IO ()
+listAvailableCommands =
+    do here <- getCurrentDirectory
+       is_valid <- mapM
+                   (\c-> withCurrentDirectory here $ (commandPrereq c) [])
+                   (extractCommands commandControlList)
+       putStr $ unlines $ map (commandName . fst) $
+                filter (isRight.snd) $
+                zip (extractCommands commandControlList) is_valid
+       putStrLn "--help"
+       putStrLn "--version"
+       putStrLn "--exact-version"
+       putStrLn "--overview"
+    where isRight (Right _) = True
+          isRight _ = False
+
+printVersion :: IO ()
+printVersion = putStrLn $ "ipatch version " ++ version
+
+-- avoiding a module import cycle between Help and TheCommands
+commandControlList :: [CommandControl]
+commandControlList =
+  CommandData help : TheCommands.commandControlList
+
+-- FIXME: the "grouping" comments below should made subsections in the
+-- manpage, as we already do for DarcsCommand groups. --twb, 2009
+
+-- | Help on each environment variable in which Darcs is interested.
+environmentHelp :: [([String], [String])]
+environmentHelp = []
+{-
+ -- General-purpose
+ environmentHelpHome,
+ environmentHelpEditor,
+ environmentHelpPager,
+ environmentHelpTmpdir,
+ environmentHelpKeepTmpdir,
+ environmentHelpEmail,
+ environmentHelpSendmail,
+ -- Remote Repositories
+ environmentHelpSsh,
+ environmentHelpScp,
+ environmentHelpSshPort,
+ environmentHelpProxy,
+ environmentHelpProxyPassword]
+-}
+
+-- | The rendered form of the data in 'environment_help'.
+helpOnEnvironment :: String
+helpOnEnvironment =
+    "Environment Variables\n" ++
+    "=====================\n\n" ++
+    unlines [andClauses ks ++ ":\n" ++
+                     (unlines $ map ("  " ++) ds)
+                     | (ks, ds) <- environmentHelp]
+
+-- | This module is responsible for emitting a ipatch "man-page", a
+-- reference document used widely on Unix-like systems.  Manpages are
+-- primarily used as a quick reference, or "memory jogger", so the
+-- output should be terser than the user manual.
+--
+-- Before modifying the output, please be sure to read the man(7) and
+-- man-pages(7) manpages, as these respectively describe the relevant
+-- syntax and conventions.
+
+-- | The lines of the manpage to be printed.
+manpageLines :: [String]
+manpageLines = [
+ ".TH DARCS 1 \"" ++ version ++ "\"",
+ ".SH NAME",
+ "ipatch \\- an advanced revision control system",
+ ".SH SYNOPSIS",
+ ".B ipatch", ".I command", ".RI < arguments |[ options ]>...",
+ "",
+ "Where the", ".I commands", "and their respective", ".I arguments", "are",
+ "",
+ unlines synopsis,
+ ".SH DESCRIPTION",
+ -- FIXME: this is copy-and-pasted from ipatch.cabal, so
+ -- it'll get out of date as people forget to maintain
+ -- both in sync.
+ "ipatch is a free, open source revision control",
+ "system. It is:",
+ ".TP 3", "\\(bu",
+ "Distributed: Every user has access to the full",
+ "command set, removing boundaries between server and",
+ "client or committer and non\\(hycommitters.",
+ ".TP", "\\(bu",
+ "Interactive: ipatch is easy to learn and efficient to",
+ "use because it asks you questions in response to",
+ "simple commands, giving you choices in your work",
+ "flow. You can choose to record one change in a file,",
+ "while ignoring another. As you update from upstream,",
+ "you can review each patch name, even the full `diff'",
+ "for interesting patches.",
+ ".TP", "\\(bu",
+ "Smart: ipatch is based on a unique algebra of patches, ",
+ "Originally developed by physicist David Roundy",
+ ".SH OPTIONS",
+ "Different options are accepted by different ipatch commands.",
+ "Each command's most important options are listed in the",
+ ".B COMMANDS",
+ "section.  For a full list of all options accepted by",
+ "a particular command, run `ipatch", ".I command", "\\-\\-help'.",
+ ".SH COMMANDS",
+ unlines commands,
+ unlines environment,
+ {-
+ ".SH BUGS",
+ "At http://bugs.darcs.net/ you can find a list of known",
+ "bugs in ipatch.  Unknown bugs can be reported at that",
+ "site (after creating an account) or by emailing the",
+ "report to bugs@darcs.net.",
+ -}
+ -- ".SH EXAMPLE",
+ -- FIXME:
+ -- new project: init, rec -la;
+ -- track upstream project: get, pull -a;
+ -- contribute to project: add, rec, push/send.
+ ".SH SEE ALSO"
+ {-"A user manual is included with ipatch, in PDF and HTML",
+ "form.  It can also be found at http://darcs.net/manual/."
+ -}
+ ]
+    where
+      -- | A synopsis line for each command.  Uses 'foldl' because it is
+      -- necessary to avoid blank lines from Hidden_commands, as groff
+      -- translates them into annoying vertical padding (unlike TeX).
+      synopsis :: [String]
+      synopsis = foldl iter [] commandControlList
+          where iter :: [String] -> CommandControl -> [String]
+                iter acc (GroupName _) = acc
+                iter acc (HiddenCommand _) = acc
+                iter acc (CommandData c@SuperCommand {}) =
+                    acc ++ concatMap
+                            (render (commandName c ++ " "))
+                            (extractCommands (commandSubCommands c))
+                iter acc (CommandData c) = acc ++ render "" c
+                render :: String -> DarcsCommand -> [String]
+                render prefix c =
+                    [".B ipatch " ++ prefix ++ commandName c] ++
+                    (map mangle_args $ commandExtraArgHelp c) ++
+                    -- In the output, we want each command to be on its own
+                    -- line, but we don't want blank lines between them.
+                    -- AFAICT this can only be achieved with the .br
+                    -- directive, which is probably a GNUism.
+                    [".br"]
+
+      -- | As 'synopsis', but make each group a subsection (.SS), and
+      -- include the help text for each command.
+      commands :: [String]
+      commands = foldl iter [] commandControlList
+          where iter :: [String] -> CommandControl -> [String]
+                iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]
+                iter acc (HiddenCommand _) = acc
+                iter acc (CommandData c@SuperCommand {}) =
+                    acc ++ concatMap
+                            (render (commandName c ++ " "))
+                            (extractCommands (commandSubCommands c))
+                iter acc (CommandData c) = acc ++ render "" c
+                render :: String -> DarcsCommand -> [String]
+                render prefix c =
+                    [".B ipatch " ++ prefix ++ commandName c] ++
+                    (map mangle_args $ commandExtraArgHelp c) ++
+                    [".RS 4", escape $ commandHelp c, ".RE"]
+
+      -- | Now I'm showing off: mangle the extra arguments of Darcs commands
+      -- so as to use the ideal format for manpages, italic words and roman
+      -- punctuation.
+      mangle_args :: String -> String
+      mangle_args s =
+          ".RI " ++ (unwords $ map show (groupBy cmp $ map toLower $ gank s))
+              where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y)
+                    xor x y = (x && not y) || (y && not x)
+                    gank (' ':'o':'r':' ':xs) = '|' : gank xs
+                    gank (x:xs) = x : gank xs
+                    gank [] = []
+
+      environment :: [String]
+      environment = ".SH ENVIRONMENT" : concat
+                    [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds
+                     | (ks, ds) <- environmentHelp]
+
+      -- | Copied from Preproc.escape_latex_specials.
+      escape :: String -> String
+      escape = minus . bs       -- Order is important
+        where
+          minus      = replace "-"     "\\-"
+          bs         = replace "\\"    "\\\\"
+
+          replace :: Eq a => [a] -> [a] -> [a] -> [a]
+          replace _ _ [] = []
+          replace find repl s =
+              if take (length find) s == find
+                  then repl ++ (replace find repl (drop (length find) s))
+                  else [head s] ++ replace find repl (tail s)
+
+\end{code}
diff --git a/Split.hs b/Split.hs
new file mode 100644 (file)
index 0000000..9058f89
--- /dev/null
+++ b/Split.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE Rank2Types #-}
+module Split where
+
+import qualified Data.ByteString as B ( writeFile )
+import Control.Applicative ( (<$>) )
+import System.Directory ( createDirectory )
+import Control.Monad ( when )
+import Control.Monad.Fix ( fix )
+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.External ( execPipeIgnoreError )
+import Darcs.Lock ( withTempDir )
+import Darcs.Patch ( Prim, apply )
+import Printer ( empty, renderPS )
+import Workaround ( getCurrentDirectory )
+import Darcs.Global ( debugMessage )
+import Darcs.Utils ( askUser, promptYorn )
+import Darcs.Utils ( withCurrentDirectory )
+import Darcs.SelectChanges
+    ( WhichChanges(First),
+      runSelection,
+      selectChanges,
+      selectionContextPrim )
+import Darcs.Patch.Split ( primSplitter )
+import Darcs.Witnesses.Ordered ( FL, (:>)(..), nullFL )
+
+import Common
+    ( withTempRepository,
+      initializeBaseState,
+      diffToPrims,
+      stdindefault )
+import DiffFile ( readDiffFile, filesTouchedByDiff )
+
+splitHelp :: String
+splitHelp = "split help"
+
+splitDescription :: String
+splitDescription = "Split a diff file interactively."
+
+split :: DarcsCommand
+split = DarcsCommand {commandName = "split",
+                      commandHelp = splitHelp,
+                      commandDescription = splitDescription,
+                      commandExtraArgs = 1,
+                      commandExtraArgHelp = ["<PATCHFILE>"],
+                      commandCommand = splitCmd,
+                      commandPrereq = amNotInRepository,
+                      commandGetArgPossibilities = listFiles,
+                      commandArgdefaults = const stdindefault,
+                      commandAdvancedOptions = [],
+                      commandBasicOptions = []}
+
+splitCmd :: [DarcsFlag] -> [String] -> IO ()
+splitCmd _ [""] = fail "Empty filename argument given to split!"
+splitCmd opts [unfixed_patchesfile] = do
+    maindir <- getCurrentDirectory
+    patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
+    diffPS <- readDiffFile patchesfile
+    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
+
+        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
+                putStrLn $ "Please select the changes for the " ++ ordinal n ++ " patch"
+                --putStrLn $ "To choose " ++ show remaining_ps
+                let context = selectionContextPrim "split" [] (Just primSplitter) []
+                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
+                        exitWith ExitSuccess
+                    repeat 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)
+
+        chunks <- fix run patch_ps 1
+
+        when (null chunks) $ do
+            putStrLn "No patched splitted, exiting."
+            exitWith ExitSuccess
+
+        withTempDir "ipatch-diff-area" $ \bpath -> do
+            debugMessage "Setting up old and new staging areas"
+            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
+                output <- renderPS <$> execPipeIgnoreError "diff" ["-u","-r","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)
+
+
+ordinal 1 = "first"
+ordinal 2 = "second"
+ordinal 3 = "third"
+ordinal n = show n ++ "th"
diff --git a/TheCommands.hs b/TheCommands.hs
new file mode 100644 (file)
index 0000000..f058d13
--- /dev/null
@@ -0,0 +1,14 @@
+module TheCommands where
+
+import Darcs.Commands ( CommandControl(CommandData, GroupName) )
+import Apply ( apply )
+import Split ( split )
+
+commandControlList :: [CommandControl]
+commandControlList =
+    [ GroupName "Changing files"
+    , CommandData apply
+    , GroupName "Changing patches"
+    , CommandData split
+    ]
+
diff --git a/Version.hs b/Version.hs
new file mode 100644 (file)
index 0000000..a6237ca
--- /dev/null
@@ -0,0 +1,4 @@
+module Version where
+
+version = "noversion"
+context = "nocontext"
diff --git a/ipatch.hs b/ipatch.hs
new file mode 100644 (file)
index 0000000..338f5b7
--- /dev/null
+++ b/ipatch.hs
@@ -0,0 +1,30 @@
+import System.Environment ( getArgs )
+import System.IO ( hSetBinaryMode, stdin, stdout )
+
+import Darcs.Flags ( DarcsFlag(Verbose) )
+import Darcs.RunCommand ( runTheCommand )
+
+import Version ( version, context )
+import Help
+    ( commandControlList,
+      helpCmd,
+      listAvailableCommands,
+      printVersion )
+
+main = do
+  argv <- getArgs
+  case argv of
+    []                  -> printVersion >> helpCmd [] []
+    ["-h"]              -> helpCmd [] []
+    ["--help"]          -> helpCmd [] []
+    ["--overview"]      -> helpCmd [Verbose] []
+    ["--commands"]      -> listAvailableCommands
+    ["-v"]              -> putStrLn version
+    ["--version"]       -> putStrLn version
+    ["--exact-version"] -> do
+              --putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__
+              putStrLn context
+    _ -> do
+      hSetBinaryMode stdin True
+      hSetBinaryMode stdout True
+      runTheCommand commandControlList (head argv) (tail argv)