Use hierarchical module names
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 22 Aug 2010 18:56:25 +0000 (18:56 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 22 Aug 2010 18:56:25 +0000 (18:56 +0000)
18 files changed:
Apply.hs [deleted file]
Common.hs [deleted file]
DiffFile.hs [deleted file]
Help.lhs [deleted file]
Setup.hs [new file with mode: 0644]
Split.hs [deleted file]
TheCommands.hs [deleted file]
Version.hs [deleted file]
ipatch.cabal
ipatch.hs [deleted file]
src/IPatch/Apply.hs [new file with mode: 0644]
src/IPatch/Common.hs [new file with mode: 0644]
src/IPatch/DiffFile.hs [new file with mode: 0644]
src/IPatch/Help.lhs [new file with mode: 0644]
src/IPatch/Split.hs [new file with mode: 0644]
src/IPatch/TheCommands.hs [new file with mode: 0644]
src/IPatch/Version.hs [new file with mode: 0644]
src/ipatch.hs [new file with mode: 0644]

diff --git a/Apply.hs b/Apply.hs
deleted file mode 100644 (file)
index 9a76d77..0000000
--- a/Apply.hs
+++ /dev/null
@@ -1,130 +0,0 @@
-{-# 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.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,
-      clonePathsWithDeletion )
-import DiffFile ( filesTouchedByDiff, readDiffFile )
-
-applyHelp :: String
-applyHelp =
-    "The `ipatch apply file.patch' command works similar to a `patch file.patch' command.\n" ++
-    "It will, however, prompt the user about each part of the patch, whether it should\n" ++
-    "be applied or not. Using the integrated hunk editor, the user has full control over\n" ++
-    "the chosen changes.\n"++
-    "\n"++
-    "No files are touched until the end, when the user is asked for a final confirmation.\n"
-
-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
-                clonePathsWithDeletion (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
deleted file mode 100644 (file)
index 2730632..0000000
--- a/Common.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{-# LANGUAGE Rank2Types #-}
-module Common where
-
-import Control.Applicative ( (<$>) )
-import Control.Monad (when)
-import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
-import System.Directory ( createDirectoryIfMissing, doesFileExist, removeFile )
-import System.FilePath.Posix ( (</>), takeDirectory, normalise )
-
-import Darcs.Arguments ( DarcsFlag(LookForAdds) )
-import Darcs.Repository
-    ( createRepository,
-      applyToWorking,
-      finalizeRepositoryChanges,
-      tentativelyAddPatch,
-      withGutsOf,
-      withRepoLock,
-      invalidateIndex,
-      unrecordedChanges )
-import Darcs.Flags ( Compression(..) )
-import Darcs.RepoPath ( AbsolutePath, FilePathLike(..) )
-import Darcs.External ( cloneFile )
-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 )
-
-clonePathWithDeletion :: FilePath -> FilePath -> FilePath -> IO ()
-clonePathWithDeletion source dest path = do
-    let source' = source </> path
-        dest' = dest </> path
-    ex <- doesFileExist source'
-    if ex
-     then do
-        fs <- getSymbolicLinkStatus source'
-        if isDirectory fs
-         then do
-            createDirectoryIfMissing True dest'
-         else
-            if isRegularFile fs
-             then do
-                createDirectoryIfMissing True (dest </> takeDirectory path)
-                cloneFile source' dest'
-             else
-                fail ("clonePathWithDeletion: Bad file " ++ source')
-     else do
-        exT <- doesFileExist dest'
-        when exT $ removeFile dest'
-   `catch` fail ("clonePathWithDeletion: Bad file " ++ source </> path)
-
-clonePathsWithDeletion source dest = mapM_ (clonePathWithDeletion source dest)
-
-
-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."  
-    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?
-        init_patch <- n2pia <$> namepatch "NODATE" "Initial state" "NOAUTHOR" [] (fromPrims init_ps)
-        tentativelyAddPatch repo [] 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 [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
-      
-stdindefault :: a -> [String] -> IO [String]
-stdindefault _ [] = return ["-"]
-stdindefault _ x = return x
diff --git a/DiffFile.hs b/DiffFile.hs
deleted file mode 100644 (file)
index fbca163..0000000
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# 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
deleted file mode 100644 (file)
index 8f7bf29..0000000
--- a/Help.lhs
+++ /dev/null
@@ -1,306 +0,0 @@
-%  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, -- This still prints "darcs", need to revise API here.
-      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]]  "],
-                     commandExtraArgHelp = ["[<IPATCH_COMMAND>]  "],
-                     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/Setup.hs b/Setup.hs
new file mode 100644 (file)
index 0000000..cd7dc32
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
diff --git a/Split.hs b/Split.hs
deleted file mode 100644 (file)
index 059ede6..0000000
--- a/Split.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# 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 =
-    "The `ipatch split file.patch' lets the user select different parts (hunks) of the\n" ++
-    "given patch file. After making a choice for each hunk, the user has to provide a\n" ++
-    "file name where the selected changes are stored. This procedure is repeated until\n" ++
-    "each change in the original file has been selected for one output file.\n" ++
-    "\n"++
-    "No files are modified by this command. The output patch files are all written at the\n" ++
-    "of the process.\n"
-
-
-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" ["-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)
-
-
-ordinal 1 = "first"
-ordinal 2 = "second"
-ordinal 3 = "third"
-ordinal n = show n ++ "th"
diff --git a/TheCommands.hs b/TheCommands.hs
deleted file mode 100644 (file)
index f058d13..0000000
+++ /dev/null
@@ -1,14 +0,0 @@
-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
deleted file mode 100644 (file)
index fa08df7..0000000
+++ /dev/null
@@ -1,7 +0,0 @@
-module Version (version) where
-
-import Data.Version
-
-import qualified Paths_ipatch
-
-version = showVersion Paths_ipatch.version
index 98dc8e0..5a45abd 100644 (file)
@@ -20,15 +20,15 @@ Cabal-version:       >=1.8
 
 
 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
-  Other-modules:     Apply
-                     DiffFile
-                     Split
-                     Version
-                     Common
-                     Help
-                     Setup
-                     TheCommands 
+  Other-modules:     IPatch.Apply
+                     IPatch.DiffFile
+                     IPatch.Split
+                     IPatch.Version
+                     IPatch.Common
+                     IPatch.Help
+                     IPatch.TheCommands 
diff --git a/ipatch.hs b/ipatch.hs
deleted file mode 100644 (file)
index 6a98cf0..0000000
--- a/ipatch.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-import System.Environment ( getArgs )
-import System.IO ( hSetBinaryMode, stdin, stdout )
-
-import Darcs.Flags ( DarcsFlag(Verbose) )
-import Darcs.RunCommand ( runTheCommand )
-
-import Version ( version )
-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
-    _ -> do
-      hSetBinaryMode stdin True
-      hSetBinaryMode stdout True
-      runTheCommand commandControlList (head argv) (tail argv)
diff --git a/src/IPatch/Apply.hs b/src/IPatch/Apply.hs
new file mode 100644 (file)
index 0000000..3fbc665
--- /dev/null
@@ -0,0 +1,130 @@
+{-# LANGUAGE Rank2Types #-}
+module IPatch.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.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 IPatch.Common
+    ( diffToPrims,
+      initializeBaseState,
+      withTempRepository,
+      stdindefault,
+      clonePathsWithDeletion )
+import IPatch.DiffFile ( filesTouchedByDiff, readDiffFile )
+
+applyHelp :: String
+applyHelp =
+    "The `ipatch apply file.patch' command works similar to a `patch file.patch' command.\n" ++
+    "It will, however, prompt the user about each part of the patch, whether it should\n" ++
+    "be applied or not. Using the integrated hunk editor, the user has full control over\n" ++
+    "the chosen changes.\n"++
+    "\n"++
+    "No files are touched until the end, when the user is asked for a final confirmation.\n"
+
+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
+                clonePathsWithDeletion (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/src/IPatch/Common.hs b/src/IPatch/Common.hs
new file mode 100644 (file)
index 0000000..c8841c8
--- /dev/null
@@ -0,0 +1,97 @@
+{-# LANGUAGE Rank2Types #-}
+module IPatch.Common where
+
+import Control.Applicative ( (<$>) )
+import Control.Monad (when)
+import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
+import System.Directory ( createDirectoryIfMissing, doesFileExist, removeFile )
+import System.FilePath.Posix ( (</>), takeDirectory, normalise )
+
+import Darcs.Arguments ( DarcsFlag(LookForAdds) )
+import Darcs.Repository
+    ( createRepository,
+      applyToWorking,
+      finalizeRepositoryChanges,
+      tentativelyAddPatch,
+      withGutsOf,
+      withRepoLock,
+      invalidateIndex,
+      unrecordedChanges )
+import Darcs.Flags ( Compression(..) )
+import Darcs.RepoPath ( AbsolutePath, FilePathLike(..) )
+import Darcs.External ( cloneFile )
+import Darcs.Lock ( withTempDir )
+import Darcs.Patch ( invert, fromPrims, namepatch )
+import Darcs.Global ( debugMessage )
+import Darcs.Hopefully ( n2pia )
+import Darcs.Utils ( clarifyErrors )
+
+import IPatch.DiffFile ( applyDiff )
+
+clonePathWithDeletion :: FilePath -> FilePath -> FilePath -> IO ()
+clonePathWithDeletion source dest path = do
+    let source' = source </> path
+        dest' = dest </> path
+    ex <- doesFileExist source'
+    if ex
+     then do
+        fs <- getSymbolicLinkStatus source'
+        if isDirectory fs
+         then do
+            createDirectoryIfMissing True dest'
+         else
+            if isRegularFile fs
+             then do
+                createDirectoryIfMissing True (dest </> takeDirectory path)
+                cloneFile source' dest'
+             else
+                fail ("clonePathWithDeletion: Bad file " ++ source')
+     else do
+        exT <- doesFileExist dest'
+        when exT $ removeFile dest'
+   `catch` fail ("clonePathWithDeletion: Bad file " ++ source </> path)
+
+clonePathsWithDeletion source dest = mapM_ (clonePathWithDeletion source dest)
+
+
+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."  
+    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?
+        init_patch <- n2pia <$> namepatch "NODATE" "Initial state" "NOAUTHOR" [] (fromPrims init_ps)
+        tentativelyAddPatch repo [] 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 [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
+      
+stdindefault :: a -> [String] -> IO [String]
+stdindefault _ [] = return ["-"]
+stdindefault _ x = return x
diff --git a/src/IPatch/DiffFile.hs b/src/IPatch/DiffFile.hs
new file mode 100644 (file)
index 0000000..0d62cf6
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE Rank2Types #-}
+module IPatch.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/src/IPatch/Help.lhs b/src/IPatch/Help.lhs
new file mode 100644 (file)
index 0000000..a3f2ec9
--- /dev/null
@@ -0,0 +1,307 @@
+%  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 IPatch.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, -- This still prints "darcs", need to revise API here.
+      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 URL ( environmentHelpProxy, environmentHelpProxyPassword )
+import Workaround ( getCurrentDirectory )
+
+import IPatch.Version ( version )
+import qualified IPatch.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]]  "],
+                     commandExtraArgHelp = ["[<IPATCH_COMMAND>]  "],
+                     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/src/IPatch/Split.hs b/src/IPatch/Split.hs
new file mode 100644 (file)
index 0000000..547b73d
--- /dev/null
@@ -0,0 +1,132 @@
+{-# LANGUAGE Rank2Types #-}
+module IPatch.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 IPatch.Common
+    ( withTempRepository,
+      initializeBaseState,
+      diffToPrims,
+      stdindefault )
+import IPatch.DiffFile ( readDiffFile, filesTouchedByDiff )
+
+splitHelp :: String
+splitHelp =
+    "The `ipatch split file.patch' lets the user select different parts (hunks) of the\n" ++
+    "given patch file. After making a choice for each hunk, the user has to provide a\n" ++
+    "file name where the selected changes are stored. This procedure is repeated until\n" ++
+    "each change in the original file has been selected for one output file.\n" ++
+    "\n"++
+    "No files are modified by this command. The output patch files are all written at the\n" ++
+    "of the process.\n"
+
+
+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" ["-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)
+
+
+ordinal 1 = "first"
+ordinal 2 = "second"
+ordinal 3 = "third"
+ordinal n = show n ++ "th"
diff --git a/src/IPatch/TheCommands.hs b/src/IPatch/TheCommands.hs
new file mode 100644 (file)
index 0000000..a80c6ea
--- /dev/null
@@ -0,0 +1,15 @@
+module IPatch.TheCommands where
+
+import Darcs.Commands ( CommandControl(CommandData, GroupName) )
+
+import IPatch.Apply ( apply )
+import IPatch.Split ( split )
+
+commandControlList :: [CommandControl]
+commandControlList =
+    [ GroupName "Changing files"
+    , CommandData apply
+    , GroupName "Changing patches"
+    , CommandData split
+    ]
+
diff --git a/src/IPatch/Version.hs b/src/IPatch/Version.hs
new file mode 100644 (file)
index 0000000..16db7ef
--- /dev/null
@@ -0,0 +1,7 @@
+module IPatch.Version (version) where
+
+import Data.Version
+
+import qualified Paths_ipatch
+
+version = showVersion Paths_ipatch.version
diff --git a/src/ipatch.hs b/src/ipatch.hs
new file mode 100644 (file)
index 0000000..2a089b1
--- /dev/null
@@ -0,0 +1,27 @@
+import System.Environment ( getArgs )
+import System.IO ( hSetBinaryMode, stdin, stdout )
+
+import Darcs.Flags ( DarcsFlag(Verbose) )
+import Darcs.RunCommand ( runTheCommand )
+
+import IPatch.Version ( version )
+import IPatch.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
+    _ -> do
+      hSetBinaryMode stdin True
+      hSetBinaryMode stdout True
+      runTheCommand commandControlList (head argv) (tail argv)