packages feed

darcs-beta (empty) → 2.2.98.1

raw patch · 421 files changed

+52488/−0 lines, 421 filesdep +HTTPdep +HUnitdep +QuickCheckbuild-type:Customsetup-changedbinary-added

Dependencies added: HTTP, HUnit, QuickCheck, array, base, bytestring, containers, directory, filepath, hashed-storage, haskeline, html, mmap, mtl, network, old-time, parsec, process, random, regex-compat, terminfo, test-framework, test-framework-hunit, test-framework-quickcheck2, unix, utf8-string, zlib

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ COPYING view
@@ -0,0 +1,339 @@+		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++			    NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++		     END OF TERMS AND CONDITIONS++	    How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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 of the License, 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; if not, write to the Free Software Foundation, Inc.,+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ Distribution/ShellHarness.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -cpp #-}+module Distribution.ShellHarness ( runTests ) where++import Prelude hiding( catch )+import System.Directory ( getCurrentDirectory, setPermissions,+                          Permissions(..), getDirectoryContents,+                          findExecutable, createDirectoryIfMissing )+import System.Environment ( getEnv, getEnvironment )+import System.Exit ( ExitCode (..) )+import System.FilePath+import System.IO+import System.Process ( ProcessHandle,+                        runInteractiveProcess, waitForProcess,+                        getProcessExitCode )+import Data.Maybe+import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy )+import Control.Concurrent+#if __GLASGOW_HASKELL__ >= 610+import Control.OldException+#else+import Control.Exception+#endif+import Control.Monad++runTests :: Maybe FilePath -> String -> [String] -> IO Bool+runTests darcs_path cwd tests = do+     fails <- run darcs_path tests+     if  "bugs" `isInfixOf` cwd+         then if (length tests /= length fails)+                 then do putStrLn $ "Some bug tests passed:"+                         mapM_ putStrLn (tests \\ fails)+                         return False+                 else do putStrLn "All bug tests OK"+                         return True+         else if fails /= []+                 then do putStrLn "Some tests failed:"+                         mapM_ putStrLn fails+                         return False+                 else do putStrLn "All tests OK"+                         return True++run :: Maybe FilePath -> [String] -> IO [String]+run set_darcs_path tests= do+    cwd <-  getCurrentDirectory+    path <- getEnv "PATH"+    env <- getEnvironment+    darcs_path <- case set_darcs_path of+                    Nothing -> get_darcs_path+                    Just x -> return x+    let myenv = [("HOME",cwd)+                ,("APPDATA",cwd) -- the Windows analogue of $HOME.+                ,("TESTS_WD",cwd)+                ,("EMAIL","tester")+                ,("DARCSEMAIL","tester")+                ,("PATH",(darcs_path++":"++path))+                ,("DARCS_DONT_COLOR","1")+                ,("DARCS_DONT_ESCAPE_ANYTHING","1")]+    bash <- find_bash+    let shell = takeWhile (/= '\n') bash+    putStrLn $ "Using bash shell in '"++shell++"'"+    set_prefs+    run_helper shell tests []  (set_env myenv env)+  where get_darcs_path = do+           env <- getEnvironment+           cwd <-  getCurrentDirectory+           case lookup "DARCS" env of+                Nothing -> return (cwd ++ "/..")+                Just d  -> return $ takeDirectory d+        set_prefs = do+            finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n")+                           (\e -> fail $ "Unable to set preferences: "+                                         ++ show e))+                    (createDirectoryIfMissing  False ".darcs")+run_helper :: String -> [String] -> [String] ->+                  [(String,String)] -> IO [String]+run_helper _ [] fails _ = return fails+run_helper shell (test:ts) fails env = do+    putStr $ "Running " ++ test ++ " ..." ++ (replicate (36 - (length test)) ' ')+    (output,success) <- backtick shell test env+    if success then do putStrLn " passed."+                       cleanup_dirs+                       run_helper shell ts fails env+               else do putStrLn " failed."+                       putStrLn $ "Probable reason :" ++ output+                       cleanup_dirs+                       run_helper shell ts (fails++[test]) env+  where cleanup_dirs :: IO ()+        cleanup_dirs =+          do dirfiles <- getDirectoryContents (fromJust $ lookup "TESTS_WD" env)+             let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) +++                             (filter ("tmp" `isPrefixOf`) dirfiles)+             mapM_ (\x-> +                  setPermissions x (Permissions +                                   {readable = True+                                   ,writable = True+                                   ,executable = False+                                   ,searchable = True}+                                   )+                 ) tempfiles++backtick :: String -> String -> [(String, String)]-> IO (String,Bool)+backtick cmd args env = do+   (exitcode,res) <- backtick_helper cmd args env+   case exitcode of+        ExitSuccess -> return (res, True)+        ExitFailure _ -> return (res, False)++backtick_helper :: String -> String -> [(String,String)] ->+                                      IO (ExitCode, String)+backtick_helper cmd args env = process_wrapper (runInteractiveProcess+                                                   cmd [args] Nothing+                                                   (Just env)+                                               ) ""++find_bash :: IO FilePath+find_bash =+   do sh <- findExecutable "bash"+      case sh of+          Just p -> return p+          Nothing -> error "Could not find bash in PATH"++-- | Run a process with a list of arguments and return anything from+-- /stderr/ or /stdout/+process_wrapper :: IO (Handle, Handle, Handle, ProcessHandle) ->+                   String -> IO (ExitCode, String)+process_wrapper f _ = do+       (_,o,e,pid) <- f+       hSetBuffering o LineBuffering+       hSetBuffering e LineBuffering+       ch <- newChan+       -- WARNING: beware of hokeyness ahead!+       let readWrite i = do x <- hGetLine i+                            writeChan ch $ Just x+                            readWrite i+                         `catch` \_ -> writeChan ch Nothing+           readEO = do x <- readChan ch+                       case x of+                         Just l -> do y <- readEO+                                      return $ l:y+                         Nothing -> readEO'+           readEO' = do x <- readChan ch+                        case x of+                          Just l -> do y <- readEO'+                                       return $ l:y+                          Nothing -> return []+       forkIO $ readWrite o+       forkIO $ readWrite e+       outerr <- readEO+       ec <- waitForProcessNonBlocking pid+       threadDelay 1000+       case ec of+         ExitFailure 127 -> fail $ "timeout running command\n\n"+                                   ++unlines outerr+         _ -> return (ec, unlines outerr)++--+-- waitForProcess uses a very hokey heuristic to try to avoid burning too+-- much CPU time in a busy wait, while also not adding too much extra+-- latency.++waitForProcessNonBlocking :: ProcessHandle -> IO ExitCode+waitForProcessNonBlocking = if rtsSupportsBoundThreads+                            then waitForProcess+                            else wfp 0+    where wfp n pid = do mec <- getProcessExitCode pid+                         case mec of+                           Just ec -> return ec+                           Nothing -> do threadDelay n+                                         wfp (min 100000 (n+1+n`div`4)) pid++++set_env :: [(String,String)] -> [(String,String)] -> [(String, String)]+set_env es env = nubBy (\(x,_) (y,_) -> x == y) (es ++ env)
+ README view
@@ -0,0 +1,90 @@+Darcs+=====+This is the source tree for darcs, a distributed version control system+written in Haskell.++For more information, visit the darcs web site:++   http://www.darcs.net+++Compilation and Installation+============================++Darcs currently supports two build systems: a traditional autotools-+based system, and an experimental cabal-based system.  Currently+AUTOTOOLS IS RECOMMENDED; in later releases it will be deprecated and+eventually removed (in favour of cabal).++If a "configure" file is present, autotools is supported.  If a+"Setup.lhs" file is present, cabal is supported.  Currently there is a+separate source tarball for each build system; either can be used in+unstable checkouts.+++Using Autotools+---------------++If you have the normal, autotools-based tarball, this sequence should work+for you (if you are in doubt, this is likely the case):++    $ ./configure+    $ make+    # make install++You first need to run `autoconf` if you obtained the source tree from the+darcs repository (but this is not needed for release tarballs).++For more information, please see the manual:++ * http://www.darcs.net/manual+ * doc/manual/darcs.ps+++Using Cabal+-----------++This method requires the cabal package, version 1.6 or higher.  The+cabal-install package is also recommended.++If you have the "cabal-install" package on your system (that is, there+is a "cabal" executable in your path), you can use the following+commands to create an executable in ~/.cabal/bin/darcs.++    $ cabal configure+    $ cabal build+    $ cabal install++Otherwise, if you have the "cabal" package but not the "cabal-install"+package, run the following:++    $ runghc Setup configure+    $ runghc Setup build+    $ sudo runghc Setup install++You may also omit the last step and copy the darcs executable (found in+dist/build/darcs/darcs) to a location of your choosing.++More detailed instructions can be found at+<http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package>+including instructions on obtaining a copy of cabal-install.++Please also note that the cabal-based build by default requires the cURL+library (and development headers). If, for some reason, you cannot provide+cURL, please pass "-f-curl" to the configure step above.++Hacking+=======+For more information about darcs hacking and best practices please check+the darcs wiki at http://wiki.darcs.net/DarcsWiki++Of particular interest are the following documents:+  * http://wiki.darcs.net/index.html/DeveloperFAQ+  * http://wiki.darcs.net/index.html/DeveloperTips++Testing+=======+For more information about the test suite, including how to run specific+tests please read tests/README.test_maintainers.txt.++Happy hacking!
+ Setup.lhs view
@@ -0,0 +1,389 @@+\begin{code}+{-# OPTIONS_GHC -cpp #-}+-- copyright (c) 2008 Duncan Coutts+-- portions copyright (c) 2008 David Roundy++import Distribution.Simple+         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.PackageDescription+         ( PackageDescription(executables), Executable(buildInfo, exeName)+         , BuildInfo(customFieldsBI), emptyBuildInfo+         , updatePackageDescription, cppOptions, ccOptions )+import Distribution.Package+         ( packageVersion )+import Distribution.Version+         ( Version(versionBranch) )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), absoluteInstallDirs )+import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))+import Distribution.Simple.Setup+    (buildVerbosity, copyDest, copyVerbosity, fromFlag,+     haddockVerbosity, installVerbosity, sDistVerbosity)+import Distribution.Simple.BuildPaths+         ( autogenModulesDir )+import Distribution.System+         ( OS(Windows), buildOS )+import Distribution.Simple.Utils+    (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,+     rewriteFile)+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text+         ( display )+import Distribution.Package (Package)++import Control.Monad ( zipWithM_, when, unless, filterM )+import Control.Exception ( bracket )+import System.Directory+    (copyFile, createDirectory, createDirectoryIfMissing,+     doesDirectoryExist, doesFileExist,+     getCurrentDirectory, getDirectoryContents,+     removeDirectoryRecursive, removeFile, setCurrentDirectory)+import System.IO (openFile, IOMode (..))+import System.Process (runProcess)+import System.IO.Error ( isDoesNotExistError )+import Data.List( isSuffixOf, sort, partition )++import System.FilePath       ( (</>), splitDirectories, isAbsolute )+import Foreign.Marshal.Utils ( with )+import Foreign.Storable      ( peek )+import Foreign.Ptr           ( castPtr )+import Data.Word             ( Word8, Word32 )++import qualified Distribution.ShellHarness as Harness ( runTests )++#if __GLASGOW_HASKELL__ >= 610+import qualified Control.OldException as Exception+#else+import qualified Control.Exception as Exception+#endif++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {++  buildHook = \ pkg lbi hooks flags ->+              let verb = fromFlag $ buildVerbosity flags+               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),++  haddockHook = \ pkg lbi hooks flags ->+                let verb = fromFlag $ haddockVerbosity flags+                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,++  postBuild = \ _ _ _ lbi -> buildManpage lbi,+  postCopy = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),+  postInst = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,++  runTests = \ args _ _ lbi -> do+             cwd <- getCurrentDirectory+             let isabs = isAbsolute $ buildDir lbi+                 path = (if isabs then id else (cwd </>))+                        (buildDir lbi </> "darcs")+                 what = if null args then ["tests"] else args+                 (series, tests) = partition+                                     (`elem` ["bugs", "network", "tests"]) what+             sequence_ [ case w of+                           "bugs" -> allTests path Bug []+                           "network" -> execTests path Network "" []+                           "tests" -> allTests path Test []+                           _ -> return () {- impossible, silence -Wall -}+                         | w <- series ]+             when (not $ null tests) $ individualTests path tests,++  -- Remove the temporary directories created by "cabal test".+  postClean = \ _ _ _ _ -> mapM_ rmRf+              ["tests-darcs-2.dir",+               "tests-hashed.dir",+               "tests-old-fashioned-inventory.dir",+               "bugs-darcs-2.dir",+               "bugs-hashed.dir",+               "bugs-old-fashioned-inventory.dir",+               "tests_network-.dir"],++  sDistHook = \ pkg lbi hooks flags -> do+    let pkgVer = packageVersion pkg+        verb = fromFlag $ sDistVerbosity flags+    x <- versionPatches verb pkgVer+    y <- context verb pkgVer+    rewriteFile "release/distributed-version" $ show x+    rewriteFile "release/distributed-context" $ show y++    sDistHook simpleUserHooks pkg lbi hooks flags+}++-- | For @./Setup build@ and @./Setup haddock@, do some unusual+-- things, then invoke the base behaviour ("simple hook").+commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)+                -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a+commonBuildHook runHook pkg lbi hooks verbosity = do+  -- Autoconf may have generated a context file.  Remove it before+  -- building, as its existence inexplicably breaks Cabal.+  removeFile "src/Context.hs"+    `catch` (\e -> unless (isDoesNotExistError e) (ioError e))++  -- Create our own context file.+  writeGeneratedModules verbosity pkg lbi++  -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)+  -- invocations, doing a dance to make the base hook aware of them.+  (version, state) <- determineVersion verbosity pkg+  littleEndian <- testEndianness+  let args = ("-DPACKAGE_VERSION=" ++ show' version) :+             ("-DPACKAGE_VERSION_STATE=" ++ show' state) :+             [arg | (arg, True) <-         -- include fst iff snd.+              [("-DHAVE_HTTP", "x-have-http" `elem` customFields),+               ("-DUSE_COLOR", "x-use-color" `elem` customFields),+               -- We have MAPI iff building on/for Windows.+               ("-DHAVE_MAPI", buildOS == Windows),+               ("-DBIGENDIAN", not littleEndian)]]+      bi = emptyBuildInfo { cppOptions = args, ccOptions = args }+      hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])+      pkg' = updatePackageDescription hbi pkg+      lbi' = lbi { localPkgDescr = pkg' }+  return $ runHook simpleUserHooks pkg' lbi' hooks++  where+    customFields = map fst . customFieldsBI . buildInfo $ darcsExe+    darcsExe = head [e | e <- executables pkg, exeName e == "darcs"]+    show' :: String -> String   -- Petr was worried that we might+    show' = show                -- allow non-String arguments.+    testEndianness :: IO Bool+    testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p+                                                   return $ o == (1 :: Word8)++buildManpage :: LocalBuildInfo -> IO ()+buildManpage lbi = do+  let darcs = buildDir lbi </> "darcs/darcs"+      manpage = buildDir lbi </> "darcs/darcs.1"+  manpageHandle <- openFile manpage WriteMode+  runProcess darcs ["help","manpage"]+             Nothing Nothing Nothing (Just manpageHandle) Nothing+  return ()++installManpage :: PackageDescription -> LocalBuildInfo+                  -> Verbosity -> CopyDest -> IO ()+installManpage pkg lbi verbosity copy =+    copyFiles verbosity+              (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")+              [(buildDir lbi </> "darcs", "darcs.1")]++writeGeneratedModules :: Verbosity+                      -> PackageDescription -> LocalBuildInfo -> IO ()+writeGeneratedModules verbosity pkg lbi = do+  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)++  let contextModulePath = autogenModulesDir lbi </> "Context.hs"+  generateContextModule verbosity contextModulePath pkg++determineVersion :: Verbosity -> PackageDescription -> IO (String, String)+determineVersion verbosity pkg = do+  let darcsVersion  =  packageVersion pkg+  numPatches <- versionPatches verbosity darcsVersion+  return (display darcsVersion, versionStateString numPatches darcsVersion)++  where+    versionStateString :: Maybe Int -> Version -> String+    versionStateString Nothing  _ = "unknown"+    versionStateString (Just 0) v = case versionBranch v of+                         x | 97 `elem` x -> "alpha " ++ show (after 97 x)+                           | 98 `elem` x -> "beta " ++ show (after 98 x)+                           | 99 `elem` x  ->+                               "release candidate " ++ show (after 99 x)+                         _ -> "release"+    versionStateString (Just 1) _ = "+ 1 patch"+    versionStateString (Just n) _ = "+ " ++ show n ++ " patches"+    after w (x:r) | w == x = head r+                  | otherwise = after w r+    after _ [] = undefined++versionPatches :: Verbosity -> Version -> IO (Maybe Int)+versionPatches verbosity darcsVersion = do+  numPatchesDarcs <- do+      out <- rawSystemStdout verbosity "darcs"+               ["changes", "--from-tag", display darcsVersion, "--count"]+      case reads (out) of+        ((n,_):_) -> return $ Just ((n :: Int) - 1)+        _         -> return Nothing+    `Exception.catch` \_ -> return Nothing++  numPatchesDist <- parseFile versionFile+  return $ case (numPatchesDarcs, numPatchesDist) of+             (Just x, _) -> Just x+             (Nothing, Just x) -> Just x+             (Nothing, Nothing) -> Nothing++ where+  versionFile = "release/distributed-version"++generateContextModule :: (Package pkg) => Verbosity -> FilePath -> pkg -> IO ()+generateContextModule verbosity targetFile pkg = do+  ctx <- context verbosity (packageVersion pkg)+  rewriteFile targetFile $ unlines+    ["module Context where"+    ,"context :: String"+    ,"context = " ++ case ctx of+                       Just x -> show x+                       Nothing -> show "context not available"+    ]++context :: Verbosity -> Version -> IO (Maybe String)+context verbosity version = do+  contextDarcs <- do+      -- FIXME currently we run changes --from-tag to at least assert that the+      -- requested version is tagged in this repository... it is a weak check,+      -- but otherwise, my ~/_darcs context tends to gets used when running+      -- from an unpacked distribution+      rawSystemStdout verbosity "darcs"+                          ["changes", "--from-tag", display version ]+      out <- rawSystemStdout verbosity "darcs" ["changes", "--context"]+      return $ Just out+   `Exception.catch` \_ -> return Nothing++  contextDist <- parseFile contextFile+  return $ case (contextDarcs, contextDist) of+             (Just x, _) -> Just x+             (Nothing, Just x) -> Just x+             (Nothing, Nothing) -> Nothing+ where contextFile = "release/distributed-context"++parseFile :: (Read a) => String -> IO (Maybe a)+parseFile f = do+  exist <- doesFileExist f+  if exist then do+             content <- readFile f -- ^ ratify readFile: we don't care here.+             case reads content of+               ((s,_):_) -> return s+               _         -> return Nothing+             else return Nothing++-------------------------------------+-- Running the testsuite+--++data TestKind = Bug | Test | Network deriving Eq++instance Show TestKind where+    show Bug = "bugs"+    show Test = "tests"+    show Network = "tests/network"++flat :: (Show a) => a -> String+flat a = [ if x == '/' then '_' else x | x <- show a ]++isTest :: FilePath -> Bool+isTest = (".sh" `isSuffixOf`)++execTests :: FilePath -> TestKind -> String -> [String] -> IO ()+execTests darcs_path k fmt tests = do+  let dir = (flat k) ++ "-" ++ fmt ++ ".dir"+  rmRf dir+  cloneTree (show k) dir+  withCurrentDirectory dir $ do+    createDirectory ".darcs"+    when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n"+    putStrLn $ "Running tests for format: " ++ fmt+    exec+ where exec = do+         fs <- case tests of+                  [] -> sort `fmap` getDirectoryContents "."+                  x -> return x+         cwd <- getCurrentDirectory+         let run = filter isTest fs+         res <- Harness.runTests (Just darcs_path) cwd run+         when ((not res) && (k /= Bug)) $ fail "Tests failed"+         return ()++individualTests :: FilePath -> [String] -> IO ()+individualTests darcs_path tests = do+  run <- concat `fmap` mapM find tests+  sequence_ [ do exec kind [test | (kind', test) <- run, kind' == kind]+                     | kind <- [Test, Bug, Network] ]+      where tryin w t' = [w </> t', w </> (t' ++ ".sh")]+            exec _ [] = return ()+            exec kind to_run = allTests darcs_path kind to_run+            find t = do+              let c = [t, t ++ ".sh"] ++ tryin "tests" t ++ tryin "bugs" t+                        ++ tryin "network" t+              run <- map kindify `fmap` filterM doesFileExist c+              return $ take 1 run+            kindify test = case splitDirectories test of+                             [p, y] -> (parse_kind p, y)+                             _ -> error $ "Bad format in " ++ test +++                                          ": expected type/test"+            parse_kind "tests" = Test+            parse_kind "bugs" = Bug+            parse_kind "network" = Network+            parse_kind x = error $ "Test prefix must be one of " +++                           "[tests, bugs, network] in " ++ x+++allTests :: FilePath -> TestKind -> [String] -> IO ()+allTests darcs_path k s =+    do test `mapM` repotypes+       return ()+    where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"]+          test x = execTests darcs_path k x s++-------------------------------------------------------+-- Utility functions (FIXME)+-- copy & paste & edit: darcs wants to share these+--++withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory name m =+    bracket+        (do cwd <- getCurrentDirectory+            when (name /= "") (setCurrentDirectory name)+            return cwd)+        (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ()))+        (const m)++cloneTree :: FilePath -> FilePath -> IO ()+cloneTree = cloneTreeExcept []++cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()+cloneTreeExcept except source dest =+ do isdir <- doesDirectoryExist source+    if isdir then do+        createDirectoryIfMissing True dest+        fps <- getDirectoryContents source+        let fps' = filter (`notElem` (".":"..":except)) fps+            mk_source fp = source ++ "/" ++ fp+            mk_dest   fp = dest   ++ "/" ++ fp+        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+     else fail ("cloneTreeExcept: Bad source " ++ source)+   `catch` fail ("cloneTreeExcept: Bad source " ++ source)++cloneSubTree :: FilePath -> FilePath -> IO ()+cloneSubTree source dest =+ do isdir <- doesDirectoryExist source+    isfile <- doesFileExist source+    if isdir then do+        createDirectory dest+        fps <- getDirectoryContents source+        let fps' = filter (`notElem` [".", ".."]) fps+            mk_source fp = source ++ "/" ++ fp+            mk_dest   fp = dest   ++ "/" ++ fp+        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+     else if isfile then do+        cloneFile source dest+     else fail ("cloneSubTree: Bad source "++ source)+    `catch` (\e -> if isDoesNotExistError e+                   then return ()+                   else ioError e)++cloneFile :: FilePath -> FilePath -> IO ()+cloneFile = copyFile++rmRf :: FilePath -> IO ()+rmRf path = do+  isdir <- doesDirectoryExist path+  isf <- doesFileExist path+  when isdir $ removeDirectoryRecursive path+  when isf $ removeFile path+  return ()++-- (END FIXME)++\end{code}
+ bugs/add_permissions.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Darcs should refuse to add an unreadable file, because unreadable+## files aren't recordable.+##+## Copyright (C) 2005  Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++abort_windows                   # does not work on Windows.+rm -rf temp1                    # Another script may have left a mess.+darcs initialize --repodir temp1+touch temp1/unreadable+chmod a-r temp1/unreadable      # Make the file unreadable.+not darcs add --repodir temp1 no_perms.txt 2>temp1/log+fgrep -i 'permission denied' temp1/log+rm -rf temp1
+ bugs/dist-v.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++# tests for "darcs dist"++not () { "$@" && exit 1 || :; }++rm -rf temp1+mkdir temp1+cd temp1+darcs init+# needs fixed on FreeBSD+darcs dist -v 2> log+not grep error log+cd ..++rm -rf temp1+
+ bugs/emailformat.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++# This appears to hang on Windows++set -ev+# TODO: is this really enough to make all commands interpret the given strings +# as latin1?+export LANG="en_US.ISO-8859-1"++rm -rf temp1+rm -rf temp2+mkdir temp1+mkdir temp2+cd temp1++seventysevenaddy="<aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa@bbbbbbbbbb.cccccccccc.abrasoft.com>"++darcs init++echo "Have you seen the smørrebrød of René Çavésant?" > non_ascii_file+darcs add non_ascii_file+darcs record -am "non-ascii file add" -A test++cd ../temp2+darcs init+cd ../temp1++# long email adress: check that email adresses of <= 77 chars don't get split up+darcs send --from="Kjålt Überström $seventysevenaddy" \+           --subject "Un patch pour le répositoire" \+           --to="Un garçon français <garcon@francais.fr>" \+           --sendmail-command='cp /dev/stdin mail_as_file %<' \+           -a ../temp2++cat mail_as_file+# The long mail address should be in there as a whole+grep $seventysevenaddy mail_as_file++# Check that there are no non-ASCII characters in the mail+ghc -e 'getContents >>= return . not . any (> Data.Char.chr 127)' < mail_as_file | grep '^True$'+++cd ..+rm -rf temp1+rm -rf temp2+
+ bugs/issue1013_either_dependency.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+set -ev+export DARCS_EMAIL=test+rm -rf tmp_d1 tmp_d2 tmp_d+# Preparations:+# Set up two repos, each with a patch (d1 and d2 respectively) with both+# an individual change and a change that is identical in both repos,+# and thus auto-merge, i.e., they don't conflict in darcs2.  Pull them+# together and record a patch (problem) on top of the auto-merged change,+# so that it depends on EITHER of two patches.++mkdir tmp_d1; cd tmp_d1+darcs init --darcs-2+echo a > a+echo b > b+echo c > c+darcs rec -alm init+echo a-independent > a+echo c-common > c+darcs rec -am d1+cd ..+darcs get --to-patch init tmp_d1 tmp_d2+cd tmp_d2+echo b-independent > b+echo c-common > c+darcs rec -am d2+darcs pull -a ../tmp_d1+# no conflicts -- c-common is identical+echo c-problem > c+darcs rec -am problem+cd ..++# I want to pull the 'problem' patch, but expect darcs to get confused+# because it doesn't know how to select one of the two dependent patches.++darcs get --to-patch init tmp_d2 tmp_d+cd tmp_d+echo n/n/y |tr / \\012 |darcs pull ../tmp_d2+darcs cha++# This is weird, we got d2 though we said No.  I would have expected+# darcs to skip the 'problem' patch in this case.++# Try to pull d1 and unpull d2.++darcs pull -a ../tmp_d1+exit 1 # darcs hangs here (2.0.2+77)!+echo n/y/d |tr / \\012 |darcs obl -p d2++# The obliterate fails with: patches to commute_to_end does not commutex (1)++cd ..+rm -rf tmp_d1 tmp_d2 tmp_d
+ bugs/issue1014_identical_patches.sh view
@@ -0,0 +1,60 @@+#!/usr/bin/env bash+set -ev++# Set up a base repo. Our experiment will start from this point+mkdir base+cd base+darcs init --darcs-2+printf "Line1\nLine2\nLine3\n" > foo+darcs rec -alm Base+cd ..++# Now we want to record patch A, which will turn "Line2" into "Hello"+darcs get base a+cd a+printf "Line1\nHello\nLine3\n" > foo+darcs rec --ignore-times -am A+cd ..++# Make B the same as A+darcs get base b+cd b+printf "Line1\nHello\nLine3\n" > foo+darcs rec --ignore-times -am B+cd ..++# Now we make a patch C that depends on A+darcs get a ac+cd ac+printf "Line1\nWorld\nLine3\n" > foo+darcs rec --ignore-times -am C+cd ..++# Merge A and B+darcs get a ab+cd ab+darcs pull -a ../b+darcs revert -a+cd ..++# And merge in C too+darcs get ab abc+cd abc+darcs pull -a ../ac+darcs revert -a+cd ..++# Now we can pull just B and C into base+darcs get base bc+cd bc+darcs pull ../abc -ap 'B|C'+cd ..++# Now we have base, B and C in a repository.  At this point we're correct.++# Let's try merging AC with BC now, here we discover a bug.++darcs get ac abc2+cd abc2+darcs pull -a ../bc+
+ bugs/issue1190_unmarked_hunk_replace_conflict.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue1190 - conflicts between HUNK and REPLACE are not+## marked by --mark-conflicts.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf d e                      # Another script may have left a mess.+darcs init    --repo d/+printf %s\\n foo bar baz >d/f+darcs record  --repo d/ -lam f1+darcs get d/ e/+darcs replace --repo e/ --force bar baz f+darcs record  --repo e/ -lam replacement+printf %s\\n foo bar quux >d/f  # replace baz with quux+darcs record  --repo d/ -am f2++## There ought to be a conflict here, and there is.+darcs pull    --repo e/ d/ -a --mark-conflicts+## The file ought to now have conflict markers in it.+grep 'v v v' e/f+rm -rf d/ e/                    # Clean up after ourselves.
+ bugs/issue1196_whatsnew_falsely_lists_all_changes.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++not () { "$@" && exit 1 || :; }++rm -rf temp1+mkdir temp1+cd temp1++darcs init+touch aargh+darcs add aargh+echo utrecht > aargh++darcs wh foo foo/../foo/. > out+cat out+not grep utrecht out++cd ..+rm -rf temp1+
+ bugs/issue1266_init_inside_a_repo.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+## Test for issue1266 - attempting to initialize a repository inside+## another repository should cause a warning, because while perfectly+## legitimate, it is likely to be accidental.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf temp1 out                # Another script may have left a mess.+darcs init --repodir temp1+darcs init --repodir temp1/temp2 2>&1 | tee out+grep -i WARNING out             # A warning should be printed.
+ bugs/issue1327.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash+set -ev++# See issue1327.+# results in the error:+# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452+++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo fileA version 1 > fileA+echo fileB version 1 > fileB+darcs add fileA fileB+darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB"+echo fileA version 2 > fileA+darcs record --author foo@bar --ignore-times --all -m "Modify fileA"+cd ..+darcs get temp1 temp2+cd temp2+darcs obliterate -p "Modify fileA" --all+darcs unrecord -p "Add fileA and fileB" --all+darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA"+cd ../temp1+darcs pull --all ../temp2+echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
+ bugs/issue1337_darcs_changes_false_positives.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1337 - darcs changes shows unrelated patches+## Asking "darcs changes" about an unrecorded file d/f will list the+## patch that creates the parent directory d/ (instead of no patches).+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf temp1+darcs init --repodir temp1+cd temp1+mkdir d+darcs record -lam d d+# We use --match 'touch d/f' instead of simply d/f because the latter+# prints "Changes to d/f:\n" before the count.+test 0 -eq "$(darcs changes --count --match 'touch d/f')"
+ bugs/issue1396_changepref-conflict.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+set -ev++. ../tests/lib++rm -rf temp1 temp1a temp1b++mkdir temp1+cd temp1+darcs init+darcs setpref test 'echo nothing'+darcs record -am 'null pref'+cd ..++darcs get temp1 temp1a+cd temp1a+darcs setpref test 'echo a'+darcs record -am 'pref a'+cd ..++darcs get temp1 temp1b+cd temp1b+darcs setpref test 'echo b'+darcs record -am 'pref b'+cd ..++cd temp1+darcs pull -a ../temp1a --dont-allow-conflicts+not darcs pull -a ../temp1b --dont-allow-conflicts+cd ..++rm -rf temp1 temp1a temp1b
+ bugs/issue1401_bug_in_get_extra.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Test for issue1401 - when two repos share a HUNK patch, but that+## patch's ADDFILE dependency is met by different patches in each+## repo, it becomes impossible to pull between the two repos.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++## This bug only affects darcs-2 repositories.+fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0++rm -rf d e                      # Another script may have left a mess.+darcs initialize --repodir d/+darcs initialize --repodir e/+touch d/f d/g e/f+darcs record     --repodir d/ -lam 'Add f and g'+darcs record     --repodir e/ -lam 'Add f'+echo >d/f+darcs record     --repodir d/ -am 'Change f'+darcs pull       --repodir e/ -a d/+darcs obliterate --repodir e/ -ap 'Add f and g'+darcs pull       --repodir e/ -a d/+rm -rf d/ e/                    # Clean up after ourselves.
+ bugs/issue1406.sh view
@@ -0,0 +1,19 @@+#!/bin/sh+rm -rf temp1+darcs init --repodir temp1++cd temp1++echo "test exit 1" > _darcs/prefs/prefs+echo "name" > _darcs/prefs/author+echo "a" > a+darcs record --look-for-adds --no-test --all --patch-name=p1+echo "b" >> a+echo "y" | darcs amend-record --all --patch=p1++# There should be one patch in the repo+test 1 -eq `darcs changes --count` || exit 1++# Another check: there should be nothing new after a is restored+echo "a" > a+darcs whatsnew -l && exit 1 || exit 0
+ bugs/issue1442_encoding_round-trip.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## -*- coding: utf-8 -*-+## Test for issue1442 - if we disable Darcs escaping and don't change+## our encoding, the bytes in a filename should be the same bytes that+## "darcs changes -v" prints to the right of "addfile" and "hunk".+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib++rm -rf R                        # Another script may have left a mess.++## Use the first UTF-8 locale we can find.+export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1)+export DARCS_DONT_ESCAPE_ANYTHING=True++## If LC_ALL is the empty string, this system doesn't support UTF-8.+if test -z "$LC_ALL"+then exit 1+fi++darcs init      --repo R+echo '首頁 = א₀' >R/'首頁 = א₀'+darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'+darcs changes   --repo R -v '首頁 = א₀' >R/log+#cat R/log                      # Show the humans what the output was.+grep -c '首頁 = א₀' R/log >R/count+echo 5 >R/expected-count+cmp R/count R/expected-count    # Both count files should contain "5\n".+rm -rf R                        # Clean up after ourselves.
+ bugs/issue1461_case_folding.sh view
@@ -0,0 +1,83 @@+#!/usr/bin/env bash+## Test for issue1461 - patches to files whose names only differ by+## case can be wrongly applied to the same file in the working directory.+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf lower upper joint        # Another script may have left a mess.+mkdir lower upper++cd lower+darcs init+cat > a << EOF+1+2+3+EOF+darcs add a+darcs record -am 'lower init a'+cd ..++cd upper+darcs init+cat > A << EOF+1+2+3+EOF+darcs add A+darcs record -am 'upper init A'+cd ..++darcs get lower joint+cd joint+darcs pull -a ../upper+cd ..++cd lower+cat > a << EOF+one lower+2+3+EOF+darcs record -am 'lower modify'+cd ..++cd upper+cat > A << EOF+1+2+three upper+EOF+darcs record -am 'upper modify'+cd ..++cd joint+darcs pull ../lower -a+darcs pull ../upper -a+grep one a && not grep three a+grep three A && not grep one A+cd ..+# clean up after ourselves+rm -rf lower upper joint
+ bugs/issue1473_annotate_repodir.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++. ../tests/lib+rm -rf temp+mkdir temp+cd temp+darcs init+mkdir a b+touch a/a b/b+darcs add --rec .+darcs record -a -m ab -A test+darcs annotate a/a+# annotate --repodir=something '.' should work+cd ..+darcs annotate --repodir temp '.'+cd temp++cd ..+rm -rf temp+
+ bugs/issue27.sh view
@@ -0,0 +1,43 @@+#!/bin/sh++set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+echo first > a+darcs add a+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++echo first > b+darcs add b+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++cd ../temp2+darcs init+darcs pull --all --dont-allow-conflicts ../temp1+echo second >> a+darcs record --pipe --all --patch-name=second <<EOF+Thu Sep 18 22:37:07 MSD 2008+author+EOF++cd ../temp1+echo second >> b+darcs record --pipe --all --patch-name=second <<EOF+Thu Sep 18 22:37:07 MSD 2008+author+EOF++darcs pull --all --dont-allow-conflicts ../temp2+test `darcs changes --count` = "4"+cd ..++rm -rf temp1 temp2
+ bugs/issue390_whatsnew.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory++set -ev++if ! test -x "$(which strace)"+then echo skipping test since strace was not found+     exit+fi++rm -rf temp+mkdir temp+cd temp+darcs init+date > file1+date > file2+darcs add file*+darcs record -am "test"++strace darcs whatsnew file1 &> out+# we should be accessing file1+grep file1 out+# but shouldn't be accessing file2+if grep file2 out+then+    echo A whatsnew for file1 should not involve a 'stat' call to file2+    exit 1+else+    echo Yay.  We pass.+fi++rm -rf temp
+ bugs/issue558_broken_pipe.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash++# For issue588, "amend-record --look-for-adds end up with two "addfile" entries"++set -ev+rm -rf temp1+darcs init --repodir temp1++export EMAIL=me++cd temp1++date > f+darcs add f+darcs rec -am p1+for (( i=0 ; i < 500; i=i+1 )); do+  echo $i >> f;+  darcs rec -am p$i+done++darcs changes 2> err | head++touch correcterr++diff correcterr err++cd ..++rm -rf temp1
+ bugs/issue944_partial_inventory.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++set -ev++test $DARCS || DARCS=$PWD/../darcs+ACTUAL_DARCS=`which $DARCS`+DARCSPATH=`dirname $ACTUAL_DARCS`+PATH="$DARCSPATH:$PATH"+export PATH++# create base repository+rm -rf temp1+mkdir temp1+cd temp1+darcs init++echo first > a+darcs add a+darcs record -am first+darcs tag --checkpoint 'Tag 1'++echo second > b+darcs add b+darcs record -am second+darcs tag --checkpoint 'Tag 2'++echo third > c+darcs add c+darcs record -am third+darcs tag --checkpoint 'Tag 3'++# create a partial copy of the base repository and modify it+cd ..+rm -rf temp2+darcs get --partial temp1 temp2+cd temp2++# instead of the following three commands one could also use darcs optimize+echo mistake > a+darcs record -am mistake+darcs unrecord -ap mistake++# now check the repository+darcs check+# => darcs: failed to read patch: ...+
+ bugs/merging_newlines.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+set -ev++# Note that this is fixed, the lines marked # BUG HERE+# should be moved back into merging_newlines.sh++# trick: requiring something to fail+not () { "$@" && exit 1 || :; }++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+echo "apply allow-conflicts" > _darcs/prefs/defaults+# note: to make this pass, change echo to echo -n+# is that right?+echo "from temp1" > one.txt+darcs add one.txt+darcs record -A bar -am "add one.txt"+echo >> one.txt+darcs wh -u+cd ..++darcs get temp1 temp2+cd temp2+# reality check+darcs show files | grep one.txt+echo "in tmp2" >> one.txt+darcs whatsnew -s | grep M+darcs record -A bar -am "add extra line"+darcs annotate -p . -u+darcs push -av > log+cat log+not grep -i conflicts log+# BUG HERE+# after a conflict, darcs resolve should report a conflict+darcs mark-conflicts > log 2>&1+cat log+not grep -i 'no conflicts' log+cd ..++rm -rf temp1 temp2
+ bugs/newlines.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+echo -n "from temp1" > one.txt+darcs add one.txt+darcs record -A bar -am "add one.txt"+echo >> one.txt+cd ..++darcs get temp1 temp2+cd temp2+echo "in tmp2" >> one.txt+darcs record -A bar -am "add extra line"+lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l`+echo $lines_added+test $lines_added -eq 1+cd ..++rm -rf temp1 temp2
+ bugs/nfs-failure.sh view
@@ -0,0 +1,35 @@+#!/bin/sh++set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo first > a+darcs add a+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++echo first > b+darcs add b+darcs record --pipe --all --patch-name=first <<EOF+Thu Sep 18 22:37:06 MSD 2008+author+EOF++# it seems that somehow the following occasionally fails on an nfs+# filesystem when darcs is compiled with ghc 6.6.++darcs get . ../temp2++# it fails with something like:++# darcs: ./_darcs/patches/20080918223706-f64cd-6b512400a8108808b7ba7057f0eac2adf473b3ae.gz: copyFile: resource busy (file is locked)+++cd ..++rm -rf temp1 temp2
+ bugs/record-scaling.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issueN - darcs record shouldn't access old inventories!+##+## Copyright (C) 2008  David Roundy+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+which strace                    # This test requires strace(1).+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repo.+touch R/a-unique-filename+strace -eopen -oR/trace \+  darcs record  --repo R -lam 'A unique commit message.'+grep a-unique-filename R/trace+grep _darcs/hashed_inventory R/trace+not grep _darcs/inventories/ R/trace+rm -rf R                        # Clean up after ourselves.
+ bugs/time-stamps.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash++# test for broken time stamps++set -ev++. lib.sh++rm -rf temp+mkdir temp+cd temp+darcs init --hashed++echo this is my favorite test > foobar+darcs add foobar+sleep 2 # so the time stamps won't accidentally be identical+darcs record -am 'add foobar'++HASHVAL=0000000025-4cbbfd8ce543076b132b13b60ae06d0189ee80b4d5908abb5e060d331d25eb5c++if test -d _darcs/pristine.hashed;+then+  ls _darcs/pristine.hashed+  test -f _darcs/pristine.hashed/$HASHVAL+  # verify that the modification time of the file in the pristine cache+  # is identical to the modification time of the file in the working+  # directory.+  not test foobar -ot _darcs/pristine.hashed/$HASHVAL+  not test foobar -nt _darcs/pristine.hashed/$HASHVAL+else+  not test foobar -ot _darcs/pristine/foobar+  not test foobar -nt _darcs/pristine/foobar+fi++# Now let's verify that the test actually works...++sleep 1+touch foobar++if test -d _darcs/pristine.hashed;+then+  not test foobar -ot _darcs/pristine.hashed/$HASHVAL+  test foobar -nt _darcs/pristine.hashed/$HASHVAL+else+  not test foobar -ot _darcs/pristine/foobar+  test foobar -nt _darcs/pristine/foobar+fi+++cd ..++rm -rf temp
+ contrib/_darcs.zsh view
@@ -0,0 +1,36 @@+#compdef darcs+## Darcs completion snippet for zsh.+##+## Copyright (C) 2009  Nicolas Pouillard+##+## 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 of the License, 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.++if (($CURRENT == 2)); then+  # We're completing the first word after "darcs" -- the command.+  _wanted command expl 'darcs command' \+    compadd -- $( darcs --commands )+else+  case "${words[$CURRENT]}"; in+    # If it looks like an URL...+    ht*|ft*)+        _arguments '*:URL:_urls'+        ;;+    # If it looks like an explicit path...+    /*|./*|\~*|../*)+        _arguments '*:file:_files'+        ;;+    # Otherwise, let's ask darcs for all possible options+    *)+      _wanted args expl 'arg for darcs command' \+        compadd -- $( darcs ${words[2]} --list-option )+      ;;+  esac+fi
+ contrib/cgi/README.in view
@@ -0,0 +1,42 @@+darcs.cgi is the darcs repository viewer.  It provides a web interface+for viewing darcs repositories, using XSLT to transform darcs' XML+output into XHTML. It is written in perl and is more featureful than+the older haskell cgi program darcs_cgi.lhs (seen in URLs as "darcs").++dependencies++  darcs.cgi requires with the following tools and has been tested with+  the version mentioned:++  darcs-1.0.1           http://www.darcs.net+  libxslt-1.1.6         http://xmlsoft.org/XSLT/+  perl-5.8.0            http://www.perl.com++installation++  1) copy darcs.cgi to your webserver's cgi directory, eg+     /usr/lib/cgi-bin. A symlink probably won't do. Make+     sure it's executable.+  2) copy cgi.conf to @sysconfdir@/darcs/cgi.conf and edit appropriately.+     You can overwrite the cgi.conf used by the old darcs cgi script.+     You probably don't need to change anything here.+  3) copy the xslt directory to @datadir@/darcs/xslt+  4) copy xslt/styles.css to @sysconfdir@/darcs/styles.css++  Test by browsing "http://<host>/cgi-bin/darcs.cgi/".++troubleshooting++  if the configuration is incorrect error messages will be printed to+  the webserver's error log, for example "/var/log/apache/error.log".++  you can also double check the configuration by running darcs.cgi+  from the command line and supplying a --check argument:++     $ ./darcs.cgi --check++character encodings++  if your repositories contain files with characters encoded in+  something other than ASCII or UTF-8, change the 'xml_encoding'+  setting in cgi.conf to the appropriate encoding.
+ contrib/cgi/cgi.conf.in view
@@ -0,0 +1,31 @@+# This is an example for cgi.conf++# reposdir is the directory containing the repositories++reposdir = /var/www/repos++# cachedir is a directory writable by www-data (or whatever user your cgi+# scripts run as) which is used to cache the web pages.++cachedir = /var/cache/darcs++# The following are used by darcs.cgi (not darcs_cgi)+PATH = /bin:/usr/bin:/usr/local/bin++# paths to executables, or just the executables if they are in 'PATH'+#darcs = darcs+#xsltproc = xsltproc++# Path to XSLT templates (default is /usr/local/share/darcs/xslt)+xslt_dir = @datadir@/darcs/xslt++# HTTP request path of the style sheet, the default will magically read +# @sysconfdir@/darcs/styles.css+#stylesheet = /cgi-bin/darcs.cgi/styles.css++css_styles  = @sysconfdir@/darcs/styles.css++# encoding to include in XML declaration.  Set this to the encoding used+# by the files in your repositories.++xml_encoding = UTF-8
+ contrib/cgi/darcs.cgi.in view
@@ -0,0 +1,491 @@+#!/usr/bin/perl -T+#+# darcs.cgi - the darcs repository viewer+#+# Copyright (c) 2004 Will Glozer+#+# Permission is hereby granted, free of charge, to any person obtaining+# a copy of this software and associated documentation files (the+# "Software"), to deal in the Software without restriction, including+# without limitation the rights to use, copy, modify, merge, publish,+# distribute, sublicense, and/or sell copies of the Software, and to+# permit persons to whom the Software is furnished to do so, subject to+# the following conditions+#+# The above copyright notice and this permission notice shall be+# included in all copies or substantial portions of the Software.+#+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+# OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++#+# This program calls darcs (or its own subroutines) to generate XML+# which is rendered into HTML by XSLT.  It is capable of displaying+# the files in a repository, various patch histories, annotations, etc.+#++use strict;++use CGI qw( :standard );+use CGI::Util;+use File::Basename;+use File::stat;+use IO::File;+use POSIX;++## the following variables can be customized to reflect your system+## configuration by defining them appropriately in the file+## "@sysconfdir@/darcs/cgi.conf".  The syntax accepts equals signs or simply+## blanks separating values from assignments.++$ENV{'PATH'} = read_conf('PATH', $ENV{'PATH'});++# path to executables, or just the executable if they are in $ENV{'PATH'}+my $darcs_program    = read_conf("darcs", "darcs");+my $xslt_program     = read_conf("xsltproc", "xsltproc");++# directory containing repositories+my $repository_root  = read_conf("reposdir", "/var/www");++# XSLT template locations+my $template_root = read_conf("xslt_dir", '@datadir@/darcs/xslt');++my $xslt_annotate = "$template_root/annotate.xslt";+my $xslt_browse   = "$template_root/browse.xslt";+my $xslt_patches  = "$template_root/patches.xslt";+my $xslt_repos    = "$template_root/repos.xslt";+my $xslt_rss      = "$template_root/rss.xslt";++my $xslt_errors   = "$template_root/errors.xslt";++# CSS stylesheet that XSLT templates refer to.  This is a HTTP request+# path, not a local file system path. The default will cause darcs.cgi+# to serve the stylesheet rather than the web server.+my $stylesheet = read_conf("stylesheet", "/cgi-bin/darcs.cgi/styles.css");++# location of the CSS stylesheet that darcs.cgi will serve if it+# receives a request for '/styles.css'+my $css_styles = read_conf("css_styles", '@sysconfdir@/darcs/styles.css');++# location of the favicon that darcs.cgi will serve if it+# receives a request for '/[\w\-]+/favicon.ico'+my $favicon = read_conf("favicon", "/cgi-bin/favicon.ico");++# XML source for the error pages+my $xml_errors = "$template_root/errors.xml";++# encoding to include in XML declaration+my $xml_encoding = read_conf("xml_encoding", "UTF-8");++## end customization++# ----------------------------------------------------------------------++# read a value from the cgi.conf file.+{+  my(%conf);++  sub read_conf {+    my ($flag, $val) = @_;+    $val = "" if !defined($val);+    +    if (!%conf && open(CGI_CONF, '@sysconfdir@/darcs/cgi.conf')) {+      while (<CGI_CONF>) {+        chomp;+	next if /^\s*(?:\#.*)?$/;   # Skip blank lines and comment lines+        if (/^\s*(\S+)\s*(?:\=\s*)?(\S+)\s*$/) {+           $conf{$1} = $2;+	   # print "read_conf: $1 = $2\n";+        } else {+           warn "read_conf: $_\n";+        }+      }+      close(CGI_CONF);+    }++    $val = $conf{$flag} if exists($conf{$flag});++    return $val;+  }+}++# open xsltproc to transform and output `xml' with stylesheet file `xslt'+sub transform {+    my ($xslt, $args, $content_type) = @_;++    $| = 1;+    printf "Content-type: %s\r\n\r\n", $content_type || "text/html";+    my $pipe = new IO::File "| $xslt_program $args $xslt -";+    $pipe->autoflush(0);+    return $pipe;+}++sub pristine_dir {+    my ($repo) = @_;+    my $pristine = "current";+    if (! -d "${repository_root}/${repo}/_darcs/$pristine") {+        $pristine = "pristine";+    }+    return "${repository_root}/${repo}/_darcs/$pristine";+}++# begin an XML document with a root element and the repository path+sub make_xml {+    my ($fh, $repo, $dir, $file) = @_;+    my ($full_path, $path) = '/';++    printf $fh qq(<?xml version="1.0" encoding="$xml_encoding"?>\n);++    printf $fh qq(<darcs repository="$repo" target="%s/%s%s">\n),+        $repo, ($dir ? "$dir/" : ''), ($file ? "$file" : '');++    print $fh qq(<path>\n);+    foreach $path (split('/', "$repo/$dir")) {+        $full_path .= "$path/";+        print $fh qq(<directory full-path="$full_path">$path</directory>\n);+    }+    if ($file) {+        print $fh qq(<file full-path="$full_path$file">$file</file>\n) if $file;+    }+    print $fh qq(</path>\n\n);+}++# finish XML output+sub finish_xml {+    my ($fh) = @_;+    print $fh "\n</darcs>\n";+    $fh->flush;+}++# run darcs and wrap the output in an XML document+sub darcs_xml {+    my ($fh, $repo, $cmd, $args, $dir, $file) = @_;++    make_xml($fh, $repo, $dir, $file);++    push(@$args, '--xml-output');+    darcs($fh, $repo, $cmd, $args, $dir, $file);++    finish_xml($fh);+}++# run darcs with output redirected to the specified file handle+sub darcs {+    my ($fh, $repo, $cmd, $args, $dir, $file) = @_;+    my (@darcs_argv) = ($darcs_program, $cmd, @$args);++    # push target only if there is one, otherwise darcs will get an empty param+    if ($dir || $file) {+        push(@darcs_argv, sprintf("%s%s%s", $dir, ($dir ? '/' : ''), $file));+    }++    my($pid) = fork;+    if ($pid) {+	# in the parent process+	my($status) = waitpid($pid, 0);+	die "$darcs_program exited with status $?\n" if $?;+    } elsif(defined($pid)) {+	# in the child process+	open(STDIN, '/dev/null');+	if (defined($fh)) {+	    open(STDOUT, '>&', $fh)+		|| die "can't dup to stdout: $!\n";+	}+	chdir "$repository_root/$repo"+	    || die "chdir: $repository_root/$repo: $!\n";+	exec @darcs_argv;+	die "can't exec ".$darcs_argv[0].": $!\n";+    } else {+	# fork failed+	die "can't fork: $!\n";+    }+}++# get a directory listing as XML output+sub dir_listing {+    my ($fh, $repo, $dir) = @_;+    make_xml($fh, $repo, $dir, '');++    print $fh "<files>\n";+    my $dir_ = pristine_dir ($repo) . "/$dir";+    opendir(DH, $dir_);+    while( defined (my $file_ = readdir(DH)) ) {+        next if $file_ =~ /^\.\.?$/;+        my $file = "$dir_/$file_";+        my $secs  = stat($file)->mtime;+        my $mtime = localtime($secs);+        my $ts = POSIX::strftime("%Y%m%d%H%M%S", gmtime $secs);++        my ($name, $type);++         if (-d $file) {+             ($name, $type) = (basename($file) . '/', 'directory');+         } else {+             ($name, $type) = (basename($file), 'file');+         }+         print $fh qq(  <$type name="$name" modified="$mtime" ts="$ts" />\n);+    }+    closedir(DH);+    print $fh "</files>\n";++    finish_xml($fh);+}++# get a repository listing as XML output+sub repo_listing {+    my($fh) = @_;++    make_xml($fh, "", "", "");++    print $fh "<repositories>\n";+    opendir(DH, $repository_root);+    while( defined (my $name = readdir(DH)) ) {+        next if $name =~ /^\.\.?$/;+        if (-d "$repository_root/$name/_darcs") {+            print $fh qq(  <repository name="$name" />\n);+        }+    }+    closedir(DH);+    print $fh "</repositories>\n";++    finish_xml($fh);+    return $fh;+}++# show an error page+sub show_error {+    my ($type, $code, $message) = @_;+    my $xml;++    # set the xslt processing arguments+    my $xslt_args = qq {+        --stringparam error-type '$type'+        --stringparam stylesheet '$stylesheet'+    };+    $xslt_args =~ s/\s+/ /gm;++    print "Status: $code $message\r\n\r\n";+    system("$xslt_program $xslt_args $xslt_errors $xml_errors");+}++# check if the requested resource has been modified since the client last+# saw it. If not send HTTP status code 304, otherwise set the Last-modified+# and Cache-control headers.+sub is_cached {+    my ($path) = @_;+    my ($stat) = stat($path);++    # stat may fail because the path was renamed or deleted but still referred+    # to by older darcs patches+    if ($stat) {+        my $last_modified = CGI::expires($stat->mtime);++        if (http('If-Modified-Since') eq $last_modified) {+            print("Status: 304 Not Modified\r\n\r\n");+            return 1;+        }++        print("Cache-control: max-age=0, must-revalidate\r\n");+        print("Last-modified: $last_modified\r\n");+    }+    return 0;+}++# safely extract a parameter from the http request.  This applies a regexp+# to the parameter which should group only the appropriate parameter value+sub safe_param {+    my ($param, $regex, $default) = @_;+    my $value = CGI::Util::unescape(param($param));+    return ($value =~ $regex) ? $1 : $default;+}++# common regular expressions for validating passed parameters+my $hash_regex = qr/^([\w\-.]+)$/;+my $path_regex = qr@^([^\\!\$\^&*()\[\]{}<>`|';"?\r\n]+)$@;++# respond to a CGI request+sub respond {+    # untaint the full URL to this CGI+    my $cgi_url = CGI::Util::unescape(url());+    $cgi_url =~ $path_regex or die qq(bad url "$cgi_url");+    $cgi_url = $1;++    # untaint script_name, reasonable to expect only \w, -, /, and . in the name+    my $script_name = CGI::Util::unescape(script_name());+    $script_name =~ qr~^([\w/.\-\~]+)$~ or die qq(bad script_name "$script_name");+    $script_name = $1;++    # untaint simple parameters, which can only have chars matching \w++    my $cmd  = safe_param('c', '^(\w+)$', 'browse');+    my $sort = safe_param('s', '^(\w+)$', '');++    # set the xslt processing arguments+    my $xslt_args = qq {+        --stringparam cgi-program '$script_name'+        --stringparam cgi-url '$cgi_url'+        --stringparam sort-by '$sort'+        --stringparam stylesheet '$stylesheet'+    };+    $xslt_args =~ s/\s+/ /gm;++    my ($path) = CGI::Util::unescape(path_info());+    # don't allow ./ or ../ in paths+    $path =~ s|[.]+/||g;++    # check whether we're asking for styles.css+    if ($path eq '/styles.css') {+        return if is_cached($css_styles);++        open (STYLES_CSS, $css_styles) or die qq(couldn't open "${css_styles}");+        my $size = stat($css_styles)->size;++        print "Content-length: $size\r\n";+        print "Content-type: text/css\r\n\r\n";++        while (<STYLES_CSS>) {+          print $_;+        }+        close (STYLES_CSS);+        return;+    }++    # check whether we're asking for favicon.ico+    if ($path =~ '/[\w\-]+/favicon.ico') {+        return if is_cached($favicon);++        open (FAVICON, $favicon) or die qq(couldn't open "${favicon}");+        my $size = stat($favicon)->size;++        print "Content-length: $size\r\n";+        print "Content-type: image/x-icon\r\n\r\n";++        while (<FAVICON>) {+          print $_;+        }+        close (FAVICON);+        return;+    }++    # when no repository is requested display available repositories+    if (length($path) < 2) {+        my $fh = transform($xslt_repos, $xslt_args);+        repo_listing($fh);+        return;+    }++    # don't allow any shell meta characters in paths+    $path =~ $path_regex or die qq(bad path_info "$path");+    my @path = split('/', substr($1, 1));++    # split the path into a repository, directory, and file+    my ($repo, $dir, $file, @bits) = ('', '', '');+    while (@path > 0) {+        $repo = join('/', @path);+        # check if remaining path elements refer to a repo+        if (-d "${repository_root}/${repo}/_darcs") {+            if (@bits > 1) {+                $dir  = join('/', @bits[0..$#bits - 1]);+            }+            $file = $bits[$#bits];+            # check if last element of path, stored in $file, is really a dir+            if (-d (pristine_dir ($repo) . "/${dir}/${file}")) {+                $dir = ($dir ? "$dir/$file" : $file);+                $file = '';+            }+            last;+        } else {+            $repo = '';+            unshift(@bits, pop @path);+        }+    }++    # make sure the repository exists+    unless ($repo) {+        show_error('invalid-repository', '404', 'Invalid repository');+        return;+    }++    # don't generate output unless the requested path has been+    # modified since the client last saw it.+    return if is_cached(pristine_dir ($repo) . "/$dir/$file");++    # untaint patches and tags. Tags can have arbitrary values, so+    # never pass these unquoted, on pain of pain!+    my $patch = safe_param('p', $hash_regex);+    my $tag   = safe_param('t', '^(.+)$');++    my @darcs_args;+    push(@darcs_args, '--match', "hash $patch") if $patch;+    push(@darcs_args, '-t', $tag) if $tag;++    # process the requested command+    if ($cmd eq 'browse') {+        my $fh = transform($xslt_browse, $xslt_args);+        dir_listing($fh, $repo, $dir);+    } elsif ($cmd eq 'patches') {+        # patches as an option is used to support "--patches"+        if (my $patches = safe_param('patches','^(.+)$')) {+            push @darcs_args, '--patches', $patches;+        }++        my $fh = transform($xslt_patches, $xslt_args);+        darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);+    } elsif ($cmd eq 'annotate') {+        push(@darcs_args, '--summary');++        my $creator_hash  = safe_param('ch', $hash_regex);+        my $original_path = safe_param('o', $path_regex);+        my $fh = transform($xslt_annotate, $xslt_args);++        # use the creator hash and original file name when available so+        # annotations can span renames+        if ($creator_hash ne '' && $original_path ne '') {+            push(@darcs_args, '--creator-hash', $creator_hash);+            darcs_xml($fh, $repo, "annotate", \@darcs_args, '', $original_path);+        } else {+            darcs_xml($fh, $repo, "annotate", \@darcs_args, $dir, $file);+        }+    } elsif ($cmd eq 'diff') {+        push(@darcs_args, '-u');+        print "Content-type: text/plain\r\n\r\n";+        darcs(undef, $repo, "diff", \@darcs_args, $dir, $file);+    } elsif ($cmd eq 'rss') {+        push(@darcs_args, '--last', '25');++        my $fh = transform($xslt_rss, $xslt_args, "application/rss+xml");+        darcs_xml($fh, $repo, "changes", \@darcs_args, $dir, $file);+    } else {+        show_error('invalid-command', '400', 'Invalid command');+    }+}++# run a self-test when the --check argument is supplied+if ($ARGV[0] eq '--check') {+    (read_conf("css_styles", "abc") ne "abc") ||+        die "cannot read config file: $!\n";++    (`$darcs_program`) ||+        die "cannot execute darcs as '$darcs_program': $!\n";+    (`$xslt_program`) ||+        die "cannot execute xstlproc as '$xslt_program': $!\n";++    (-d $repository_root && -r $repository_root) ||+        die "cannot read repository root directory '$repository_root': $!\n";+    (-d $template_root && -r $template_root) ||+        die "cannot read template root directory '$template_root': $!\n";+    (-f $css_styles) ||+        die "cannot read css stylesheet '$css_styles': $!\n";+    (-f $xml_errors) ||+        die "cannot read error messages '$xml_errors': $!\n";++    exit 0;+}++# handle the CGI request+respond();+
+ contrib/cgi/xslt/annotate.xslt view
@@ -0,0 +1,390 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for converting darcs' `annotate` output from XML to XHTML.  This+ template expects the following external variables:++   cgi-program    - path to the CGI executable, to place in links+   sort-by        - field to sort by+   stylesheet     - path to the CSS stylesheet++-->+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">+  <xsl:strip-space elements="*"/>++  <xsl:include href="common.xslt"/>++  <xsl:template match="path">+    <h1 class="target">+        annotations for <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>+    </h1>+  </xsl:template>++  <!-- patch annotate tags -->+  <xsl:template match="/darcs/patch">+    <xsl:call-template name="show-patch-info">+      <xsl:with-param name="patch" select="."/>+      <xsl:with-param name="show-comment" select="true()"/>+      <xsl:with-param name="show-author" select="true()"/>+      <xsl:with-param name="show-date" select="true()"/>+    </xsl:call-template>+  </xsl:template>+  +  <xsl:template match="summary">+    <xsl:variable name="hash" select="../patch/@hash"/>+      +    <table>+      <tr class="annotate">+        <th>file</th>+        <th>change</th>+        <th></th>+        <th></th>+      </tr>++      <xsl:apply-templates/>+    </table>++    <form action="{$command}" method="get">+      <p>+        <input type="submit" name="c" value="diff"/>+        <input type="hidden" name="p" value="{$hash}"/>+      </p>+    </form>+  </xsl:template>+  +  <xsl:template match="modify_file">+    <xsl:variable name="file" select="text()"/>+    <xsl:variable name="hash" select="/darcs/patch/@hash" />+      +    <tr class="modified-file">+      <td><xsl:value-of select="$file"/></td>++      <td class="line-count">+        <xsl:for-each select="added_lines">+          +<xsl:value-of select="@num"/>/+        </xsl:for-each>+        <xsl:for-each select="removed_lines">-<xsl:value-of select="@num"/>+        </xsl:for-each>+        lines+      </td>++      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$file}?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="add_file">+    <xsl:variable name="file" select="text()"/>+    <xsl:variable name="hash" select="/darcs/patch/@hash" />+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$file"/></td>+      <td>added file</td>+      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$file}?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="move">+    <xsl:variable name="file" select="@to"/>+    <xsl:variable name="old-file" select="@from"/>    +    <xsl:variable name="hash" select="/darcs/patch/@hash" />+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$file"/></td>+      <td>moved from <xsl:value-of select="$old-file"/></td>+      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$file}?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="remove_file">+    <xsl:variable name="file" select="text()"/>+    <xsl:variable name="hash" select="/darcs/patch/@hash" />+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$file"/></td>+      <td>removed file</td>+      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$file}?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="add_directory">+    <xsl:variable name="dir" select="text()"/>+    <xsl:variable name="hash" select="/darcs/patch/@hash" />+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$dir"/></td>+      <td>added directory</td>+      <td><a href="{$command}{$dir}/?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$dir}/?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="remove_directory">+    <xsl:variable name="dir" select="text()"/>+    <xsl:variable name="hash" select="/darcs/patch/@hash" />+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$dir"/></td>+      <td>removed directory</td>+      <td><a href="{$command}{$dir}/?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$dir}/?c=patches">patches</a></td>+    </tr>+  </xsl:template>+  +  <!-- directory annotate templates -->+  <xsl:template match="/darcs/directory">+    <xsl:call-template name="show-patch-info">+      <xsl:with-param name="patch" select="modified/patch"/>+    </xsl:call-template>++    <table>+      <tr class="annotate">+        <th>file</th>+        <th>change</th>+        <th></th>+        <th></th>+      </tr>++      <xsl:apply-templates/>+    </table>+  </xsl:template>+  +  <xsl:template match="directory/modified/modified_how">+    <xsl:variable name="hash" select="../patch/@hash" />+    <xsl:variable name="how" select="substring(text(), 0, 10)"/>+    <xsl:variable name="target" select="/darcs/@target"/>++    <!--+      annotating a directory outputs the directory itself as well as+      any contents.  this ugly code checks if the matching element is+      the original directory so that the 'annotate' and 'patch' links+      don't append the directory twice.+    -->+    <xsl:variable name="last" select="//darcs/path/directory[last()]"/>+    <xsl:variable name="name" select="../../@name"/>+    <xsl:variable name="dir">+      <xsl:choose>+        <xsl:when test="$last = $name"></xsl:when>+        <xsl:otherwise><xsl:value-of select="$name"/>/</xsl:otherwise>+      </xsl:choose>+    </xsl:variable>++    <tr class="add-remove-file">+      <td><xsl:value-of select="$name"/></td>+      <td>+        <xsl:choose>+          <xsl:when test="$how = 'Dir added'">added directory</xsl:when>+          <xsl:when test="$how = 'Dir moved'">moved directory</xsl:when>+          <xsl:when test="$how = 'Dir remov'">removed directory</xsl:when>+        </xsl:choose>+      </td>+      <td>+        <a href="{$command}{$dir}?c=annotate&amp;p={$hash}">annotate</a>+      </td>+      <td><a href="{$command}{$dir}?c=patches">patches</a></td>+    </tr>+  </xsl:template>++  <xsl:template match="directory/file/modified/modified_how">+    <xsl:variable name="file" select="../../@name"/>+    <xsl:variable name="hash" select="../patch/@hash" />+    <xsl:variable name="how" select="substring(text(), 0, 11)"/>+    +    <tr class="add-remove-file">+      <td><xsl:value-of select="$file"/></td>+      <td>+        <xsl:choose>+          <xsl:when test="$how = 'File added'">added file</xsl:when>+          <xsl:when test="$how = 'File moved'">moved file</xsl:when>+          <xsl:when test="$how = 'File remov'">removed file</xsl:when>+        </xsl:choose>+      </td>+      <td><a href="{$command}{$file}?c=annotate&amp;p={$hash}">annotate</a></td>+      <td><a href="{$command}{$file}?c=patches">patches</a></td>+    </tr>+  </xsl:template>+   +  <!-- file annotate templates -->+  <xsl:template match="/darcs/file">+    <xsl:variable name="modified_how" select="modified/modified_how/text()"/>+    +    <xsl:call-template name="show-patch-info">+      <xsl:with-param name="patch" select="modified/patch"/>+    </xsl:call-template>++    <!-- don't display table of changes when file's contents are modified -->+    <xsl:if test="$modified_how != 'File modified'">+      <xsl:variable name="file" select="@name"/>+      <xsl:variable name="how" select="substring($modified_how, 0, 11)"/>++      <xsl:variable name="annotate-href">+        <xsl:call-template name="make-annotate-href">+          <xsl:with-param name="hash" select="modified/patch/@hash"/>+        </xsl:call-template>+      </xsl:variable>+      +      <table>+        <tr class="annotate">+          <th>file</th>+          <th>change</th>+          <th></th>+          <th></th>+        </tr>++        <tr class="add-remove-file">+          <td><xsl:value-of select="$file"/></td>+          <td>+            <xsl:choose>+              <xsl:when test="$how = 'File added'">added file</xsl:when>+              <xsl:when test="$how = 'File moved'">moved file</xsl:when>+              <xsl:when test="$how = 'File remov'">removed file</xsl:when>+            </xsl:choose>+          </td>+          <td><a href="{$annotate-href}">annotate</a></td>+          <td><a href="{$command}?c=patches">patches</a></td>+        </tr>+      </table>+    </xsl:if>++    <!-- the empty <p/> element is a Konqueror bug workaround -->+    <pre xml:space="preserve"><p/>+      <xsl:apply-templates/>+    </pre>+  </xsl:template>+  +  <xsl:template match="added_line">+    <xsl:variable name="annotate-href">+      <xsl:call-template name="make-annotate-href">+        <xsl:with-param name="hash" select="preceding::modified/patch/@hash"/>+      </xsl:call-template>+    </xsl:variable>++    <xsl:variable name="annotate-name" select="preceding::modified/patch/name"/>+    <xsl:variable name="author" select="preceding::modified/patch/@author"/>+    +    <a class="added-line" href="{$annotate-href}" title="added with '{$annotate-name}' by '{$author}'">+      <pre><xsl:value-of select="text()"/></pre>+    </a>+    <xsl:call-template name="check-removed-by"/>+  </xsl:template>++  <xsl:template match="normal_line">+    <xsl:variable name="annotate-href">+      <xsl:call-template name="make-annotate-href">+        <xsl:with-param name="hash" select="*/patch/@hash"/>+      </xsl:call-template>+    </xsl:variable>++    <xsl:variable name="annotate-name" select="*/patch/name"/>+    <xsl:variable name="author" select="*/patch/@author"/>++    <a class="normal-line" href="{$annotate-href}" title="last changed with '{$annotate-name}' by '{$author}'">+      <pre><xsl:value-of select="text()"/></pre>+    </a>+    <xsl:call-template name="check-removed-by"/>+  </xsl:template>++  <xsl:template match="removed_line">+    <xsl:variable name="annotate-href">+      <xsl:call-template name="make-annotate-href">+        <xsl:with-param name="hash" select="*/patch/@hash"/>+      </xsl:call-template>+    </xsl:variable>++    <xsl:variable name="annotate-name" select="*/patch/name"/>+    <xsl:variable name="author" select="*/patch/@author"/>+    +    <!-- don't display removed lines when a file is removed -->+    <xsl:if test="../modified/modified_how/text() != 'File removed'">+      +        <a class="removed-line" href="{$annotate-href}" title="removed with '{$annotate-name}' by '{$author}'">+        <pre><xsl:value-of select="text()"/></pre>+      </a>+      <xsl:call-template name="check-removed-by"/>+    </xsl:if>+  </xsl:template>++  <xsl:template name="check-removed-by">+    <xsl:variable name="hash" select="removed_by/patch/@hash"/>+    +    <xsl:variable name="annotate-href">+      <xsl:call-template name="make-annotate-href">+        <xsl:with-param name="hash" select="$hash"/>+      </xsl:call-template>+    </xsl:variable>+    +    <xsl:choose>+      <xsl:when test="$hash != ''">+        <a class="removed-by" href="{$annotate-href}">-</a>+      </xsl:when>+    </xsl:choose>++    <!-- put a newline after the hyperlink -->      +    <xsl:text xml:space="preserve">+    </xsl:text>+  </xsl:template>++  <xsl:template name="show-patch-info">+    <xsl:param name="patch"/>+    <xsl:param name="show-comment"/>+    <xsl:param name="show-author"/>+    <xsl:param name="show-date"/>+    +    <xsl:variable name="hash" select="$patch/@hash"/>+    <xsl:variable name="name" select="$patch/name"/>+    <xsl:variable name="author" select="$patch/@author"/>+    <xsl:variable name="local_date" select="$patch/@local_date"/>+    +    <h2 class="patch">+      patch "<span class="path">+      <a href="{$cgi-program}/{$repo}/?c=annotate&amp;p={$hash}">+        <xsl:value-of select="$name"/>+      </a>+      </span>"+    </h2>++    <xsl:if test="$show-comment">+        <xsl:if test="$patch/comment">+          <h2 class="patch">+            comment "<span class="comment">+            <xsl:value-of select="$patch/comment"/>+            </span>"+            </h2>+        </xsl:if>+        </xsl:if>++      <xsl:if test="$show-author"> +          <h2 class="author">+        by <span class="author">+        <xsl:value-of select="$patch/@author"/>+        </span>++      <xsl:if test="$show-date"> +        on <span class="local_date">+        <xsl:value-of select="$patch/@local_date"/>+        </span>+    </xsl:if>+    </h2>+    </xsl:if>++  </xsl:template>++  <xsl:template name="make-annotate-href" xml:space="default">+    <xsl:param name="hash"/>++    <xsl:variable name="created-as" select="/darcs/*/created_as"/>+    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>+    <xsl:variable name="original-name" select="$created-as/@original_name"/>+    +    <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>&amp;ch=<xsl:value-of select="$creator-hash"/>&amp;o=<xsl:value-of select="$original-name"/>+  </xsl:template>++  <!-- ignore <name>, <comment> and <modified_how> children -->+  <xsl:template match="name"/>+  <xsl:template match="comment"/>+  <xsl:template match="author"/>+  <xsl:template match="modified_how"/>+</xsl:stylesheet>
+ contrib/cgi/xslt/browse.xslt view
@@ -0,0 +1,110 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for converting a darcs current/ directory listing from XML to+ XHTML.  This template expects the following external variables:++   cgi-program    - path to the CGI executable, to place in links+   sort-by        - field to sort by+   stylesheet     - path to the CSS stylesheet++ the input XML must have the following structure, aside from what common.xslt+ expects:++ <files>+   <directory name="" modified=""/>+   <file name="" modified=""/>+ </files>+-->+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">+  <xsl:include href="common.xslt"/>++  <xsl:template match="path">+    <h1 class="target">+      files in <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>+    </h1>+  </xsl:template>+  +  <xsl:template match="files">+    <table>+      <tr class="browse">+        <th>+          <a class="sort" href="{$command}?c=browse&amp;s=name">name</a>+          <a class="revsort" href="{$command}?c=browse&amp;s=revname"> (rev)</a>+        </th>+        <th>+          <a class="sort" href="{$command}?c=browse&amp;s=ts">modified</a>+          <a class="revsort" href="{$command}?c=browse&amp;s=revts"> (rev)</a>+        </th>+        <th></th>+        <th></th>+      </tr>+      +      <xsl:choose>+        <xsl:when test="$sort-by = 'ts'">+          <xsl:apply-templates>+            <xsl:sort select="name(self::node())"/>+            <xsl:sort select="@ts"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'revts'">+          <xsl:apply-templates>+            <xsl:sort select="name(self::node())"/>+            <xsl:sort select="@ts" order="descending"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'name'">+          <xsl:apply-templates>+            <xsl:sort select="name(self::node())"/>+            <xsl:sort select="@name"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'revname'">+          <xsl:apply-templates>+            <xsl:sort select="name(self::node())"/>+            <xsl:sort select="@name" order="descending"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:otherwise>+          <xsl:apply-templates>+            <xsl:sort select="name(self::node())"/>+            <xsl:sort select="@name"/>+          </xsl:apply-templates>+        </xsl:otherwise>+      </xsl:choose>+    </table>+  </xsl:template>+  +  <xsl:template match="directory">+    <xsl:variable name="name" select="@name"/>+    <xsl:variable name="type" select="@type"/>+    +    <tr class="directory">+      <td>+        <a href="{$command}{$name}?c=browse"><xsl:value-of select="@name"/></a>+      </td>+      <td><xsl:value-of select="@modified"/></td>+      <td>+        <a href="{$command}{$name}?c=annotate">annotate</a>+      </td>+      <td>+        <a href="{$command}{$name}?c=patches">patches</a>+      </td>+    </tr>++    <xsl:apply-templates/>+  </xsl:template>++  <xsl:template match="file">+    <xsl:variable name="name" select="@name"/>+    +    <tr class="file">+      <td><xsl:value-of select="@name"/></td>+      <td><xsl:value-of select="@modified"/></td>+      <td><a href="{$command}{$name}?c=annotate">annotate</a></td>+      <td><a href="{$command}{$name}?c=patches">patches</a></td>+    </tr>++    <xsl:apply-templates/>+  </xsl:template>+</xsl:stylesheet>
+ contrib/cgi/xslt/common.xslt view
@@ -0,0 +1,66 @@+<!--+ templates fragments shared by all templates.  This template expects+ the following external variables:++   cgi-program    - path to the CGI executable, to place in links+   stylesheet     - path to the CSS stylesheet++ the input XML must have the following structure, plus any elements+ that are not common to all templates:++ <darcs repository="">+   <path>+     <element full-path=""></element>+   </path>++   ...+ + </darcs>+-->+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">+  <xsl:variable name="command">+    <xsl:value-of select="$cgi-program"/>/<xsl:value-of select="/darcs/@target"/>+  </xsl:variable>++  <xsl:variable name="repo" select="/darcs/@repository"/>+  +  <xsl:template match="/darcs">+    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">+      <head>+        <title>darcs repository</title>+        <link rel="stylesheet" href="{$stylesheet}"/>+        <link rel="alternate" type="application/rss+xml" title="RSS 2.0" href="{$command}?c=rss" />+      </head>++      <body>+        <xsl:apply-templates/>++        <form action="{$command}" method="get">+          <p>+            <input class="patches" type="submit" name="c" value="patches"/>+            +            <a href="{$command}?c=rss">rss</a>+            +            <span class="version">+              <a class="home" href="http://darcs.net/">darcs.cgi</a>+              v1.0+            </span>+          </p>+        </form>+      </body>+    </html>+  </xsl:template>++  <xsl:template match="path/directory">+    <xsl:variable name="full-path"  select="@full-path"/>+    +    <a href="{$cgi-program}{$full-path}?c=browse">+      <xsl:apply-templates/>+    </a> /+  </xsl:template>++  <xsl:template match="path/file">+    <xsl:apply-templates/>+  </xsl:template>+  +</xsl:stylesheet>
+ contrib/cgi/xslt/errors.xml view
@@ -0,0 +1,22 @@+<!--+  HTML templates for all potential error pages.  Each <error> element+  should contain all of the HTML <body> content to be output if that+  error occurs+-->+<errors>+  <error type="invalid-command" title="Invalid command">+    <h1>Invalid command</h1>++    <p>+      The requested command is invalid.+    </p>+  </error>++  <error type="invalid-repository" title="Invalid repository">+    <h1>Invalid repository</h1>++    <p>+      The requested repository does not exist on this server.+    </p>+  </error>+</errors>
+ contrib/cgi/xslt/errors.xslt view
@@ -0,0 +1,36 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for converting selected content of errors.xml XML to XHTML. This+ template expects the following external variables:++   error-type     - the type of error+   stylesheet     - path to the CSS stylesheet++ the input XML must have the following structure++ <errors>+   <error type="" title="">+     ...+   </error>+ </errors>+-->+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">+  <xsl:template match="error[@type = $error-type]">+    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">+      <head>+        <title>+          <xsl:value-of select="@title"/>+        </title>+        <link rel="stylesheet" href="{$stylesheet}"/>+      </head>++      <body>+        <xsl:copy-of select="*"/>+      </body>+    </html>+  </xsl:template>++  <!-- ignore errors that don't match -->+  <xsl:template match="error"/>+</xsl:stylesheet>
+ contrib/cgi/xslt/patches.xslt view
@@ -0,0 +1,125 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for converting darcs' `changes` output from XML to XHTML.  This+ template expects the following external variables:++   cgi-program    - path to the CGI executable, to place in links+   sort-by        - field to sort by+   stylesheet     - path to the CSS stylesheet++ the input XML must have the following structure, aside from what common.xslt+ expects:++ <changelog>+   <patch author="" date="" localdate="" inverted="" hash="">+     <name></name>+   </patch>+ </changelog>+-->+<xsl:stylesheet version="1.0"+                xmlns:xsl="http://www.w3.org/1999/XSL/Transform"+                xmlns:str="http://exslt.org/strings">+  +  <xsl:include href="common.xslt"/>++  <xsl:template match="path">+    <h1 class="target">+      patches applied to <span class="path"><a href="{$cgi-program}">projects</a></span> / <span class="path"><xsl:apply-templates/></span>+    </h1>+  </xsl:template>+  +  +  <xsl:template match="changelog">+    <table>+      <tr class="patches">+        <th>+          <a class="sort" href="{$command}?c=patches&amp;s=name">name</a>+          <a class="revsort" href="{$command}?c=patches&amp;s=revname"> (rev)</a>+        </th>+        <th>+          <a class="sort" href="{$command}?c=patches&amp;s=date">date</a>+          <a class="revsort" href="{$command}?c=patches&amp;s=revdate"> (rev)</a>+        </th>+        <th>+          <a class="sort" href="{$command}?c=patches&amp;s=author">author</a>+          <a class="revsort" href="{$command}?c=patches&amp;s=revauthor"> (rev)</a>+        </th>+        <th>+        </th>+      </tr>++      <xsl:choose>+        <xsl:when test="$sort-by = 'name'">+          <xsl:apply-templates>+            <xsl:sort select="name"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'revname'">+          <xsl:apply-templates>+            <xsl:sort select="name" order="descending"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'date'">+          <xsl:apply-templates>+            <xsl:sort select="@date"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'revdate'">+          <xsl:apply-templates>+            <xsl:sort select="@date" order="descending"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'author'">+          <xsl:apply-templates>+            <xsl:sort select="@author"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:when test="$sort-by = 'revauthor'">+          <xsl:apply-templates>+            <xsl:sort select="@author" order="descending"/>+          </xsl:apply-templates>+        </xsl:when>+        <xsl:otherwise>+          <!-- use the repository's natural order -->+          <xsl:apply-templates/>+        </xsl:otherwise>+      </xsl:choose>+    </table>+  </xsl:template>++  <xsl:template match="patch">+    <xsl:variable name="author" select="@author"/>+    <xsl:variable name="hash"   select="@hash"/>+    <xsl:variable name="name"   select="name"/>+    <xsl:variable name="repo"   select="/darcs/@repository"/>++    <xsl:variable name="created-as" select="/darcs/changelog/created_as"/>+    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>+    <xsl:variable name="original-name" select="$created-as/@original_name"/>++    <xsl:variable name="annotate-href">+      <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>++      <xsl:if test="$creator-hash">&amp;ch=<xsl:value-of select="$creator-hash"/></xsl:if>+      <xsl:if test="$original-name">&amp;o=<xsl:value-of select="$original-name"/></xsl:if>+    </xsl:variable>+    +    <tr class="patch">+      <td><a href="{$annotate-href}"><xsl:value-of select="name"/></a></td>+      <td><xsl:value-of select="@local_date"/></td>+      <td>+        <a href="mailto:{$author}"><xsl:value-of select="$author"/></a>+      </td>+      <td>+        <a href="{$cgi-program}/{$repo}/?c=annotate&amp;p={$hash}">detail</a>+      </td>+    </tr>+    <xsl:apply-templates/>+  </xsl:template>++  <!-- ignore <created_as>, <name> and <comment> children of <patch> -->+  <xsl:template match="created_as"/>+  <xsl:template match="name"/>+  <xsl:template match="comment"/>+</xsl:stylesheet>
+ contrib/cgi/xslt/repos.xslt view
@@ -0,0 +1,59 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for displaying a list of available repositories, used when a+ CGI request has no repository path information.  This template expects+ the following external variables:++   cgi-program    - path to the CGI executable, to place in links+   stylesheet     - path to the CSS stylesheet++ the input XML must have the following structure:++ <darcs repository="">+   <repositories>+     <repository name=""/>+   </repositories>+ </darcs>+-->+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">+  <xsl:variable name="command">+    <xsl:value-of select="$cgi-program"/>/<xsl:value-of select="/darcs/@target"/>+  </xsl:variable>+  +  <xsl:template match="/darcs">+    <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">+      <head>+        <title>darcs repository viewer</title>+        <link rel="stylesheet" href="{$stylesheet}"/>+      </head>++      <body>+        <h1 class="target">Available Repositories</h1>++        <table>+          <xsl:apply-templates/>+        </table>+      </body>+    </html>+  </xsl:template>++  <xsl:template match="repositories">+    <xsl:apply-templates>+      <xsl:sort select="name(self::node())"/>+      <xsl:sort select="@name"/>+    </xsl:apply-templates>+  </xsl:template>++  <xsl:template match="repositories/repository">+    <xsl:variable name="repository"  select="@name"/>++    <tr>+      <td>+        <a href="{$cgi-program}/{$repository}/?c=browse">+          <xsl:value-of select="$repository"/>+        </a>+      </td>+    </tr>+  </xsl:template>+</xsl:stylesheet>
+ contrib/cgi/xslt/rss.xslt view
@@ -0,0 +1,92 @@+<?xml version="1.0" encoding="utf-8"?>++<!--+ template for converting darcs' `changes` output from XML to RSS.  This+ template expects the following external variables:++   cgi-url    - full URL to the CGI executable, to place in links++ the input XML must have the following structure:++ <darcs repository="">+   <changelog>+     <patch author="" date="" localdate="" inverted="" hash="">+       <name></name>+       <comment></comment>+     </patch>+   </changelog>+ </darcs>+-->+<xsl:stylesheet version="1.0"+                exclude-result-prefixes="str"+                xmlns:xsl="http://www.w3.org/1999/XSL/Transform"+                xmlns:str="http://exslt.org/strings">++  <xsl:variable name="repo" select="/darcs/@repository"/>++  <xsl:variable name="command">+    <xsl:value-of select="$cgi-url"/>/<xsl:value-of select="/darcs/@target"/>+  </xsl:variable>++  <xsl:template match="changelog">+    <rss version="2.0">+      <channel>+        <title>changes to <xsl:value-of select="$repo"/></title>+        <link><xsl:value-of select="$command"/></link>+        <description>+          Recent patches applied to the darcs repository named+          "<xsl:value-of select='$repo'/>".+        </description>++        <xsl:apply-templates>+          <xsl:sort select="@date"/>+        </xsl:apply-templates>+      </channel>+    </rss>+  </xsl:template>++  <xsl:template match="patch">+    <xsl:variable name="hash"       select="@hash"/>++    <xsl:variable name="created-as" select="/darcs/changelog/created_as"/>+    <xsl:variable name="creator-hash" select="$created-as/patch/@hash"/>+    <xsl:variable name="original-name" select="$created-as/@original_name"/>++    <xsl:variable name="annotate-href">+      <xsl:value-of select="$command"/>?c=annotate&amp;p=<xsl:value-of select="$hash"/>++      <xsl:if test="$creator-hash">&amp;ch=<xsl:value-of select="$creator-hash"/></xsl:if>+      <xsl:if test="$original-name">&amp;o=<xsl:value-of select="$original-name"/></xsl:if>+    </xsl:variable>++    <xsl:variable name="date-nodes" select="str:tokenize(@local_date, ' ')"/>+    <xsl:variable name="rfc-date">+      <xsl:value-of select="$date-nodes[1]"/>+      <xsl:value-of select="', '"/>+      <xsl:if test="$date-nodes[3] &lt; 10">0</xsl:if>+      <xsl:value-of select="$date-nodes[3]"/>+      <xsl:value-of select="' '"/>+      <xsl:value-of select="$date-nodes[2]"/>+      <xsl:value-of select="' '"/>+      <xsl:value-of select="$date-nodes[6]"/>+      <xsl:value-of select="' '"/>+      <xsl:value-of select="$date-nodes[4]"/>+      <xsl:value-of select="' '"/>+      <xsl:value-of select="$date-nodes[5]"/>+    </xsl:variable>++    <item>+      <title><xsl:value-of select="name"/></title>+      <link><xsl:value-of select="$annotate-href"/></link>+      <author><xsl:value-of select="@author"/></author>+      <description><xsl:value-of select="comment"/></description>+      <pubDate><xsl:value-of select="$rfc-date"/></pubDate>+    </item>+  </xsl:template>++  <!-- ignore <path> <created_as>, <name> and <comment> children of <patch> -->+  <xsl:template match="path"/>+  <xsl:template match="created_as"/>+  <xsl:template match="name"/>+  <xsl:template match="comment"/>+</xsl:stylesheet>
+ contrib/cgi/xslt/styles.css view
@@ -0,0 +1,91 @@+/**+ stylesheet for darcs repository browser+**/++a:link, a:visited {+  color: blue;+  text-decoration: none;+}++a:hover { text-decoration: underline; }+a.sort  { color: black; }+a.revsort  { +  color: black;+  font-size: 75%;+}+a.home  { color: #9292C9; }++body { margin: 10px 10px 10px 10px; }++h1.target {+  font-size: 150%;+  font-weight: bold;+}++h2.patch {+  font-size: 125%;+  font-weight: bold;+  margin-top: -10px;+  padding-left: 10px;+}++h2.author {+  font-size: smaller;+  margin-top: -10px;+  font-weight: bold;+  padding-left: 30px;+}++input.patches {  margin-right: 20px; }+label.tag     {  margin-right: 5px; }++span.path, span.path > a { color: #2A2A6B; }++span.version {+  color: #9292C9;  +  margin-left: 75px;+}++span.comment {+  color: #2A2A6B;+  white-space: pre;+}++th,td {+  text-align: left;+  padding: 5px 10px 5px 10px;  +}++tr.annotate { background-color: #FFAAAA; }+tr.browse { background-color: #FFFF99; }+tr.patches { background-color: #AAFFAA; }+tr.directory { background-color: #CFCFCF; }+tr.file, tr.patch, tr.modified-file { background-color: #DCDCDA; }+tr.modified-file, tr.add-remove-file { background-color: #DCDCDA; }++pre {+    margin: 0 0 0 0;+}++a.added-line {+    color: #00AA00;+    float: left;+}++a.normal-line {+    color: #000000;+    float: left;+}++a.removed-line {+    color: #CC0000;+    float: left;+    text-decoration: line-through;+}++a.removed-by {+    clear: right;+    color: #CC0000;+    float: right;+    font-size: 125%;+}
+ contrib/cygwin-wrapper.bash view
@@ -0,0 +1,263 @@+#! /bin/bash++DIRNAME=`dirname "${0}"`+if [ "${DIRNAME:0:1}" = "/" ] ; then+ DARCSPACKAGEDIR="${DIRNAME}"+else+ DARCSPACKAGEDIR="${PWD}/${DIRNAME}"+fi++# If the DARCSPACKAGEDIR assignment above doesn't work for some funny reason, +# you could set these variables by hand.  Or fix the script to work +# automatically and submit a patch.++# Should be set to the full Cygwin path to the directory containing the +# putty executables.+putty_binary_dir="${DARCSPACKAGEDIR}"+# Should be set to the full Cygwin path to the directory containing the +# Windows binary "darcs.exe".+darcs_binary_dir="$putty_binary_dir"+# Should be set to the full Cygwin path to the Windows binary+# "darcs.exe".+darcs_binary="${darcs_binary_dir}/realdarcs.exe"++#---------------------------------------------------------------------+# Darcs Wrapper for Cygwin+#+# A Bash script that allows Cywin paths on the command line when using+# a version of Darcs compiled for Windows.  Darcs will still use still+# Windows paths internally.+#+#---------------------------------------------------------------------+# Usage+# +# Edit this file and set the variables above.  Then, rename this +# script to "darcs" and put it in your PATH somewhere before the +# original binary.+#+# Darcs needs to launch itself for some operations and so the original+# binary needs to be in your Windows PATH.  Do not rename it.+#+#---------------------------------------------------------------------+# Known Issues+#+# This script is just a stopgap measure.  Things don't work perfectly.+# We really need a Cygwin build of Darcs.+#+# No path conversion is performed on:+#    - Any preferences set with "setpref"+#    - The "COMMAND" argument to "darcs trackdown"+#+# When Darcs launches external programs, it uses a Windows system call+# to do so.  This means you may not be able to run "hash bang" scripts+# directly.  For example, to run the Bash script "myscript", you'll+# have to tell Darcs to run "bash myscript".+#+# --------------------------------------------------------------------+++PATH="$putty_binary_dir:$darcs_binary_dir:${PATH}"++debug=false++cmd="$1"++# Print each argument to stderr on a separate line.  Then exit.+function die() {+   local line+   for line in "$@"; do+      echo "$line" > /dev/stderr+   done+   exit 2+}++# Make sure 'darcs_binary_dir' is set.+if [ ! -d "$darcs_binary_dir" ]; then+   die "Please edit this script and set the 'darcs_binary_dir' variable" \+       "to refer to a valid directory." \+       "      script path = '$0'"  \+       "     darcs_binary_dir = '$darcs_binary_dir'"+fi++# Special case for when the first argument is an option.+if expr match "$cmd" '-' > /dev/null; then+   if $debug; then+      # echo "SIMPLE CASE:"+      for arg in "$@"; do+         echo "  arg = '$arg'"+      done+   else+      # echo about to exec -a darcs "$darcs_binary" "$@"+      exec -a darcs "$darcs_binary" "$@"+   fi+fi++# Shift off the darcs command name+shift++function is_opaque_opt() {+   local opt+   for opt in "${opaque_binary_opts[@]}"; do+      if [ "$opt" == "$1" ]; then+         return 0+      fi+   done+   return 1+}++function is_file_opt() {+   local opt+   for opt in "${file_binary_opts[@]}"; do+      if [ "$opt" == "$1" ]; then+         return 0+      fi+   done+   return 1+}++# Options are not dealt with in a command-specific way.  AFAIK, Darcs+# doesn't use the same option in two different ways, so we should be+# fine.++# List of "opaque" binary options.  These are options where we don't+# treat the option argument like a file.+declare -a opaque_binary_opts=( \+   '--repo-name' \+   '--to-match' '--to-patch' '--to-tag' \+   '--from-match' '--from-patch' '--from-tag' \+   '-t' '--tag' '--tags' '--tag-name' \+   '-p' '--patch' '--patches' \+   '-m' '--patch-name' \+   '--matches' '--match' \+   '--token-chars' \+   '-A' '--author' '--from' '--to' '--cc' \+   '--sign-as' '--creator-hash' \+   '--last' '--diff-opts' \+   '-d' '--dist-name' \+   '--log-file' \+   '--apply-as' \+   )++# List of binary options that take file arguments that need to be converted.+declare -a file_binary_opts=( \+   '--repodir' '--repo' '--sibling' \+   '--context' \+   '--logfile' '-o' '--output' \+   '--external-merge' \+   '--sign-ssl' '--verify' '--verify-ssl' \+   )++# --------------------------------------------------------------------+# The three command categories.  We only use the first one, but the+# others are listed to make sure we've covered everything.  Luckily,+# there aren't any commands that have some args that need to be+# converted and some that don't.++# Commands whose arguments are file paths that need to be translated.+cmds_convert_nonoption_args='|get|put|pull|push|send|apply'++# Commands who's arguments should be left alone.  File paths that+# refer to files in the repo should NOT be converted because they+# are relative paths, which Darcs will handle just fine.  Cygwin+# sometimes makes them absolute paths, which confuses Darcs.+#cmds_no_convert_nonoption_paths='|add|remove|mv|replace|record|whatsnew|changes|setpref|trackdown|amend-record|revert|diff|annotate'++# Commands that don't accept non-option arguments+#cmds_no_nonoption_args='|initialize|tag|check|optimize|rollback|unrecord|unpull|resolve|dist|repair'++# See if we need to convert the non-option args for the current+# command.  This matches some prefix of one of the commands in the+# list.  The match may not be unambiguous, we can rely on Darcs to+# deal with that correctly.+if expr match "$cmds_convert_nonoption_args" ".*|$cmd" > /dev/null; then+   convert_nonoption_args=true+else+   convert_nonoption_args=false+fi++function convert_path() {+   # echo "converting path ${*} ..." >> /tmp/log+   if expr match "$1" '[-@._A-Za-z0-9]*:' > /dev/null; then+      # Some sort of URL or remote ssh pathname ("xxx:/")+      echo "$1"+      # echo "converting path ${*} ... to ${1}" >> /tmp/log+   elif [ "$1" == '.' ]; then+      # Compensate for stupid 'cygpath' behavior.+      echo '.'+      # echo "converting path ${*} ... to ." >> /tmp/log+   else+      cygpath -wl -- "$1"+      # echo "converting path ${*} ... to `cygpath -wl -- ${1}`" >> /tmp/log+   fi+}++declare -a params=("$cmd")++num_nonoption_args=0++while [ $# -gt 0 ]; do+   arg=$1+   shift+   if expr match "$arg" '-' > /dev/null; then+      # It's an option.  Check to see if it's an opaque binary option.++      if expr match "$arg" '.*=' > /dev/null; then+         # The option has an '=' in it.+         opt=`expr match "$arg" '\([^=]*\)'`+         opt_arg=`expr match "$arg" '[^=]*=\(.*\)'`+         if is_opaque_opt "$opt"; then+            true;+         elif is_file_opt "$opt"; then+            opt_arg=`convert_path "$opt_arg"`+         else+            die "darcs-wrapper: I don't think '$opt' accepts an argument." \+                "[ If it does, then there is a bug in the wrapper script. ]"+         fi+         params[${#params[*]}]="$opt=$opt_arg"++      else+         # The option doesn't have an '='+         opt="$arg"+         if is_opaque_opt "$opt"; then+            if [ $# -eq 0 ]; then+               die "darcs-wrapper: I think '$arg' requires an argument." \+                   "[ If it doesn't, then there is a bug in the wrapper script. ]"+            fi+            opt_arg="$1"+            shift+            params[${#params[*]}]="$opt"+            params[${#params[*]}]="$opt_arg"+         elif is_file_opt "$opt"; then+            if [ $# -eq 0 ]; then+               die "darcs-wrapper: I think '$arg' requires an argument." \+                   "[ If it doesn't, then there is a bug in the wrapper script. ]"+            fi+            opt_arg=`convert_path "$1"`+            shift+            params[${#params[*]}]="$opt"+            params[${#params[*]}]="$opt_arg"+         else+            params[${#params[*]}]="$opt"+         fi+      fi++   else+      if $convert_nonoption_args; then+         arg=`convert_path "$arg"`+      fi+      params[${#params[*]}]="$arg"+      (( num_nonoption_args += 1 ))+   fi+done++# DEBUG+if $debug; then+   echo "ARGS:"+   for arg in "${params[@]}"; do+      echo "  arg = '$arg'"+   done+else+   # echo about to exec -a darcs "$darcs_binary" "${params[@]}"+   exec -a darcs "$darcs_binary" "${params[@]}"+fi+
+ contrib/darcs_completion view
@@ -0,0 +1,52 @@+#-*- mode: shell-script;-*-++# darcs command line completion.+# Copyright 2002 "David Roundy" <droundy@abridgegame.org>+#+have darcs &&+_darcs()+{+    local cur+    cur=${COMP_WORDS[COMP_CWORD]}++    COMPREPLY=()++    if (($COMP_CWORD == 1)); then+        COMPREPLY=( $( darcs --commands | grep "^$cur" ) )+        return 0+    fi++    local IFS=$'\n' # So that the following "command-output to array" operation splits only at newlines, not at each space, tab or newline.+    COMPREPLY=( $( darcs ${COMP_WORDS[1]} --list-option | grep "^${cur//./\\.}") )++	# Then, we adapt the resulting strings to be reusable by bash. If we don't+	# do this, in the case where we have two repositories named+	# ~/space in there-0.1 and ~/space in there-0.2, the first completion will+	# give us:+	# bash> darcs push ~/space in there-0.+	# ~/space in there-0.1 ~/space in there-0.2+	# and we have introduced two spaces in the command line (if we try to+	# recomplete that, it won't find anything, as it doesn't know anything+	# starting with "there-0.").+	# printf %q will gracefully add the necessary backslashes.+	#+	# Bash also interprets colon as a separator. If we didn't handle it+	# specially, completing http://example.org/repo from http://e would +	# give us:+	# bash> darcs pull http:http://example.org/repo+	# An option would be to require the user to escape : as \: and we+	# would do the same here. Instead, we return only the part after+	# the last colon that is already there, and thus fool bash. The+	# downside is that bash only shows this part to the user.+    local i=${#COMPREPLY[*]}+    local colonprefixes=${cur%"${cur##*:}"}+    while [ $((--i)) -ge 0 ]; do+      COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"`++      COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} +    done+    return 0++}+[ "$have" ] && complete -F _darcs -o default darcs+
+ contrib/update_roundup.pl view
@@ -0,0 +1,78 @@+#!/usr/bin/perl++use strict;+use warnings;++# A script to update the status of an issue in a Roundup bug tracker+# based on the format of a darcs patch name.+# It is intended to be run from a darcs posthook.++# The format we look for is:+#   resolved issue123 +# in the first line of the patch. ++use Getopt::Long;++use MIME::Lite;+use XML::Simple;++unless ($ENV{DARCS_PATCHES_XML}) {+    die "DARCS_PATCHES_XML was expected to be set in the environment, but was not found. +          Are you running this from a Darcs 2.0 or newer posthook?"+}++my $xml = eval { XMLin($ENV{DARCS_PATCHES_XML}); };+die "hmmm.. we couldn't parse your XML. The error was: $@"  if $@;++# $xml structure returned looks like this: +#  'patch' => {+#    'resolved issue123: adding t.t' => {+#        'hash' => '20080215033723-20bb4-54f935f89817985a3e98f3de8e8ac9dad5e8e0e5.gz',+#        'inverted' => 'False',+#        'date' => '20080215033723',+#        'author' => 'Mark Stosberg <mark@summersault.com>',+#        'local_date' => 'Thu Feb 14 22:37:23 EST 2008'+#        },+#     'some other patch' => { ... }, ++for my $patch_name (keys %{ $xml->{patch} }) {+    my $issue_re = qr/resolved? \s+ (issue\d+)/msxi;++    next unless ($patch_name =~ $issue_re);+    my $issue = $1;+    my $patch = $xml->{patch}{$patch_name};++    # Using the Command Line would be a simpler alternative. +    # my $out = `roundup-admin -i /var/lib/roundup/trackers/darcs set $issue status=resolved`;+    # warn "unexpected output: $out" if $out;++    my $author = $patch->{author};+    # If the Author name contains an @ sign, we take it to be an e-mail address.+    # Otherwise, we default to darcs-devel as the sender. +    my $email = ($author =~ m/\@/) ? $author : 'darcs-devel@darcs.net';++    my $comment = $patch->{comment} ? "\n$patch->{comment}" : '';++    my $patch_name_minus_status = $patch_name; +    $patch_name_minus_status =~ s/$issue_re(:?\s?)//;++     # Each patches can potentially update the status of a different issue, so generates a different e-mail+    my $msg = MIME::Lite->new(+         From     => $email, +         To      =>'bugs@darcs.net',+         #To       =>'mark@stosberg.com',+         Subject  =>"[$issue] [status=resolved]",+         Type     =>'text/plain',+         Data     => qq!The following patch updated the status of $issue to be resolved:++* $patch_name $comment++!+     );+     $msg->send;+     # An alternative to actually sending, for debugging. +     # use File::Slurp;+     # write_file("msg-$patch->{hash}.out",$msg->as_string);+}++
+ contrib/upload.cgi view
@@ -0,0 +1,126 @@+#!/usr/bin/perl++use strict;+use File::Temp qw/ tempdir tempfile /;++# this is a sample cgi script to accept darcs patches via POST+# it simply takes patches and sends them using sendmail or+# places them in a Maildir style mailbox.++my $tmp_dir;        # temporary directory, when placing patches to maildir+                    # files are linked from $tmp_dir to $maildir+$tmp_dir = "/tmp";++# target email addresses--leave blank to use To: header in patch contents.+my $target_email;++# target repository for patch testing.  Leave blank to use DarcsURL header+# in patch contents.+my $target_repo;++my $sendmail_cmd;   # command to send patches with+$sendmail_cmd = "/usr/sbin/sendmail -i -t $target_email";++my $maildir;        # maildir to put patches to, replace sendmail+#$maildir = "/tmp/maildir";++my $patch_test_cmd; # command to test patches with+$patch_test_cmd = "darcs apply --dry-run --repodir 'TARGETREPO' 'TARGETPATCH'";++my $repo_get_cmd; # command to get testing repo+                  # used only when $target_repo is blank+$repo_get_cmd = "darcs get --lazy --repodir 'TARGETDIR' 'TARGETREPO'";+++sub error_page {+    my ($m) = @_;+    print "Status: 500 Error accepting patch\n";+    print "Content-Type: text/plain\n\n";+    print($m || "There was an error processing your request");+    print "\n";+    exit 0;+}++sub success_page {+    print "Content-Type: text/plain\n\n";+    print "Thank you for your contribution!\n";+    exit 0;+}+++if ($ENV{CONTENT_TYPE} eq 'message/rfc822') {+    my $m = start_message() or error_page("could not create temporary file");+    my $fh = $m->{fh};+    my ($totalbytes, $bytesread, $buffer);+    do {+        $bytesread = read(STDIN, $buffer, 1024);+        print $fh $buffer;+        $totalbytes += $bytesread;+    } while ($bytesread);+    my $r = end_message($m);+    $r ? error_page($r) : success_page();+} elsif ($ENV{CONTENT_TYPE}) {+    error_page("invalid content type, I expect something of message/rfc822");+} else {+    error_page("This url is for accepting darcs patches.");+}++++sub maildir_file {+    my ($tmp_file) = @_;+    my $base_name = sprintf("patch-%d-%d-0000", $$, time());+    my $count = 0;+    until (link("$tmp_file", "$maildir/$base_name")) {+        $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;+        return undef if $count++ > 100;+    }+    return "$maildir/$base_name";+}++sub start_message {+    my ($fh, $fname) = tempfile("$tmp_dir/dpatch".'X'x8, UNLINK => 1) or+        return undef;+    return { fh => $fh, filename => $fname };+}++sub end_message {+    my ($m) = @_;+    close $m->{fh} or return "$!: $m->{filename} - Could not close filehandle";++    unless ($target_repo) {+        # Look for DarcsURL header+        my $darcsurl;+        open(MF,$m->{filename}) or return "$!: $m->{filename} - Could not open file";+        while (<MF>) {+            if (/^DarcsURL: (.+)$/) {+                $darcsurl = $1;+                last;+            }+        }+        close(MF);+        return "Could not find DarcsURL header" unless $darcsurl;++        my $test_dir = tempdir(CLEANUP => 1).'/repo' or+            return "$!: Could not create test directory";+        $repo_get_cmd =~ s/TARGETDIR/$test_dir/;+        $repo_get_cmd =~ s/TARGETREPO/$darcsurl/;+        system("$repo_get_cmd >/dev/null 2>/dev/null") == 0 or+            return "Could not get target repo: '$repo_get_cmd' failed";+        $target_repo = $test_dir;+    }+    $patch_test_cmd =~ s/TARGETREPO/$target_repo/;+    $patch_test_cmd =~ s/TARGETPATCH/$m->{filename}/;+    system("$patch_test_cmd >/dev/null 2>/dev/null") == 0 or+        return "Patch is not valid: '$patch_test_cmd' failed";++    if ($maildir) {+        maildir_file("$m->{filename}") or+            return "$!: Could not create a new file in maildir";+    } else {+        system("$sendmail_cmd < '$m->{filename}'") == 0 or+            return "$!: Could not send mail";+    }++    return 0;+}
+ darcs-beta.cabal view
@@ -0,0 +1,648 @@+Name:           darcs-beta+version:        2.2.98.1+License:        GPL+License-file:   COPYING+Author:         David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>+Maintainer:     <darcs-users@darcs.net>++Stability:      Experimental+Category:       Development+Synopsis:       a distributed, interactive, smart revision control system+Description:    Darcs is a free, open source revision control+                system. It is:+                .+                * Distributed: Every user has access to the full+                  command set, removing boundaries between server and+                  client or committer and non-committers.+                .+                * Interactive: Darcs 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.+                .+                * Smart: Originally developed by physicist David+                  Roundy, darcs is based on a unique algebra of+                  patches.+                .+                  This smartness lets you respond to changing demands+                  in ways that would otherwise not be possible. Learn+                  more about spontaneous branches with darcs.+Homepage:       http://darcs.net/++Build-Type:     Custom+Cabal-Version:  >= 1.6+Tested-with:    GHC==6.8.2++extra-source-files:+  -- C headers+  src/*.h src/Crypt/sha2.h+  src/win32/send_email.h src/win32/sys/mman.h++  -- TODO: factor out these standalone executables to other sections+  src/preproc.hs, src/unit.lhs,++  -- The contrib directory would make a sensible 'darcs-contrib' package+  contrib/_darcs.zsh, contrib/darcs_completion,+  contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi,+  contrib/cgi/darcs.cgi.in, contrib/cgi/cgi.conf.in, contrib/cgi/README.in+  contrib/cgi/xslt/*.xslt, contrib/cgi/xslt/*.xml, contrib/cgi/xslt/*.css,++  -- documentation files+  src/best_practices.tex, src/building_darcs.tex, src/configuring_darcs.tex,+  src/features.tex, src/gpl.tex, src/switching.tex,+  contrib/cgi/README.in++  README++  -- release data+  release/distributed-version, release/distributed-context++  -- testsuite+  Distribution/ShellHarness.hs+  tests/repos/*.tgz tests/repos/README+  tests/*.sh+  tests/network/*.sh+  tests/lib+  tests/example_binary.png+  bugs/*.sh++source-repository head+  type:     darcs+  location: http://darcs.net/++flag curl+  description: Use libcurl for HTTP support.++flag curl-pipelining+  description: Use libcurl's HTTP pipelining.+  default:     False+  --TODO: needs Cabal ticket #342 to allow default True+  --      and decide on this automatically++flag http+  description: Use the pure Haskell HTTP package for HTTP support.++-- SUNSET: this should be mandatory after the 2009-07 release is out+flag bytestring+  description: Use the external bytestring package.++flag zlib+  description: Use the external zlib binding package.+  default:     True++-- SUNSET: this should be mandatory after the 2009-07 release is out+flag utf8-string+  description: Use the external utf8-string binding package.++flag terminfo+  description: Use the terminfo package for enhanced console support.++flag type-witnesses+  description: Use GADT type witnesses.+  default:     False++flag color+  description: Use ansi color escapes.++flag mmap+  description: Compile with mmap support.++flag base3++flag test+  description: Compile unit tests (requires QuickCheck >= 2.1.0.0).+  default:     False++Executable          witnesses+  main-is:          witnesses.hs+  hs-source-dirs:   src+  include-dirs:     src+  cpp-options:      -DGADT_WITNESSES=1+  -- FIXME...+  c-sources:        src/atomic_create.c+                    src/fpstring.c+                    src/c_compat.c+                    src/maybe_relink.c+                    src/umask.c+                    src/Crypt/sha2.c+  if !flag(type-witnesses)+    buildable: False++  if !flag(zlib)+    extra-libraries:  z++  if os(windows)+    hs-source-dirs: src/win32+    include-dirs:   src/win32+    other-modules:  CtrlC+                    System.Posix+                    System.Posix.Files+                    System.Posix.IO+    cpp-options:    -DWIN32+    c-sources:      src/win32/send_email.c++-- ----------------------------------------------------------------------+-- darcs library+-- ----------------------------------------------------------------------++Library+  hs-source-dirs:   src+  include-dirs:     src++  exposed-modules:  CommandLine+                    Crypt.SHA256+                    Darcs.ArgumentDefaults+                    Darcs.Arguments+                    Darcs.Bug+                    Darcs.CheckFileSystem+                    Darcs.ColorPrinter+                    Darcs.Commands+                    Darcs.Commands.Add+                    Darcs.Commands.AmendRecord+                    Darcs.Commands.Annotate+                    Darcs.Commands.Apply+                    Darcs.CommandsAux+                    Darcs.Commands.Changes+                    Darcs.Commands.Check+                    Darcs.Commands.Convert+                    Darcs.Commands.Diff+                    Darcs.Commands.Dist+                    Darcs.Commands.Get+                    Darcs.Commands.GZCRCs+                    Darcs.Commands.Help+                    Darcs.Commands.Init+                    Darcs.Commands.MarkConflicts+                    Darcs.Commands.Move+                    Darcs.Commands.Optimize+                    Darcs.Commands.Pull+                    Darcs.Commands.Push+                    Darcs.Commands.Put+                    Darcs.Commands.Record+                    Darcs.Commands.Remove+                    Darcs.Commands.Repair+                    Darcs.Commands.Replace+                    Darcs.Commands.Revert+                    Darcs.Commands.Rollback+                    Darcs.Commands.Send+                    Darcs.Commands.SetPref+                    Darcs.Commands.Show+                    Darcs.Commands.ShowAuthors+                    Darcs.Commands.ShowBug+                    Darcs.Commands.ShowContents+                    Darcs.Commands.ShowFiles+                    Darcs.Commands.ShowIndex+                    Darcs.Commands.ShowRepo+                    Darcs.Commands.ShowTags+                    Darcs.Commands.Tag+                    Darcs.Commands.TrackDown+                    Darcs.Commands.TransferMode+                    Darcs.Commands.Unrecord+                    Darcs.Commands.Unrevert+                    Darcs.Commands.WhatsNew+                    Darcs.Compat+                    Darcs.Diff+                    Darcs.Email+                    Darcs.External+                    Darcs.FilePathMonad+                    Darcs.Flags+                    Darcs.Global+                    Darcs.Gorsvet+                    Darcs.Hopefully+                    Darcs.IO+                    Darcs.Lock+                    Darcs.Match+                    Darcs.Ordered+                    Darcs.Patch+                    Darcs.Patch.Apply+                    Darcs.Patch.Bundle+                    Darcs.Patch.Check+                    Darcs.Patch.Choices+                    Darcs.Patch.Commute+                    Darcs.Patch.Core+                    Darcs.Patch.Depends+                    Darcs.Patch.FileName+                    Darcs.Patch.Info+                    Darcs.Patch.Match+                    Darcs.Patch.MatchData+                    Darcs.Patch.Non+                    Darcs.Patch.Patchy+                    Darcs.Patch.Permutations+                    Darcs.Patch.Prim+                    Darcs.Patch.Properties+                    Darcs.Patch.Read+                    Darcs.Patch.ReadMonads+                    Darcs.Patch.Real+                    Darcs.Patch.Set+                    Darcs.Patch.Show+                    Darcs.Patch.TouchesFiles+                    Darcs.Patch.Viewing+                    Darcs.Population+                    Darcs.PopulationData+                    Darcs.PrintPatch+                    Darcs.ProgressPatches+                    Darcs.RemoteApply+                    Darcs.RepoPath+                    Darcs.Repository+                    Darcs.Repository.ApplyPatches+                    Darcs.Repository.Cache+                    Darcs.Repository.Checkpoint+                    Darcs.Repository.DarcsRepo+                    Darcs.Repository.Format+                    Darcs.Repository.HashedIO+                    Darcs.Repository.HashedRepo+                    Darcs.Repository.Internal+                    Darcs.Repository.InternalTypes+                    Darcs.Repository.Motd+                    Darcs.Repository.Prefs+                    Darcs.Repository.Pristine+                    Darcs.Repository.Repair+                    Darcs.Resolution+                    Darcs.RunCommand+                    Darcs.Sealed+                    Darcs.SelectChanges+                    Darcs.Show+                    Darcs.SignalHandler+                    Darcs.SlurpDirectory+                    Darcs.SlurpDirectory.Internal+                    Darcs.Test+                    Darcs.TheCommands+                    Darcs.URL+                    Darcs.Utils+                    DateMatcher+                    English+                    Exec+                    ByteStringUtils+                    HTTP+                    IsoDate+                    Lcs+                    OldDate+                    Printer+                    Progress+                    RegChars+                    SHA1+                    Ssh+                    URL+                    UTF8+                    Workaround++  other-modules:    ThisVersion++  c-sources:        src/atomic_create.c+                    src/fpstring.c+                    src/c_compat.c+                    src/maybe_relink.c+                    src/umask.c+                    src/Crypt/sha2.c+  cc-options:       -D_REENTRANT++  if os(windows)+    hs-source-dirs: src/win32+    include-dirs:   src/win32+    other-modules:  CtrlC+                    System.Posix+                    System.Posix.Files+                    System.Posix.IO+    cpp-options:    -DWIN32++  if os(solaris)+    cc-options:     -DHAVE_SIGINFO_H++  build-depends:   base          < 4,+                   regex-compat >= 0.71 && < 0.94,+                   mtl          >= 1.0 && < 1.2,+                   parsec       >= 2.0 && < 3.1,+                   html         == 1.0.*,+                   filepath     == 1.1.*,+                   haskeline    >= 0.6.1 && < 0.7,+                   hashed-storage >= 0.3.3.1 && < 0.4++  if !os(windows)+    build-depends: unix >= 1.0 && < 2.4++  if flag(base3)+    build-depends: base >= 3,+                   old-time   == 1.0.*,+                   directory  == 1.0.*,+                   process    == 1.0.*,+                   containers >= 0.1 && < 0.3,+                   array      >= 0.1 && < 0.3,+                   random     == 1.0.*+  else+    build-depends: base < 3++  -- We need optimizations, regardless of what Hackage says+  ghc-options:      -Wall -O2 -funbox-strict-fields+  ghc-prof-options: -prof -auto-all++  if flag(curl)+    extra-libraries:   curl+    includes:          curl/curl.h+    cpp-options:       -DHAVE_CURL+    c-sources:         src/hscurl.c+    cc-options:        -DHAVE_CURL++    if flag(curl-pipelining)+      -- curl 7.19.1 has bug-free pipelining+      if !os(windows)+        pkgconfig-depends: libcurl >= 7.19.1+      cpp-options:       -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT++  if flag(http)+      build-depends:    network == 2.2.*,+                        HTTP    >= 3000.0 && < 3001.2+      cpp-options:      -DHAVE_HTTP+      x-have-http:++  if !flag(curl) && !flag(http)+      buildable: False++  if flag(mmap) && !os(windows)+    build-depends:    mmap >= 0.2+    cpp-options:      -DHAVE_MMAP++  if flag(bytestring)+    build-depends:    bytestring >= 0.9.0 && < 0.10+    cpp-options:      -DHAVE_BYTESTRING++  if flag(zlib)+    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0+    cpp-options:      -DHAVE_HASKELL_ZLIB+  else+    extra-libraries:  z++  if flag(utf8-string)+    build-depends:    utf8-string == 0.3.*+    cpp-options:      -DHAVE_UTF8STRING++  -- The terminfo package cannot be built on Windows.+  if flag(terminfo) && !os(windows)+    build-depends:    terminfo == 0.3.*+    cpp-options:      -DHAVE_TERMINFO++  if flag(color)+    x-use-color:++  extensions:+    CPP,+    ForeignFunctionInterface,+    BangPatterns,+    PatternGuards,+    MagicHash,+    UndecidableInstances,+    DeriveDataTypeable,+    GADTs,+    TypeOperators,+    ExistentialQuantification,+    FlexibleContexts,+    FlexibleInstances,+    ScopedTypeVariables,+    KindSignatures,+    TypeSynonymInstances,+    Rank2Types,+    RankNTypes,+    GeneralizedNewtypeDeriving,+    MultiParamTypeClasses++-- ----------------------------------------------------------------------+-- darcs itself+-- ----------------------------------------------------------------------++Executable          darcs+  main-is:          darcs.hs+  hs-source-dirs:   src+  include-dirs:     src+  c-sources:        src/atomic_create.c+                    src/fpstring.c+                    src/c_compat.c+                    src/maybe_relink.c+                    src/umask.c+                    src/Crypt/sha2.c++  -- We need optimizations, regardless of what Hackage says+  ghc-options:      -Wall -O2 -funbox-strict-fields -threaded+  ghc-prof-options: -prof -auto-all++  if !flag(zlib)+    extra-libraries:  z++  cc-options:       -D_REENTRANT++  if os(windows)+    hs-source-dirs: src/win32+    include-dirs:   src/win32+    other-modules:  CtrlC+                    System.Posix+                    System.Posix.Files+                    System.Posix.IO+    cpp-options:    -DWIN32+    c-sources:      src/win32/send_email.c++  if os(solaris)+    cc-options:     -DHAVE_SIGINFO_H++  build-depends:   base          < 4,+                   regex-compat >= 0.71 && < 0.94,+                   mtl          >= 1.0 && < 1.2,+                   parsec       >= 2.0 && < 3.1,+                   html         == 1.0.*,+                   filepath     == 1.1.*,+                   haskeline    >= 0.6.1 && < 0.7,+                   hashed-storage >= 0.3.3.1 && < 0.4++  if !os(windows)+    build-depends: unix >= 1.0 && < 2.4++  if flag(base3)+    build-depends: base >= 3,+                   old-time   == 1.0.*,+                   directory  == 1.0.*,+                   process    == 1.0.*,+                   containers >= 0.1 && < 0.3,+                   array      >= 0.1 && < 0.3,+                   random     == 1.0.*+  else+    build-depends: base < 3++  if flag(curl)+    extra-libraries:   curl+    includes:          curl/curl.h+    cpp-options:       -DHAVE_CURL+    c-sources:         src/hscurl.c+    cc-options:        -DHAVE_CURL++    if flag(curl-pipelining)+      -- curl 7.19.1 has bug-free pipelining+      if !os(windows)+        pkgconfig-depends: libcurl >= 7.19.1+      cpp-options:       -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT++   if flag(http)+      build-depends:    network == 2.2.*,+                        HTTP    >= 3000.0 && < 3001.2+      cpp-options:      -DHAVE_HTTP+      x-have-http:++  if !flag(curl) && !flag(http)+      buildable: False++  if flag(mmap) && !os(windows)+    build-depends:    mmap >= 0.2+    cpp-options:      -DHAVE_MMAP++  if flag(bytestring)+    build-depends:    bytestring >= 0.9.0 && < 0.10+    cpp-options:      -DHAVE_BYTESTRING++  if flag(zlib)+    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0+    cpp-options:      -DHAVE_HASKELL_ZLIB+  else+    extra-libraries:  z++  if flag(utf8-string)+    build-depends:    utf8-string == 0.3.*+    cpp-options:      -DHAVE_UTF8STRING++  -- The terminfo package cannot be built on Windows.+  if flag(terminfo) && !os(windows)+    build-depends:    terminfo == 0.3.*+    cpp-options:      -DHAVE_TERMINFO++  if flag(color)+    x-use-color:++  extensions:+    CPP,+    ForeignFunctionInterface,+    BangPatterns,+    PatternGuards,+    MagicHash,+    UndecidableInstances,+    DeriveDataTypeable,+    GADTs,+    TypeOperators,+    ExistentialQuantification,+    FlexibleContexts,+    FlexibleInstances,+    ScopedTypeVariables,+    KindSignatures,+    TypeSynonymInstances,+    Rank2Types,+    RankNTypes,+    GeneralizedNewtypeDeriving,+    MultiParamTypeClasses++-- ----------------------------------------------------------------------+-- unit test driver+-- ----------------------------------------------------------------------++Executable          unit+  main-is:          unit.lhs+  hs-source-dirs:   src+  include-dirs:     src+  c-sources:        src/atomic_create.c+                    src/fpstring.c+                    src/c_compat.c+                    src/maybe_relink.c+                    src/umask.c+                    src/Crypt/sha2.c++  -- We need optimizations, regardless of what Hackage says+  ghc-options:      -Wall -O2 -funbox-strict-fields -threaded+  ghc-prof-options: -prof -auto-all++  if !flag(test)+    buildable: False+  else+    buildable: True+    build-depends:   base          < 4,+                     regex-compat >= 0.71 && < 0.94,+                     mtl          >= 1.0 && < 1.2,+                     parsec       >= 2.0 && < 3.1,+                     html         == 1.0.*,+                     filepath     == 1.1.*,+                     QuickCheck   >= 2.1.0.0,+                     HUnit        >= 1.0,+                     test-framework             >= 0.2.2,+                     test-framework-hunit       >= 0.2.2,+                     test-framework-quickcheck2 >= 0.2.2+++  if !flag(zlib)+    extra-libraries:  z++  cc-options:       -D_REENTRANT++  if os(windows)+    hs-source-dirs: src/win32+    include-dirs:   src/win32+    other-modules:  CtrlC+                    System.Posix+                    System.Posix.Files+                    System.Posix.IO+    cpp-options:    -DWIN32+    c-sources:      src/win32/send_email.c++  if os(solaris)+    cc-options:     -DHAVE_SIGINFO_H++  if !os(windows)+    build-depends: unix >= 1.0 && < 2.4++  if flag(base3)+    build-depends: base >= 3,+                   old-time   == 1.0.*,+                   directory  == 1.0.*,+                   process    == 1.0.*,+                   containers >= 0.1 && < 0.3,+                   array      >= 0.1 && < 0.3,+                   random     == 1.0.*+  else+    build-depends: base < 3++  if flag(mmap) && !os(windows)+    build-depends:    mmap >= 0.2+    cpp-options:      -DHAVE_MMAP++  if flag(bytestring)+    build-depends:    bytestring >= 0.9.0 && < 0.10+    cpp-options:      -DHAVE_BYTESTRING++  if flag(zlib)+    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0+    cpp-options:      -DHAVE_HASKELL_ZLIB+  else+    extra-libraries:  z++  -- The terminfo package cannot be built on Windows.+  if flag(terminfo) && !os(windows)+    build-depends:    terminfo == 0.3.*+    cpp-options:      -DHAVE_TERMINFO++  if flag(color)+    x-use-color:++  extensions:+    CPP,+    ForeignFunctionInterface,+    BangPatterns,+    PatternGuards,+    MagicHash,+    UndecidableInstances,+    DeriveDataTypeable,+    GADTs,+    TypeOperators,+    ExistentialQuantification,+    FlexibleContexts,+    FlexibleInstances,+    ScopedTypeVariables,+    KindSignatures,+    TypeSynonymInstances,+    Rank2Types,+    RankNTypes,+    GeneralizedNewtypeDeriving,+    MultiParamTypeClasses+    OverlappingInstances
+ release/distributed-context view
@@ -0,0 +1,1 @@+Just "\nContext:\n\n[TAG 2.2.98.1\nPetr Rockai <me@mornfall.net>**20090623155657\n Ignore-this: b388b0221526b2609dec75bb733bfc4c\n] \n"
+ release/distributed-version view
@@ -0,0 +1,1 @@+Just 0
+ src/ByteStringUtils.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  ByteStringUtils+-- Copyright   :  (c) The University of Glasgow 2001,+--                    David Roundy 2003-2005+-- License : GPL (I'm happy to also license this file BSD style but don't+--           want to bother distributing two license files with darcs.+--+-- Maintainer  :  droundy@abridgegame.org+-- Stability   :  experimental+-- Portability :  portable+--+-- GZIp and MMap IO for ByteStrings, and miscellaneous functions for Data.ByteString+--++module ByteStringUtils (++        unsafeWithInternals,+        unpackPSfromUTF8,++        -- IO with mmap or gzip+        gzReadFilePS,+        mmapFilePS,+        gzWriteFilePS,+        gzWriteFilePSs,++        -- gzip handling+        isGZFile,+#ifdef HAVE_HASKELL_ZLIB+        gzDecompress,+#endif++        -- list utilities+        ifHeadThenTail,+        dropSpace,+        breakSpace,+        linesPS,+        unlinesPS,+        hashPS,+        breakFirstPS,+        breakLastPS,+        substrPS,+        readIntPS,+        is_funky,+        fromHex2PS,+        fromPS2Hex,+        betweenLinesPS,+        break_after_nth_newline,+        break_before_nth_newline,+        intercalate+    ) where++import Prelude hiding ( catch )+import qualified Data.ByteString            as B+import qualified Data.ByteString.Char8      as BC+import qualified Data.ByteString.Internal   as BI+import Data.ByteString (intercalate, uncons)+import Data.ByteString.Internal (fromForeignPtr)++#if defined (HAVE_MMAP) || ! defined (HAVE_HASKELL_ZLIB)+import Control.Exception        ( catch )+#endif+import System.IO+import System.IO.Unsafe         ( unsafePerformIO )++import Foreign.Storable         ( peekElemOff, peek )+import Foreign.Marshal.Alloc    ( free )+import Foreign.Marshal.Array    ( mallocArray, peekArray, advancePtr )+import Foreign.C.Types          ( CInt )++import Data.Bits                ( rotateL )+import Data.Char                ( chr, ord, isSpace )+import Data.Word                ( Word8 )+import Data.Int                 ( Int32 )+import Control.Monad            ( when )++#ifndef HAVE_HASKELL_ZLIB+import Foreign.Ptr              ( nullPtr )+import Foreign.ForeignPtr       ( ForeignPtr )+#endif+import Foreign.Ptr              ( plusPtr, Ptr )+import Foreign.ForeignPtr       ( withForeignPtr )++#ifdef DEBUG_PS+import Foreign.ForeignPtr       ( addForeignPtrFinalizer )+import Foreign.Ptr              ( FunPtr )+#endif++#if HAVE_HASKELL_ZLIB+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib.Internal as ZI+import Darcs.Global ( addCRCWarning )+#else+import Foreign.C.String ( CString, withCString )+#endif++#ifdef HAVE_MMAP+import System.IO.MMap( mmapFileByteString )+import System.Mem( performGC )+import System.Posix.Files( fileSize, getSymbolicLinkStatus )+#endif++-- -----------------------------------------------------------------------------+-- obsolete debugging code++# ifndef HAVE_HASKELL_ZLIB+debugForeignPtr :: ForeignPtr a -> String -> IO ()+#ifdef DEBUG_PS+foreign import ccall unsafe "static fpstring.h debug_alloc" debug_alloc+    :: Ptr a -> CString -> IO ()+foreign import ccall unsafe "static fpstring.h & debug_free" debug_free+    :: FunPtr (Ptr a -> IO ())+debugForeignPtr fp n =+    withCString n $ \cname-> withForeignPtr fp $ \p->+    do debug_alloc p cname+       addForeignPtrFinalizer debug_free fp+#else+debugForeignPtr _ _ = return ()+#endif+#endif++-- -----------------------------------------------------------------------------+-- unsafeWithInternals++-- | Do something with the internals of a PackedString. Beware of+-- altering the contents!+unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a+unsafeWithInternals ps f+ = case BI.toForeignPtr ps of+   (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l++-- | readIntPS skips any whitespace at the beginning of its argument, and+-- reads an Int from the beginning of the PackedString.  If there is no+-- integer at the beginning of the string, it returns Nothing, otherwise it+-- just returns the int read, along with a B.ByteString containing the+-- remainder of its input.++readIntPS :: B.ByteString -> Maybe (Int, B.ByteString)+readIntPS = BC.readInt . BC.dropWhile isSpace++-- -----------------------------------------------------------------------------+-- Destructor functions (taking PackedStrings apart)++unpackPSfromUTF8 :: B.ByteString -> String+unpackPSfromUTF8 ps =+ case BI.toForeignPtr ps of+   (_,_, 0) -> ""+   (x,s,l)  ->+    unsafePerformIO $ withForeignPtr x $ \p->+    do outbuf <- mallocArray l+       lout <- fromIntegral `fmap`+               utf8_to_ints outbuf (p `plusPtr` s) (fromIntegral l)+       when (lout < 0) $ error "Bad UTF8!"+       str <- (map (chr . fromIntegral)) `fmap` peekArray lout outbuf+       free outbuf+       return str++foreign import ccall unsafe "static fpstring.h utf8_to_ints" utf8_to_ints+    :: Ptr Int -> Ptr Word8 -> CInt -> IO CInt++-- -----------------------------------------------------------------------------+-- List-mimicking functions for PackedStrings++{-# INLINE ifHeadThenTail #-}+ifHeadThenTail :: Word8 -> B.ByteString -> Maybe B.ByteString+ifHeadThenTail c s = case uncons s of+    Just (w, t) | w == c    -> Just t+    _                       -> Nothing++------------------------------------------------------------------------+-- A reimplementation of Data.ByteString.Char8.dropSpace, but+-- specialised to darcs' need for a 4 way isspace.+--+-- TODO: if it is safe to use the expanded definition of isSpaceWord8+-- provided by Data.ByteString.Char8, then all this can go.++-- A locale-independent isspace(3) so patches are interpreted the same everywhere.+-- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')+isSpaceWord8 :: Word8 -> Bool+isSpaceWord8 w =+    w == 0x20 ||    -- ' '+    w == 0x09 ||    -- '\t'+    w == 0x0A ||    -- '\n'+    w == 0x0D       -- '\r'+{-# INLINE isSpaceWord8 #-}++firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int+firstnonspace !ptr !n !m+    | n >= m    = return n+    | otherwise = do w <- peekElemOff ptr n+                     if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n++firstspace :: Ptr Word8 -> Int -> Int -> IO Int+firstspace !ptr !n !m+    | n >= m    = return n+    | otherwise = do w <- peekElemOff ptr n+                     if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n++-- | 'dropSpace' efficiently returns the 'ByteString' argument with+-- white space Chars removed from the front. It is more efficient than+-- calling dropWhile for removing whitespace. I.e.+-- +-- > dropWhile isSpace == dropSpace+--+dropSpace :: B.ByteString -> B.ByteString+dropSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do+    i <- firstnonspace (p `plusPtr` s) 0 l+    return $! if i == l then B.empty else BI.PS x (s+i) (l-i)+{-# INLINE dropSpace #-}++-- | 'breakSpace' returns the pair of ByteStrings when the argument is+-- broken at the first whitespace byte. I.e.+-- +-- > break isSpace == breakSpace+--+breakSpace :: B.ByteString -> (B.ByteString,B.ByteString)+breakSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do+    i <- firstspace (p `plusPtr` s) 0 l+    return $! case () of {_+        | i == 0    -> (B.empty, BI.PS x s l)+        | i == l    -> (BI.PS x s l, B.empty)+        | otherwise -> (BI.PS x s i, BI.PS x (s+i) (l-i))+    }+{-# INLINE breakSpace #-}++------------------------------------------------------------------------++{-# INLINE is_funky #-}+is_funky :: B.ByteString -> Bool+is_funky ps = case BI.toForeignPtr ps of+   (x,s,l) ->+    unsafePerformIO $ withForeignPtr x $ \p->+    (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l)++foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char+    :: Ptr Word8 -> CInt -> IO CInt++------------------------------------------------------------------------++-- ByteString rewrites break (=='x') to breakByte 'x'+--  break ((==) x) = breakChar x+--  break (==x) = breakChar x+--++{-+{-# INLINE breakOnPS #-}+breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString)+breakOnPS c p = case BC.elemIndex c p of+                Nothing -> (p, BC.empty)+                Just n  -> (B.take n p, B.drop n p)+-}++{-# INLINE hashPS #-}+hashPS :: B.ByteString -> Int32+hashPS ps =+   case BI.toForeignPtr ps of+   (x,s,l) ->+    unsafePerformIO $ withForeignPtr x $ \p->+    do hash (p `plusPtr` s) l++hash :: Ptr Word8 -> Int -> IO Int32+hash ptr len = f (0 :: Int32) ptr len+ where f h _ 0 = return h+       f h p n = do x <- peek p+                    let !h' =  (fromIntegral x) + (rotateL h 8)+                    f h' (p `advancePtr` 1) (n-1)++{-# INLINE substrPS #-}+substrPS :: B.ByteString -> B.ByteString -> Maybe Int+substrPS tok str+    | B.null tok = Just 0+    | B.length tok > B.length str = Nothing+    | otherwise = do n <- BC.elemIndex (BC.head tok) str+                     let ttok = B.tail tok+                         reststr = B.drop (n+1) str+                     if ttok == B.take (B.length ttok) reststr+                        then Just n+                        else ((n+1)+) `fmap` substrPS tok reststr++------------------------------------------------------------------------++-- TODO: replace breakFirstPS and breakLastPS with definitions based on+-- ByteString's break/breakEnd+{-# INLINE breakFirstPS #-}+breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakFirstPS c p = case BC.elemIndex c p of+                   Nothing -> Nothing+                   Just n -> Just (B.take n p, B.drop (n+1) p)++{-# INLINE breakLastPS #-}+breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakLastPS c p = case BC.elemIndexEnd c p of+                  Nothing -> Nothing+                  Just n -> Just (B.take n p, B.drop (n+1) p)++-- TODO: rename+{-# INLINE linesPS #-}+linesPS :: B.ByteString -> [B.ByteString]+linesPS ps+     | B.null ps = [B.empty]+     | otherwise = BC.split '\n' ps++{- QuickCheck property:++import Test.QuickCheck+import qualified Data.ByteString.Char8 as BC+import Data.Char+instance Arbitrary BC.ByteString where+    arbitrary = fmap BC.pack arbitrary+instance Arbitrary Char where+  arbitrary = chr `fmap` choose (32,127)+deepCheck = check (defaultConfig { configMaxTest = 10000})+testLines =  deepCheck (\x -> (linesPS x == linesPSOld x))+linesPSOld ps = case  BC.elemIndex '\n' ps of+             Nothing -> [ps]+             Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -}++{-| This function acts exactly like the "Prelude" unlines function, or like+"Data.ByteString.Char8" 'unlines', but with one important difference: it will+produce a string which may not end with a newline! That is:++> unlinesPS ["foo", "bar"]++evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for+'linesPS' as well.++TODO: rename this function. -}+unlinesPS :: [B.ByteString] -> B.ByteString+unlinesPS [] = BC.empty+unlinesPS x  = BC.init $ BC.unlines x+{-# INLINE unlinesPS #-}+{- QuickCheck property:++testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))+unlinesPSOld ss = BC.concat $ intersperse_newlines ss+    where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)+          intersperse_newlines s = s+          newline = BC.pack "\n" -}++-- -----------------------------------------------------------------------------+-- gzReadFilePS++#ifdef HAVE_HASKELL_ZLIB++gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString]+gzDecompress reportBadCRC mbufsize =+    -- This is what the code would be without the bad CRC recovery logic:+    -- return . BL.toChunks . GZ.decompressWith decompressParams+    toListWarn . ZI.decompressWithErrors ZI.GZip decompressParams+  where+        decompressParams = case mbufsize of+                              Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }+                              Nothing -> GZ.defaultDecompressParams++        toListWarn :: ZI.DecompressStream -> m [B.ByteString]+        toListWarn ZI.StreamEnd = return []+        toListWarn (ZI.StreamChunk x xs) = fmap (x:) (toListWarn xs)+        -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be+        -- produced. Trap bad CRC messages, run the specified action to report that it happened,+        -- but continue on the assumption that the data is valid.+        toListWarn (ZI.StreamError ZI.DataError "incorrect data check") = reportBadCRC >> return []+        toListWarn (ZI.StreamError _ msg) = fail msg++#else++foreign import ccall unsafe "static zlib.h gzopen" c_gzopen+    :: CString -> CString -> IO (Ptr ())+foreign import ccall unsafe "static zlib.h gzclose" c_gzclose+    :: Ptr () -> IO ()+foreign import ccall unsafe "static zlib.h gzread" c_gzread+    :: Ptr () -> Ptr Word8 -> CInt -> IO CInt+foreign import ccall unsafe "static zlib.h gzwrite" c_gzwrite+    :: Ptr () -> Ptr Word8 -> CInt -> IO CInt++#endif++isGZFile :: FilePath -> IO (Maybe Int)+isGZFile f = do+    h <- openBinaryFile f ReadMode+    header <- B.hGet h 2+    if header /= BC.pack "\31\139"+       then do hClose h+               return Nothing+       else do hSeek h SeekFromEnd (-4)+               len <- hGetLittleEndInt h+               hClose h+               return (Just len)++-- | Read an entire file, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadFilePS :: FilePath -> IO B.ByteString+gzReadFilePS f = do+    mlen <- isGZFile f+    case mlen of+       Nothing -> mmapFilePS f+       Just len ->+#ifdef HAVE_HASKELL_ZLIB+               -- Passing the length to gzDecompress means that it produces produces one chunk,+               -- which in turn means that B.concat won't need to copy data.+               -- If the length is wrong this will just affect efficiency, not correctness+               fmap B.concat . (gzDecompress (addCRCWarning f) (Just len) =<<) $+#ifdef HAVE_OLD_BYTESTRING+                        -- bytestring < 0.9.1 had a bug where it did not know to close handles upon EOF+                        -- performance would be better with a newer bytestring and lazy+                        -- readFile below -- ratify readFile: comment+                        fmap (BL.fromChunks . (:[])) $+                        B.readFile f  -- ratify readFile: immediately consumed+#else+                        BL.readFile f -- ratify readFile: immediately consumed by the conversion to a strict bytestring+#endif+#else+               withCString f $ \fstr-> withCString "rb" $ \rb-> do+                 gzf <- c_gzopen fstr rb+                 when (gzf == nullPtr) $ fail $ "problem opening file "++f+                 fp <- BI.mallocByteString len+                 debugForeignPtr fp $ "gzReadFilePS "++f+                 lread <- withForeignPtr fp $ \p ->+                          c_gzread gzf p (fromIntegral len)+                 c_gzclose gzf+                 when (fromIntegral lread /= len) $+                      fail $ "problem gzreading file "++f+                 return $ fromForeignPtr fp 0 len+#endif++hGetLittleEndInt :: Handle -> IO Int+hGetLittleEndInt h = do+    b1 <- ord `fmap` hGetChar h+    b2 <- ord `fmap` hGetChar h+    b3 <- ord `fmap` hGetChar h+    b4 <- ord `fmap` hGetChar h+    return $ b1 + 256*b2 + 65536*b3 + 16777216*b4++gzWriteFilePS :: FilePath -> B.ByteString -> IO ()+gzWriteFilePS f ps = gzWriteFilePSs f [ps]++gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO ()+gzWriteFilePSs f pss  =+#ifdef HAVE_HASKELL_ZLIB+    BL.writeFile f $ GZ.compress $ BL.fromChunks pss+#else+    withCString f $ \fstr -> withCString "wb" $ \wb -> do+    gzf <- c_gzopen fstr wb+    when (gzf == nullPtr) $ fail $ "problem gzopening file for write: "++f+    mapM_ (gzWriteToGzf gzf) pss `catch`+              \_ -> fail $ "problem gzwriting file: "++f+    c_gzclose gzf++gzWriteToGzf :: Ptr () -> B.ByteString -> IO ()+gzWriteToGzf gzf ps = case BI.toForeignPtr ps of+ (_,_,0) -> return () -- avoid calling gzwrite with 0 length this would+                      -- trouble on some versions of zlib, and is always+                      -- unnecessary.+ (x,s,l) -> do+    lw <- withForeignPtr x $ \p -> c_gzwrite gzf (p `plusPtr` s)+                                                 (fromIntegral l)+    when (fromIntegral lw /= l) $ fail $ "problem in gzWriteToGzf"+#endif++-- -----------------------------------------------------------------------------+-- mmapFilePS++-- | Like readFilePS, this reads an entire file directly into a+-- 'B.ByteString', but it is even more efficient.  It involves directly+-- mapping the file to memory.  This has the advantage that the contents of+-- the file never need to be copied.  Also, under memory pressure the page+-- may simply be discarded, wile in the case of readFilePS it would need to+-- be written to swap.  If you read many small files, mmapFilePS will be+-- less memory-efficient than readFilePS, since each mmapFilePS takes up a+-- separate page of memory.  Also, you can run into bus errors if the file+-- is modified.  NOTE: as with 'readFilePS', the string representation in+-- the file is assumed to be ISO-8859-1.++mmapFilePS :: FilePath -> IO B.ByteString+#ifdef HAVE_MMAP+mmapFilePS f = do+  x <- mmapFileByteString f Nothing+   `catch` (\_ -> do+                     size <- fileSize `fmap` getSymbolicLinkStatus f+                     if size == 0+                        then return B.empty+                        else performGC >> mmapFileByteString f Nothing)+  return x+#else+mmapFilePS = B.readFile+#endif++-- -------------------------------------------------------------------------+-- fromPS2Hex++foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex+    :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()++fromPS2Hex :: B.ByteString -> B.ByteString+fromPS2Hex ps = case BI.toForeignPtr ps of+          (x,s,l) ->+           BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f ->+           conv_to_hex p (f `plusPtr` s) $ fromIntegral l++-- -------------------------------------------------------------------------+-- fromHex2PS++foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex+    :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()++fromHex2PS :: B.ByteString -> B.ByteString+fromHex2PS ps = case BI.toForeignPtr ps of+          (x,s,l) ->+           BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f ->+           conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2)++-- -------------------------------------------------------------------------+-- betweenLinesPS++-- | betweenLinesPS returns the B.ByteString between the two lines given,+-- or Nothing if they do not appear.++betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString+               -> Maybe (B.ByteString)+betweenLinesPS start end ps+ = case break (start ==) (linesPS ps) of+       (_, _:rest@(bs1:_)) ->+           case BI.toForeignPtr bs1 of+            (ps1,s1,_) ->+             case break (end ==) rest of+               (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1)+               _ -> Nothing+       _ -> Nothing++-- -------------------------------------------------------------------------+-- break_after_nth_newline++break_after_nth_newline :: Int -> B.ByteString+                        -> Maybe (B.ByteString, B.ByteString)+break_after_nth_newline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)+break_after_nth_newline n the_ps =+  case BI.toForeignPtr the_ps of+  (fp,the_s,l) ->+   unsafePerformIO $ withForeignPtr fp $ \p ->+   do let findit 0 s | s == end = return $ Just (the_ps, B.empty)+          findit _ s | s == end = return Nothing+          findit 0 s = let left_l = s - the_s+                       in return $ Just (fromForeignPtr fp the_s left_l,+                                         fromForeignPtr fp s (l - left_l))+          findit i s = do w <- peekElemOff p s+                          if w == nl then findit (i-1) (s+1)+                                     else findit i (s+1)+          nl = BI.c2w '\n'+          end = the_s + l+      findit n the_s++-- -------------------------------------------------------------------------+-- break_before_nth_newline++break_before_nth_newline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)+break_before_nth_newline 0 the_ps+ | B.null the_ps = (B.empty, B.empty)+break_before_nth_newline n the_ps =+ case BI.toForeignPtr the_ps of+ (fp,the_s,l) ->+   unsafePerformIO $ withForeignPtr fp $ \p ->+   do let findit _ s | s == end = return (the_ps, B.empty)+          findit i s = do w <- peekElemOff p s+                          if w == nl+                            then if i == 0+                                 then let left_l = s - the_s+                                      in return (fromForeignPtr fp the_s left_l,+                                                 fromForeignPtr fp s (l - left_l))+                                 else findit (i-1) (s+1)+                            else findit i (s+1)+          nl = BI.c2w '\n'+          end = the_s + l+      findit n the_s
+ src/CommandLine.hs view
@@ -0,0 +1,122 @@+-- Copyright (C) 2005 Benedikt Schmidt+--+-- 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.++-- |A parser for commandlines, returns an arg list and expands+-- format strings given in a translation table. Additionally+-- the commandline can end with "%<" specifying that the command+-- expects input on stdin.+--+-- Some tests for the parser.+--+-- > formatTable = [('s',"<insert subject here>"),+-- >                ('a',"<insert author here>")]+-- >+-- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a+-- > testParser p s ok = case parse p "" s of+-- >                     Left e -> error $ "Parser failed with: " ++ (show e)+-- >                     Right res -> if res == ok+-- >                                  then res+-- >                                  else error $ "Parser failed: got "+-- >                                         ++ (show res) ++ ", expected "+-- >                                         ++ (show ok)+-- >+-- > testCases = [("a b",(["a","b"], False)),+-- >              ("a b %<",(["a","b"], True)),+-- >              ("a b %< ",(["a","b"], True)),+-- >              ("\"arg0 contains spaces \\\"quotes\\\"\" b",+-- >               (["arg0 contains spaces \"quotes\"","b"],False)),+-- >              ("a %s %<",(["a","<insert subject here>"], True))]+-- >+-- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases+module CommandLine ( parseCmd, addUrlencoded ) where+import Text.ParserCombinators.Parsec+import Data.Char ( ord, intToDigit, toUpper )+import Data.List ( find )++-- | assoc list mapping characters to strings+-- eg (c,s) means that %c is replaced by s+type FTable = [(Char,String)]+commandline :: FTable -> Parser ([String], Bool)+commandline ftable = consumeAll (do l <- sepEndBy1 (arg ftable) +                                                   (try separator)+                                    redir <- formatRedir+                                    spaces+                                    return (l,redir))++escape:: Parser String+arg, format, quotedArg, unquotedArg, quoteContent :: FTable -> Parser String+arg ftable = (quotedArg ftable <|> unquotedArg ftable)++unquotedArg ftable = do (try $ format ftable)+                          <|> (many1 $ noneOf [' ', '\t', '"', '%'])++quotedArg ftable = between (char '"') (char '"') $ quoteContent ftable++quoteContent ftable = do s1 <- escape+                               <|> (try $ format ftable)+                               <|> (many1 (noneOf ['"', '\\', '%']))+                         s2 <- quoteContent ftable+                         return $ s1 ++ s2+                     <|> return ""++formatRedir :: Parser Bool+formatRedir = do string "%<"+                 return True+            <|> return False++format ftable = do char '%'+                   c <- oneOf  (map fst ftable)+                   return $ expandFormat ftable c++escape = do char '\\'+            c <- anyChar+            return [c]++consumeAll :: Parser a -> Parser a+consumeAll p = do r <- p+                  eof+                  return r+                +separator :: Parser ()+separator = do skipMany1 space++expandFormat :: FTable -> Char -> String+expandFormat ftable c = case find ((==c) . fst) ftable of+                          Just (_,s) -> s+                          Nothing -> error "impossible"++-- | parse a commandline returning a list of strings +-- (intended to be used as argv) and a bool value which+-- specifies if the command expects input on stdin+-- format specifiers with a mapping in ftable are accepted+-- and replaced by the given strings. E.g. if the ftable is+-- [('s',"Some subject")], then "%s" is replaced by "Some subject"+parseCmd :: FTable -> String -> Either ParseError ([String],Bool)+parseCmd ftable s = parse (commandline ftable) "" s++urlEncode :: String -> String+urlEncode s = concat $ map escapeC s+    where escapeC x = if allowed x then [x] else '%':(intToHex $ ord x)+          intToHex i = map intToDigit [i `div` 16, i `mod` 16]    +          allowed x = x `elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']+                      ++ "!'()*-.~"++-- | for every mapping (c,s), add a mapping with uppercase c+-- and the urlencoded string s+addUrlencoded :: FTable -> FTable+addUrlencoded ftable =+  ftable ++(map (\ (c,x) -> (toUpper c, urlEncode x)) ftable)
+ src/Crypt/SHA256.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-- |+-- Module:    Data.Digest.SHA256+-- Copyright: Zooko O'Whielacronx+-- License:   GPL+--+-- Stability: experimental++-- ByteString-based, zero-copying binding to Crypto++'s sha interface++-- thanks to Don Stewart <dons@galois.com>, Matthew Sackman+-- <matthew@wellquite.org>, Brian O'Sullivan, lispy, Adam Langley++module Crypt.SHA256 ( sha256sum ) where++import Foreign+import Foreign.C.Types+import Numeric (showHex)+import Foreign.C.String ( withCString )+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString as B++sha256sum :: B.ByteString -> String+sha256sum p = unsafePerformIO $+              withCString (take 64 $ repeat 'x') $ \digestCString ->+              unsafeUseAsCStringLen p $ \(ptr,n) ->+              do let digest = castPtr digestCString :: Ptr Word8+                 c_sha256 ptr (fromIntegral n) digest+                 go digest 0 []+  where -- print it in 0-padded hex format+        go :: Ptr Word8 -> Int -> [String] -> IO String+        go q n acc | seq q n >= 32 = return $ concat (reverse acc)+                   | otherwise = do w <- peekElemOff q n+                                    go q (n+1) (draw w : acc)+        draw w = case showHex w [] of+                 [x] -> ['0', x]+                 x   -> x++-- void sha256sum(const unsigned char *d, size_t n, unsigned char *md);+--+foreign import ccall unsafe "sha2.h sha256" c_sha256+    :: Ptr CChar -> CSize -> Ptr Word8 -> IO ()+
+ src/Crypt/sha2.c view
@@ -0,0 +1,950 @@+/*+ * FIPS 180-2 SHA-224/256/384/512 implementation+ * Last update: 02/02/2007+ * Issue date:  04/30/2005+ *+ * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ *    notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ *    notice, this list of conditions and the following disclaimer in the+ *    documentation and/or other materials provided with the distribution.+ * 3. Neither the name of the project nor the names of its contributors+ *    may be used to endorse or promote products derived from this software+ *    without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#if 0+#define UNROLL_LOOPS /* Enable loops unrolling */+#endif++#include <string.h>++#include "sha2.h"++#define SHFR(x, n)    (x >> n)+#define ROTR(x, n)   ((x >> n) | (x << ((sizeof(x) << 3) - n)))+#define ROTL(x, n)   ((x << n) | (x >> ((sizeof(x) << 3) - n)))+#define CH(x, y, z)  ((x & y) ^ (~x & z))+#define MAJ(x, y, z) ((x & y) ^ (x & z) ^ (y & z))++#define SHA256_F1(x) (ROTR(x,  2) ^ ROTR(x, 13) ^ ROTR(x, 22))+#define SHA256_F2(x) (ROTR(x,  6) ^ ROTR(x, 11) ^ ROTR(x, 25))+#define SHA256_F3(x) (ROTR(x,  7) ^ ROTR(x, 18) ^ SHFR(x,  3))+#define SHA256_F4(x) (ROTR(x, 17) ^ ROTR(x, 19) ^ SHFR(x, 10))++#define SHA512_F1(x) (ROTR(x, 28) ^ ROTR(x, 34) ^ ROTR(x, 39))+#define SHA512_F2(x) (ROTR(x, 14) ^ ROTR(x, 18) ^ ROTR(x, 41))+#define SHA512_F3(x) (ROTR(x,  1) ^ ROTR(x,  8) ^ SHFR(x,  7))+#define SHA512_F4(x) (ROTR(x, 19) ^ ROTR(x, 61) ^ SHFR(x,  6))++#define UNPACK32(x, str)                      \+{                                             \+    *((str) + 3) = (uint8) ((x)      );       \+    *((str) + 2) = (uint8) ((x) >>  8);       \+    *((str) + 1) = (uint8) ((x) >> 16);       \+    *((str) + 0) = (uint8) ((x) >> 24);       \+}++#define PACK32(str, x)                        \+{                                             \+    *(x) =   ((uint32) *((str) + 3)      )    \+           | ((uint32) *((str) + 2) <<  8)    \+           | ((uint32) *((str) + 1) << 16)    \+           | ((uint32) *((str) + 0) << 24);   \+}++#define UNPACK64(x, str)                      \+{                                             \+    *((str) + 7) = (uint8) ((x)      );       \+    *((str) + 6) = (uint8) ((x) >>  8);       \+    *((str) + 5) = (uint8) ((x) >> 16);       \+    *((str) + 4) = (uint8) ((x) >> 24);       \+    *((str) + 3) = (uint8) ((x) >> 32);       \+    *((str) + 2) = (uint8) ((x) >> 40);       \+    *((str) + 1) = (uint8) ((x) >> 48);       \+    *((str) + 0) = (uint8) ((x) >> 56);       \+}++#define PACK64(str, x)                        \+{                                             \+    *(x) =   ((uint64) *((str) + 7)      )    \+           | ((uint64) *((str) + 6) <<  8)    \+           | ((uint64) *((str) + 5) << 16)    \+           | ((uint64) *((str) + 4) << 24)    \+           | ((uint64) *((str) + 3) << 32)    \+           | ((uint64) *((str) + 2) << 40)    \+           | ((uint64) *((str) + 1) << 48)    \+           | ((uint64) *((str) + 0) << 56);   \+}++/* Macros used for loops unrolling */++#define SHA256_SCR(i)                         \+{                                             \+    w[i] =  SHA256_F4(w[i -  2]) + w[i -  7]  \+          + SHA256_F3(w[i - 15]) + w[i - 16]; \+}++#define SHA512_SCR(i)                         \+{                                             \+    w[i] =  SHA512_F4(w[i -  2]) + w[i -  7]  \+          + SHA512_F3(w[i - 15]) + w[i - 16]; \+}++#define SHA256_EXP(a, b, c, d, e, f, g, h, j)               \+{                                                           \+    t1 = wv[h] + SHA256_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \+         + sha256_k[j] + w[j];                              \+    t2 = SHA256_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]);       \+    wv[d] += t1;                                            \+    wv[h] = t1 + t2;                                        \+}++#define SHA512_EXP(a, b, c, d, e, f, g ,h, j)               \+{                                                           \+    t1 = wv[h] + SHA512_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \+         + sha512_k[j] + w[j];                              \+    t2 = SHA512_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]);       \+    wv[d] += t1;                                            \+    wv[h] = t1 + t2;                                        \+}++uint32 sha224_h0[8] =+            {0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,+             0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4};++uint32 sha256_h0[8] =+            {0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,+             0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19};++uint64 sha384_h0[8] =+            {0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL,+             0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL,+             0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL,+             0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL};++uint64 sha512_h0[8] =+            {0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL,+             0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL,+             0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL,+             0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL};++uint32 sha256_k[64] =+            {0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,+             0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,+             0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,+             0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,+             0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,+             0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,+             0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,+             0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,+             0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,+             0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,+             0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,+             0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,+             0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,+             0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,+             0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,+             0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2};++uint64 sha512_k[80] =+            {0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL,+             0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL,+             0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL,+             0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL,+             0xd807aa98a3030242ULL, 0x12835b0145706fbeULL,+             0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL,+             0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL,+             0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL,+             0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL,+             0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL,+             0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL,+             0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL,+             0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL,+             0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL,+             0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL,+             0x06ca6351e003826fULL, 0x142929670a0e6e70ULL,+             0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL,+             0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL,+             0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL,+             0x81c2c92e47edaee6ULL, 0x92722c851482353bULL,+             0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL,+             0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL,+             0xd192e819d6ef5218ULL, 0xd69906245565a910ULL,+             0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL,+             0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL,+             0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL,+             0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL,+             0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL,+             0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL,+             0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL,+             0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL,+             0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL,+             0xca273eceea26619cULL, 0xd186b8c721c0c207ULL,+             0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL,+             0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL,+             0x113f9804bef90daeULL, 0x1b710b35131c471bULL,+             0x28db77f523047d84ULL, 0x32caab7b40c72493ULL,+             0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL,+             0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL,+             0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL};++/* SHA-256 functions */++void sha256_transf(sha256_ctx *ctx, const unsigned char *message,+                   unsigned int block_nb)+{+    uint32 w[64];+    uint32 wv[8];+    uint32 t1, t2;+    const unsigned char *sub_block;+    int i;++#ifndef UNROLL_LOOPS+    int j;+#endif++    for (i = 0; i < (int) block_nb; i++) {+        sub_block = message + (i << 6);++#ifndef UNROLL_LOOPS+        for (j = 0; j < 16; j++) {+            PACK32(&sub_block[j << 2], &w[j]);+        }++        for (j = 16; j < 64; j++) {+            SHA256_SCR(j);+        }++        for (j = 0; j < 8; j++) {+            wv[j] = ctx->h[j];+        }++        for (j = 0; j < 64; j++) {+            t1 = wv[7] + SHA256_F2(wv[4]) + CH(wv[4], wv[5], wv[6])+                + sha256_k[j] + w[j];+            t2 = SHA256_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);+            wv[7] = wv[6];+            wv[6] = wv[5];+            wv[5] = wv[4];+            wv[4] = wv[3] + t1;+            wv[3] = wv[2];+            wv[2] = wv[1];+            wv[1] = wv[0];+            wv[0] = t1 + t2;+        }++        for (j = 0; j < 8; j++) {+            ctx->h[j] += wv[j];+        }+#else+        PACK32(&sub_block[ 0], &w[ 0]); PACK32(&sub_block[ 4], &w[ 1]);+        PACK32(&sub_block[ 8], &w[ 2]); PACK32(&sub_block[12], &w[ 3]);+        PACK32(&sub_block[16], &w[ 4]); PACK32(&sub_block[20], &w[ 5]);+        PACK32(&sub_block[24], &w[ 6]); PACK32(&sub_block[28], &w[ 7]);+        PACK32(&sub_block[32], &w[ 8]); PACK32(&sub_block[36], &w[ 9]);+        PACK32(&sub_block[40], &w[10]); PACK32(&sub_block[44], &w[11]);+        PACK32(&sub_block[48], &w[12]); PACK32(&sub_block[52], &w[13]);+        PACK32(&sub_block[56], &w[14]); PACK32(&sub_block[60], &w[15]);++        SHA256_SCR(16); SHA256_SCR(17); SHA256_SCR(18); SHA256_SCR(19);+        SHA256_SCR(20); SHA256_SCR(21); SHA256_SCR(22); SHA256_SCR(23);+        SHA256_SCR(24); SHA256_SCR(25); SHA256_SCR(26); SHA256_SCR(27);+        SHA256_SCR(28); SHA256_SCR(29); SHA256_SCR(30); SHA256_SCR(31);+        SHA256_SCR(32); SHA256_SCR(33); SHA256_SCR(34); SHA256_SCR(35);+        SHA256_SCR(36); SHA256_SCR(37); SHA256_SCR(38); SHA256_SCR(39);+        SHA256_SCR(40); SHA256_SCR(41); SHA256_SCR(42); SHA256_SCR(43);+        SHA256_SCR(44); SHA256_SCR(45); SHA256_SCR(46); SHA256_SCR(47);+        SHA256_SCR(48); SHA256_SCR(49); SHA256_SCR(50); SHA256_SCR(51);+        SHA256_SCR(52); SHA256_SCR(53); SHA256_SCR(54); SHA256_SCR(55);+        SHA256_SCR(56); SHA256_SCR(57); SHA256_SCR(58); SHA256_SCR(59);+        SHA256_SCR(60); SHA256_SCR(61); SHA256_SCR(62); SHA256_SCR(63);++        wv[0] = ctx->h[0]; wv[1] = ctx->h[1];+        wv[2] = ctx->h[2]; wv[3] = ctx->h[3];+        wv[4] = ctx->h[4]; wv[5] = ctx->h[5];+        wv[6] = ctx->h[6]; wv[7] = ctx->h[7];++        SHA256_EXP(0,1,2,3,4,5,6,7, 0); SHA256_EXP(7,0,1,2,3,4,5,6, 1);+        SHA256_EXP(6,7,0,1,2,3,4,5, 2); SHA256_EXP(5,6,7,0,1,2,3,4, 3);+        SHA256_EXP(4,5,6,7,0,1,2,3, 4); SHA256_EXP(3,4,5,6,7,0,1,2, 5);+        SHA256_EXP(2,3,4,5,6,7,0,1, 6); SHA256_EXP(1,2,3,4,5,6,7,0, 7);+        SHA256_EXP(0,1,2,3,4,5,6,7, 8); SHA256_EXP(7,0,1,2,3,4,5,6, 9);+        SHA256_EXP(6,7,0,1,2,3,4,5,10); SHA256_EXP(5,6,7,0,1,2,3,4,11);+        SHA256_EXP(4,5,6,7,0,1,2,3,12); SHA256_EXP(3,4,5,6,7,0,1,2,13);+        SHA256_EXP(2,3,4,5,6,7,0,1,14); SHA256_EXP(1,2,3,4,5,6,7,0,15);+        SHA256_EXP(0,1,2,3,4,5,6,7,16); SHA256_EXP(7,0,1,2,3,4,5,6,17);+        SHA256_EXP(6,7,0,1,2,3,4,5,18); SHA256_EXP(5,6,7,0,1,2,3,4,19);+        SHA256_EXP(4,5,6,7,0,1,2,3,20); SHA256_EXP(3,4,5,6,7,0,1,2,21);+        SHA256_EXP(2,3,4,5,6,7,0,1,22); SHA256_EXP(1,2,3,4,5,6,7,0,23);+        SHA256_EXP(0,1,2,3,4,5,6,7,24); SHA256_EXP(7,0,1,2,3,4,5,6,25);+        SHA256_EXP(6,7,0,1,2,3,4,5,26); SHA256_EXP(5,6,7,0,1,2,3,4,27);+        SHA256_EXP(4,5,6,7,0,1,2,3,28); SHA256_EXP(3,4,5,6,7,0,1,2,29);+        SHA256_EXP(2,3,4,5,6,7,0,1,30); SHA256_EXP(1,2,3,4,5,6,7,0,31);+        SHA256_EXP(0,1,2,3,4,5,6,7,32); SHA256_EXP(7,0,1,2,3,4,5,6,33);+        SHA256_EXP(6,7,0,1,2,3,4,5,34); SHA256_EXP(5,6,7,0,1,2,3,4,35);+        SHA256_EXP(4,5,6,7,0,1,2,3,36); SHA256_EXP(3,4,5,6,7,0,1,2,37);+        SHA256_EXP(2,3,4,5,6,7,0,1,38); SHA256_EXP(1,2,3,4,5,6,7,0,39);+        SHA256_EXP(0,1,2,3,4,5,6,7,40); SHA256_EXP(7,0,1,2,3,4,5,6,41);+        SHA256_EXP(6,7,0,1,2,3,4,5,42); SHA256_EXP(5,6,7,0,1,2,3,4,43);+        SHA256_EXP(4,5,6,7,0,1,2,3,44); SHA256_EXP(3,4,5,6,7,0,1,2,45);+        SHA256_EXP(2,3,4,5,6,7,0,1,46); SHA256_EXP(1,2,3,4,5,6,7,0,47);+        SHA256_EXP(0,1,2,3,4,5,6,7,48); SHA256_EXP(7,0,1,2,3,4,5,6,49);+        SHA256_EXP(6,7,0,1,2,3,4,5,50); SHA256_EXP(5,6,7,0,1,2,3,4,51);+        SHA256_EXP(4,5,6,7,0,1,2,3,52); SHA256_EXP(3,4,5,6,7,0,1,2,53);+        SHA256_EXP(2,3,4,5,6,7,0,1,54); SHA256_EXP(1,2,3,4,5,6,7,0,55);+        SHA256_EXP(0,1,2,3,4,5,6,7,56); SHA256_EXP(7,0,1,2,3,4,5,6,57);+        SHA256_EXP(6,7,0,1,2,3,4,5,58); SHA256_EXP(5,6,7,0,1,2,3,4,59);+        SHA256_EXP(4,5,6,7,0,1,2,3,60); SHA256_EXP(3,4,5,6,7,0,1,2,61);+        SHA256_EXP(2,3,4,5,6,7,0,1,62); SHA256_EXP(1,2,3,4,5,6,7,0,63);++        ctx->h[0] += wv[0]; ctx->h[1] += wv[1];+        ctx->h[2] += wv[2]; ctx->h[3] += wv[3];+        ctx->h[4] += wv[4]; ctx->h[5] += wv[5];+        ctx->h[6] += wv[6]; ctx->h[7] += wv[7];+#endif /* !UNROLL_LOOPS */+    }+}++void sha256(const unsigned char *message, unsigned int len, unsigned char *digest)+{+    sha256_ctx ctx;++    sha256_init(&ctx);+    sha256_update(&ctx, message, len);+    sha256_final(&ctx, digest);+}++void sha256_init(sha256_ctx *ctx)+{+#ifndef UNROLL_LOOPS+    int i;+    for (i = 0; i < 8; i++) {+        ctx->h[i] = sha256_h0[i];+    }+#else+    ctx->h[0] = sha256_h0[0]; ctx->h[1] = sha256_h0[1];+    ctx->h[2] = sha256_h0[2]; ctx->h[3] = sha256_h0[3];+    ctx->h[4] = sha256_h0[4]; ctx->h[5] = sha256_h0[5];+    ctx->h[6] = sha256_h0[6]; ctx->h[7] = sha256_h0[7];+#endif /* !UNROLL_LOOPS */++    ctx->len = 0;+    ctx->tot_len = 0;+}++void sha256_update(sha256_ctx *ctx, const unsigned char *message,+                   unsigned int len)+{+    unsigned int block_nb;+    unsigned int new_len, rem_len, tmp_len;+    const unsigned char *shifted_message;++    tmp_len = SHA256_BLOCK_SIZE - ctx->len;+    rem_len = len < tmp_len ? len : tmp_len;++    memcpy(&ctx->block[ctx->len], message, rem_len);++    if (ctx->len + len < SHA256_BLOCK_SIZE) {+        ctx->len += len;+        return;+    }++    new_len = len - rem_len;+    block_nb = new_len / SHA256_BLOCK_SIZE;++    shifted_message = message + rem_len;++    sha256_transf(ctx, ctx->block, 1);+    sha256_transf(ctx, shifted_message, block_nb);++    rem_len = new_len % SHA256_BLOCK_SIZE;++    memcpy(ctx->block, &shifted_message[block_nb << 6],+           rem_len);++    ctx->len = rem_len;+    ctx->tot_len += (block_nb + 1) << 6;+}++void sha256_final(sha256_ctx *ctx, unsigned char *digest)+{+    unsigned int block_nb;+    unsigned int pm_len;+    unsigned int len_b;++#ifndef UNROLL_LOOPS+    int i;+#endif++    block_nb = (1 + ((SHA256_BLOCK_SIZE - 9)+                     < (ctx->len % SHA256_BLOCK_SIZE)));++    len_b = (ctx->tot_len + ctx->len) << 3;+    pm_len = block_nb << 6;++    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+    ctx->block[ctx->len] = 0x80;+    UNPACK32(len_b, ctx->block + pm_len - 4);++    sha256_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+    for (i = 0 ; i < 8; i++) {+        UNPACK32(ctx->h[i], &digest[i << 2]);+    }+#else+   UNPACK32(ctx->h[0], &digest[ 0]);+   UNPACK32(ctx->h[1], &digest[ 4]);+   UNPACK32(ctx->h[2], &digest[ 8]);+   UNPACK32(ctx->h[3], &digest[12]);+   UNPACK32(ctx->h[4], &digest[16]);+   UNPACK32(ctx->h[5], &digest[20]);+   UNPACK32(ctx->h[6], &digest[24]);+   UNPACK32(ctx->h[7], &digest[28]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-512 functions */++void sha512_transf(sha512_ctx *ctx, const unsigned char *message,+                   unsigned int block_nb)+{+    uint64 w[80];+    uint64 wv[8];+    uint64 t1, t2;+    const unsigned char *sub_block;+    int i, j;++    for (i = 0; i < (int) block_nb; i++) {+        sub_block = message + (i << 7);++#ifndef UNROLL_LOOPS+        for (j = 0; j < 16; j++) {+            PACK64(&sub_block[j << 3], &w[j]);+        }++        for (j = 16; j < 80; j++) {+            SHA512_SCR(j);+        }++        for (j = 0; j < 8; j++) {+            wv[j] = ctx->h[j];+        }++        for (j = 0; j < 80; j++) {+            t1 = wv[7] + SHA512_F2(wv[4]) + CH(wv[4], wv[5], wv[6])+                + sha512_k[j] + w[j];+            t2 = SHA512_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);+            wv[7] = wv[6];+            wv[6] = wv[5];+            wv[5] = wv[4];+            wv[4] = wv[3] + t1;+            wv[3] = wv[2];+            wv[2] = wv[1];+            wv[1] = wv[0];+            wv[0] = t1 + t2;+        }++        for (j = 0; j < 8; j++) {+            ctx->h[j] += wv[j];+        }+#else+        PACK64(&sub_block[  0], &w[ 0]); PACK64(&sub_block[  8], &w[ 1]);+        PACK64(&sub_block[ 16], &w[ 2]); PACK64(&sub_block[ 24], &w[ 3]);+        PACK64(&sub_block[ 32], &w[ 4]); PACK64(&sub_block[ 40], &w[ 5]);+        PACK64(&sub_block[ 48], &w[ 6]); PACK64(&sub_block[ 56], &w[ 7]);+        PACK64(&sub_block[ 64], &w[ 8]); PACK64(&sub_block[ 72], &w[ 9]);+        PACK64(&sub_block[ 80], &w[10]); PACK64(&sub_block[ 88], &w[11]);+        PACK64(&sub_block[ 96], &w[12]); PACK64(&sub_block[104], &w[13]);+        PACK64(&sub_block[112], &w[14]); PACK64(&sub_block[120], &w[15]);++        SHA512_SCR(16); SHA512_SCR(17); SHA512_SCR(18); SHA512_SCR(19);+        SHA512_SCR(20); SHA512_SCR(21); SHA512_SCR(22); SHA512_SCR(23);+        SHA512_SCR(24); SHA512_SCR(25); SHA512_SCR(26); SHA512_SCR(27);+        SHA512_SCR(28); SHA512_SCR(29); SHA512_SCR(30); SHA512_SCR(31);+        SHA512_SCR(32); SHA512_SCR(33); SHA512_SCR(34); SHA512_SCR(35);+        SHA512_SCR(36); SHA512_SCR(37); SHA512_SCR(38); SHA512_SCR(39);+        SHA512_SCR(40); SHA512_SCR(41); SHA512_SCR(42); SHA512_SCR(43);+        SHA512_SCR(44); SHA512_SCR(45); SHA512_SCR(46); SHA512_SCR(47);+        SHA512_SCR(48); SHA512_SCR(49); SHA512_SCR(50); SHA512_SCR(51);+        SHA512_SCR(52); SHA512_SCR(53); SHA512_SCR(54); SHA512_SCR(55);+        SHA512_SCR(56); SHA512_SCR(57); SHA512_SCR(58); SHA512_SCR(59);+        SHA512_SCR(60); SHA512_SCR(61); SHA512_SCR(62); SHA512_SCR(63);+        SHA512_SCR(64); SHA512_SCR(65); SHA512_SCR(66); SHA512_SCR(67);+        SHA512_SCR(68); SHA512_SCR(69); SHA512_SCR(70); SHA512_SCR(71);+        SHA512_SCR(72); SHA512_SCR(73); SHA512_SCR(74); SHA512_SCR(75);+        SHA512_SCR(76); SHA512_SCR(77); SHA512_SCR(78); SHA512_SCR(79);++        wv[0] = ctx->h[0]; wv[1] = ctx->h[1];+        wv[2] = ctx->h[2]; wv[3] = ctx->h[3];+        wv[4] = ctx->h[4]; wv[5] = ctx->h[5];+        wv[6] = ctx->h[6]; wv[7] = ctx->h[7];++        j = 0;++        do {+            SHA512_EXP(0,1,2,3,4,5,6,7,j); j++;+            SHA512_EXP(7,0,1,2,3,4,5,6,j); j++;+            SHA512_EXP(6,7,0,1,2,3,4,5,j); j++;+            SHA512_EXP(5,6,7,0,1,2,3,4,j); j++;+            SHA512_EXP(4,5,6,7,0,1,2,3,j); j++;+            SHA512_EXP(3,4,5,6,7,0,1,2,j); j++;+            SHA512_EXP(2,3,4,5,6,7,0,1,j); j++;+            SHA512_EXP(1,2,3,4,5,6,7,0,j); j++;+        } while (j < 80);++        ctx->h[0] += wv[0]; ctx->h[1] += wv[1];+        ctx->h[2] += wv[2]; ctx->h[3] += wv[3];+        ctx->h[4] += wv[4]; ctx->h[5] += wv[5];+        ctx->h[6] += wv[6]; ctx->h[7] += wv[7];+#endif /* !UNROLL_LOOPS */+    }+}++void sha512(const unsigned char *message, unsigned int len,+            unsigned char *digest)+{+    sha512_ctx ctx;++    sha512_init(&ctx);+    sha512_update(&ctx, message, len);+    sha512_final(&ctx, digest);+}++void sha512_init(sha512_ctx *ctx)+{+#ifndef UNROLL_LOOPS+    int i;+    for (i = 0; i < 8; i++) {+        ctx->h[i] = sha512_h0[i];+    }+#else+    ctx->h[0] = sha512_h0[0]; ctx->h[1] = sha512_h0[1];+    ctx->h[2] = sha512_h0[2]; ctx->h[3] = sha512_h0[3];+    ctx->h[4] = sha512_h0[4]; ctx->h[5] = sha512_h0[5];+    ctx->h[6] = sha512_h0[6]; ctx->h[7] = sha512_h0[7];+#endif /* !UNROLL_LOOPS */++    ctx->len = 0;+    ctx->tot_len = 0;+}++void sha512_update(sha512_ctx *ctx, const unsigned char *message,+                   unsigned int len)+{+    unsigned int block_nb;+    unsigned int new_len, rem_len, tmp_len;+    const unsigned char *shifted_message;++    tmp_len = SHA512_BLOCK_SIZE - ctx->len;+    rem_len = len < tmp_len ? len : tmp_len;++    memcpy(&ctx->block[ctx->len], message, rem_len);++    if (ctx->len + len < SHA512_BLOCK_SIZE) {+        ctx->len += len;+        return;+    }++    new_len = len - rem_len;+    block_nb = new_len / SHA512_BLOCK_SIZE;++    shifted_message = message + rem_len;++    sha512_transf(ctx, ctx->block, 1);+    sha512_transf(ctx, shifted_message, block_nb);++    rem_len = new_len % SHA512_BLOCK_SIZE;++    memcpy(ctx->block, &shifted_message[block_nb << 7],+           rem_len);++    ctx->len = rem_len;+    ctx->tot_len += (block_nb + 1) << 7;+}++void sha512_final(sha512_ctx *ctx, unsigned char *digest)+{+    unsigned int block_nb;+    unsigned int pm_len;+    unsigned int len_b;++#ifndef UNROLL_LOOPS+    int i;+#endif++    block_nb = 1 + ((SHA512_BLOCK_SIZE - 17)+                     < (ctx->len % SHA512_BLOCK_SIZE));++    len_b = (ctx->tot_len + ctx->len) << 3;+    pm_len = block_nb << 7;++    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+    ctx->block[ctx->len] = 0x80;+    UNPACK32(len_b, ctx->block + pm_len - 4);++    sha512_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+    for (i = 0 ; i < 8; i++) {+        UNPACK64(ctx->h[i], &digest[i << 3]);+    }+#else+    UNPACK64(ctx->h[0], &digest[ 0]);+    UNPACK64(ctx->h[1], &digest[ 8]);+    UNPACK64(ctx->h[2], &digest[16]);+    UNPACK64(ctx->h[3], &digest[24]);+    UNPACK64(ctx->h[4], &digest[32]);+    UNPACK64(ctx->h[5], &digest[40]);+    UNPACK64(ctx->h[6], &digest[48]);+    UNPACK64(ctx->h[7], &digest[56]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-384 functions */++void sha384(const unsigned char *message, unsigned int len,+            unsigned char *digest)+{+    sha384_ctx ctx;++    sha384_init(&ctx);+    sha384_update(&ctx, message, len);+    sha384_final(&ctx, digest);+}++void sha384_init(sha384_ctx *ctx)+{+#ifndef UNROLL_LOOPS+    int i;+    for (i = 0; i < 8; i++) {+        ctx->h[i] = sha384_h0[i];+    }+#else+    ctx->h[0] = sha384_h0[0]; ctx->h[1] = sha384_h0[1];+    ctx->h[2] = sha384_h0[2]; ctx->h[3] = sha384_h0[3];+    ctx->h[4] = sha384_h0[4]; ctx->h[5] = sha384_h0[5];+    ctx->h[6] = sha384_h0[6]; ctx->h[7] = sha384_h0[7];+#endif /* !UNROLL_LOOPS */++    ctx->len = 0;+    ctx->tot_len = 0;+}++void sha384_update(sha384_ctx *ctx, const unsigned char *message,+                   unsigned int len)+{+    unsigned int block_nb;+    unsigned int new_len, rem_len, tmp_len;+    const unsigned char *shifted_message;++    tmp_len = SHA384_BLOCK_SIZE - ctx->len;+    rem_len = len < tmp_len ? len : tmp_len;++    memcpy(&ctx->block[ctx->len], message, rem_len);++    if (ctx->len + len < SHA384_BLOCK_SIZE) {+        ctx->len += len;+        return;+    }++    new_len = len - rem_len;+    block_nb = new_len / SHA384_BLOCK_SIZE;++    shifted_message = message + rem_len;++    sha512_transf(ctx, ctx->block, 1);+    sha512_transf(ctx, shifted_message, block_nb);++    rem_len = new_len % SHA384_BLOCK_SIZE;++    memcpy(ctx->block, &shifted_message[block_nb << 7],+           rem_len);++    ctx->len = rem_len;+    ctx->tot_len += (block_nb + 1) << 7;+}++void sha384_final(sha384_ctx *ctx, unsigned char *digest)+{+    unsigned int block_nb;+    unsigned int pm_len;+    unsigned int len_b;++#ifndef UNROLL_LOOPS+    int i;+#endif++    block_nb = (1 + ((SHA384_BLOCK_SIZE - 17)+                     < (ctx->len % SHA384_BLOCK_SIZE)));++    len_b = (ctx->tot_len + ctx->len) << 3;+    pm_len = block_nb << 7;++    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+    ctx->block[ctx->len] = 0x80;+    UNPACK32(len_b, ctx->block + pm_len - 4);++    sha512_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+    for (i = 0 ; i < 6; i++) {+        UNPACK64(ctx->h[i], &digest[i << 3]);+    }+#else+    UNPACK64(ctx->h[0], &digest[ 0]);+    UNPACK64(ctx->h[1], &digest[ 8]);+    UNPACK64(ctx->h[2], &digest[16]);+    UNPACK64(ctx->h[3], &digest[24]);+    UNPACK64(ctx->h[4], &digest[32]);+    UNPACK64(ctx->h[5], &digest[40]);+#endif /* !UNROLL_LOOPS */+}++/* SHA-224 functions */++void sha224(const unsigned char *message, unsigned int len,+            unsigned char *digest)+{+    sha224_ctx ctx;++    sha224_init(&ctx);+    sha224_update(&ctx, message, len);+    sha224_final(&ctx, digest);+}++void sha224_init(sha224_ctx *ctx)+{+#ifndef UNROLL_LOOPS+    int i;+    for (i = 0; i < 8; i++) {+        ctx->h[i] = sha224_h0[i];+    }+#else+    ctx->h[0] = sha224_h0[0]; ctx->h[1] = sha224_h0[1];+    ctx->h[2] = sha224_h0[2]; ctx->h[3] = sha224_h0[3];+    ctx->h[4] = sha224_h0[4]; ctx->h[5] = sha224_h0[5];+    ctx->h[6] = sha224_h0[6]; ctx->h[7] = sha224_h0[7];+#endif /* !UNROLL_LOOPS */++    ctx->len = 0;+    ctx->tot_len = 0;+}++void sha224_update(sha224_ctx *ctx, const unsigned char *message,+                   unsigned int len)+{+    unsigned int block_nb;+    unsigned int new_len, rem_len, tmp_len;+    const unsigned char *shifted_message;++    tmp_len = SHA224_BLOCK_SIZE - ctx->len;+    rem_len = len < tmp_len ? len : tmp_len;++    memcpy(&ctx->block[ctx->len], message, rem_len);++    if (ctx->len + len < SHA224_BLOCK_SIZE) {+        ctx->len += len;+        return;+    }++    new_len = len - rem_len;+    block_nb = new_len / SHA224_BLOCK_SIZE;++    shifted_message = message + rem_len;++    sha256_transf(ctx, ctx->block, 1);+    sha256_transf(ctx, shifted_message, block_nb);++    rem_len = new_len % SHA224_BLOCK_SIZE;++    memcpy(ctx->block, &shifted_message[block_nb << 6],+           rem_len);++    ctx->len = rem_len;+    ctx->tot_len += (block_nb + 1) << 6;+}++void sha224_final(sha224_ctx *ctx, unsigned char *digest)+{+    unsigned int block_nb;+    unsigned int pm_len;+    unsigned int len_b;++#ifndef UNROLL_LOOPS+    int i;+#endif++    block_nb = (1 + ((SHA224_BLOCK_SIZE - 9)+                     < (ctx->len % SHA224_BLOCK_SIZE)));++    len_b = (ctx->tot_len + ctx->len) << 3;+    pm_len = block_nb << 6;++    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);+    ctx->block[ctx->len] = 0x80;+    UNPACK32(len_b, ctx->block + pm_len - 4);++    sha256_transf(ctx, ctx->block, block_nb);++#ifndef UNROLL_LOOPS+    for (i = 0 ; i < 7; i++) {+        UNPACK32(ctx->h[i], &digest[i << 2]);+    }+#else+   UNPACK32(ctx->h[0], &digest[ 0]);+   UNPACK32(ctx->h[1], &digest[ 4]);+   UNPACK32(ctx->h[2], &digest[ 8]);+   UNPACK32(ctx->h[3], &digest[12]);+   UNPACK32(ctx->h[4], &digest[16]);+   UNPACK32(ctx->h[5], &digest[20]);+   UNPACK32(ctx->h[6], &digest[24]);+#endif /* !UNROLL_LOOPS */+}++#ifdef TEST_VECTORS++/* FIPS 180-2 Validation tests */++#include <stdio.h>+#include <stdlib.h>++void test(const unsigned char *vector, unsigned char *digest,+          unsigned int digest_size)+{+    unsigned char output[2 * SHA512_DIGEST_SIZE + 1];+    int i;++    output[2 * digest_size] = '\0';++    for (i = 0; i < (int) digest_size ; i++) {+       sprintf((char *) output + 2 * i, "%02x", digest[i]);+    }++    printf("H: %s\n", output);+    if (strcmp((char *) vector, (char *) output)) {+        fprintf(stderr, "Test failed.\n");+        exit(EXIT_FAILURE);+    }+}++int main()+{+    static const unsigned char *vectors[4][3] =+    {   /* SHA-224 */+        {+        "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7",+        "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525",+        "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67",+        },+        /* SHA-256 */+        {+        "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad",+        "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1",+        "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0",+        },+        /* SHA-384 */+        {+        "cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605a43ff5bed"+        "8086072ba1e7cc2358baeca134c825a7",+        "09330c33f71147e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712"+        "fcc7c71a557e2db966c3e9fa91746039",+        "9d0e1809716474cb086e834e310a4a1ced149e9c00f248527972cec5704c2a5b"+        "07b8b3dc38ecc4ebae97ddd87f3d8985",+        },+        /* SHA-512 */+        {+        "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a"+        "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f",+        "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018"+        "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909",+        "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb"+        "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"+        }+    };++    static const unsigned char message1[] = "abc";+    static const unsigned char message2a[] = "abcdbcdecdefdefgefghfghighijhi"+                                             "jkijkljklmklmnlmnomnopnopq";+    static const unsigned char message2b[] =+                                      "abcdefghbcdefghicdefghijdefghijkefghij"+                                      "klfghijklmghijklmnhijklmnoijklmnopjklm"+                                      "nopqklmnopqrlmnopqrsmnopqrstnopqrstu";+    unsigned char *message3;+    unsigned int message3_len  = 1000000;+    unsigned char digest[SHA512_DIGEST_SIZE];++    message3 = malloc(message3_len);+    if (message3 == NULL) {+        fprintf(stderr, "Can't allocate memory\n");+        return -1;+    }+    memset(message3, 'a', message3_len);++    printf("SHA-2 FIPS 180-2 Validation tests\n\n");+    printf("SHA-224 Test vectors\n");++    sha224(message1, strlen((char *) message1), digest);+    test(vectors[0][0], digest, SHA224_DIGEST_SIZE);+    sha224(message2a, strlen((char *) message2a), digest);+    test(vectors[0][1], digest, SHA224_DIGEST_SIZE);+    sha224(message3, message3_len, digest);+    test(vectors[0][2], digest, SHA224_DIGEST_SIZE);+    printf("\n");++    printf("SHA-256 Test vectors\n");++    sha256(message1, strlen((char *) message1), digest);+    test(vectors[1][0], digest, SHA256_DIGEST_SIZE);+    sha256(message2a, strlen((char *) message2a), digest);+    test(vectors[1][1], digest, SHA256_DIGEST_SIZE);+    sha256(message3, message3_len, digest);+    test(vectors[1][2], digest, SHA256_DIGEST_SIZE);+    printf("\n");++    printf("SHA-384 Test vectors\n");++    sha384(message1, strlen((char *) message1), digest);+    test(vectors[2][0], digest, SHA384_DIGEST_SIZE);+    sha384(message2b, strlen((char *) message2b), digest);+    test(vectors[2][1], digest, SHA384_DIGEST_SIZE);+    sha384(message3, message3_len, digest);+    test(vectors[2][2], digest, SHA384_DIGEST_SIZE);+    printf("\n");++    printf("SHA-512 Test vectors\n");++    sha512(message1, strlen((char *) message1), digest);+    test(vectors[3][0], digest, SHA512_DIGEST_SIZE);+    sha512(message2b, strlen((char *) message2b), digest);+    test(vectors[3][1], digest, SHA512_DIGEST_SIZE);+    sha512(message3, message3_len, digest);+    test(vectors[3][2], digest, SHA512_DIGEST_SIZE);+    printf("\n");++    printf("All tests passed.\n");++    return 0;+}++#endif /* TEST_VECTORS */+
+ src/Crypt/sha2.h view
@@ -0,0 +1,108 @@+/*+ * FIPS 180-2 SHA-224/256/384/512 implementation+ * Last update: 02/02/2007+ * Issue date:  04/30/2005+ *+ * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ *    notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ *    notice, this list of conditions and the following disclaimer in the+ *    documentation and/or other materials provided with the distribution.+ * 3. Neither the name of the project nor the names of its contributors+ *    may be used to endorse or promote products derived from this software+ *    without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#ifndef SHA2_H+#define SHA2_H++#define SHA224_DIGEST_SIZE ( 224 / 8)+#define SHA256_DIGEST_SIZE ( 256 / 8)+#define SHA384_DIGEST_SIZE ( 384 / 8)+#define SHA512_DIGEST_SIZE ( 512 / 8)++#define SHA256_BLOCK_SIZE  ( 512 / 8)+#define SHA512_BLOCK_SIZE  (1024 / 8)+#define SHA384_BLOCK_SIZE  SHA512_BLOCK_SIZE+#define SHA224_BLOCK_SIZE  SHA256_BLOCK_SIZE++#ifndef SHA2_TYPES+#define SHA2_TYPES+typedef unsigned char uint8;+typedef unsigned int  uint32;+typedef unsigned long long uint64;+#endif++#ifdef __cplusplus+extern "C" {+#endif++typedef struct {+    unsigned int tot_len;+    unsigned int len;+    unsigned char block[2 * SHA256_BLOCK_SIZE];+    uint32 h[8];+} sha256_ctx;++typedef struct {+    unsigned int tot_len;+    unsigned int len;+    unsigned char block[2 * SHA512_BLOCK_SIZE];+    uint64 h[8];+} sha512_ctx;++typedef sha512_ctx sha384_ctx;+typedef sha256_ctx sha224_ctx;++void sha224_init(sha224_ctx *ctx);+void sha224_update(sha224_ctx *ctx, const unsigned char *message,+                   unsigned int len);+void sha224_final(sha224_ctx *ctx, unsigned char *digest);+void sha224(const unsigned char *message, unsigned int len,+            unsigned char *digest);++void sha256_init(sha256_ctx * ctx);+void sha256_update(sha256_ctx *ctx, const unsigned char *message,+                   unsigned int len);+void sha256_final(sha256_ctx *ctx, unsigned char *digest);+void sha256(const unsigned char *message, unsigned int len,+            unsigned char *digest);++void sha384_init(sha384_ctx *ctx);+void sha384_update(sha384_ctx *ctx, const unsigned char *message,+                   unsigned int len);+void sha384_final(sha384_ctx *ctx, unsigned char *digest);+void sha384(const unsigned char *message, unsigned int len,+            unsigned char *digest);++void sha512_init(sha512_ctx *ctx);+void sha512_update(sha512_ctx *ctx, const unsigned char *message,+                   unsigned int len);+void sha512_final(sha512_ctx *ctx, unsigned char *digest);+void sha512(const unsigned char *message, unsigned int len,+            unsigned char *digest);++#ifdef __cplusplus+}+#endif++#endif /* !SHA2_H */+
+ src/Darcs/ArgumentDefaults.lhs view
@@ -0,0 +1,172 @@+%  Copyright (C) 2003 David Roundy+%+%  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.++\begin{code}+module Darcs.ArgumentDefaults ( get_default_flags ) where+import Data.Maybe ( catMaybes, listToMaybe, mapMaybe )++import Darcs.Arguments ( DarcsFlag,+                         DarcsOption( DarcsArgOption, DarcsNoArgOption, DarcsMultipleChoiceOption ),+                         arein, isin )+import Darcs.Commands ( CommandControl( Command_data ),+                        command_alloptions )+import Darcs.Commands.Help ( command_control_list )+import Darcs.Repository.Prefs ( get_global, get_preflist )+\end{code}++\paragraph{defaults}\label{defaults}++Default values for darcs commands can be configured on a per-repository+basis by editing (and possibly creating) the \verb!_darcs/prefs/defaults!+file.  Each line of this file has the following form:+\begin{verbatim}+COMMAND FLAG VALUE+\end{verbatim}+where \verb!COMMAND! is either the name of the command to which the default+applies, or \verb!ALL! to indicate that the default applies to all commands+accepting that flag.  The \verb!FLAG! term is the name of the long argument+option without the ``\verb!--!'', i.e.\ \verb!verbose! rather than+\verb!--verbose!.  Finally, the \verb!VALUE! option can be omitted if the+flag is one such as \verb!verbose! that doesn't involve a value.+If the value has spaces in it, use single quotes, not double quotes, to surround it. +Each line only takes one flag.  To set multiple defaults for the same+command (or for \verb!ALL! commands), use multiple lines.++Note that the use of \verb|ALL| easily can have unpredicted consequences,+especially if commands in newer versions of darcs accepts flags that they+didn't in previous versions. A command like \verb|obliterate| could be+devastating with the ``wrong'' flags (for example --all). Only use safe+flags with \verb|ALL|.++\begin{tabular}{ll}+{\tt \verb!~/.darcs/defaults!} & provides defaults for this user account, on MS Windows~\ref{ms_win} \\+{\tt \verb!repo/_darcs/prefs/defaults!} & provides defaults for one project,\\+  & overrules changes per user \\+\end{tabular}++For example, if your system clock is bizarre, you could instruct darcs to+always ignore the file modification times by adding the following line to+your \verb!_darcs/prefs/defaults! file.  (Note that this would have to be+done for each repository!)+\begin{verbatim}+ALL ignore-times+\end{verbatim}++If you never want to run a test when recording to a particular repository+(but still want to do so when running+\verb'check' on that repository), and like to name+all your patches ``Stupid patch'', you could use the following:+\begin{verbatim}+record no-test+record patch-name Stupid patch+\end{verbatim}++If you would like a command to be run every time patches are recorded+in a particular repository (for example if you have one central+repository, that all developers contribute to), then you can set apply+to always run a command when apply is successful.  For example, if you+need to make sure that the files in the repository have the correct+access rights you might use the following.  There are two things+to note about using darcs this way:+\begin{itemize}+\item Without the second line you will get errors, because the sub+      process that runs apply cannot prompt interactively.+\item Whatever script is run by the post apply command should not be+      added to the repository with \verb!darcs add!; doing so would+      allow people to modify that file and then run arbitrary scripts on+      your main repository, possibly damaging or violating security.+\end{itemize}+\begin{verbatim}+apply posthook chmod -R a+r *+apply run-posthook+\end{verbatim}++Similarly, if you need a command to run automatically before darcs+performs an action you can use a prehook.  Using prehooks it could be+possible to canonicalize line endings before recording patches.++There are some options which are meant specifically for use in+\verb!_darcs/prefs/defaults!. One of them is \verb!--disable!. As the name+suggests, this option will disable every command that got it as argument. So,+if you are afraid that you could damage your repositories by inadvertent use of+a command like amend-record, add the following line to+\verb!_darcs/prefs/defaults!:+\begin{verbatim}+amend-record disable+\end{verbatim}++Also, a global preferences file can be created with the name+\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}. +Options present there will be added to the repository-specific preferences.+If they conflict with repository-specific options, the repository-specific+ones will take precedence.++\begin{code}+get_default_flags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]+get_default_flags com com_opts already = do+    repo_defs   <- default_content $ get_preflist "defaults"+    global_defs <- default_content $ get_global   "defaults"+    let repo_flags = get_flags_from com com_opts already repo_defs+        global_flags = get_flags_from com com_opts+                                          (already++repo_flags) global_defs+    return $ repo_flags ++ global_flags++get_flags_from :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag]+get_flags_from com com_opts already defs =+    options_for com_defs com_opts com_opts +++    options_for all_defs com_opts all_opts+    where com_defs = filter (\ (c,_,_) -> c == com) defs+          all_defs = filter (\ (c,_,_) -> c == "ALL") defs+          options_for d o ao = concatMap (find_option o ao already) d+          all_opts = concatMap get_opts command_control_list+          get_opts (Command_data c) = let (o1, o2) = command_alloptions c+                                      in o1 ++ o2+          get_opts _                = []++find_option :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag]+find_option opts all_opts already (c, f, d) =+    if null $ mapMaybe choose_option all_opts+    then error $ "Bad default option: command '"++c++"' has no option '"++f++"'."+    else concat $ mapMaybe choose_option opts+    where choose_option (DarcsNoArgOption _ fls o _)+              | o `elem` already = Just []+              | f `elem` fls = if null d+                               then Just [o]+                               else error $ "Bad default option: '"++f+                                        ++"' takes no argument, but '"++d+                                        ++"' argument given."+          choose_option (DarcsArgOption _ fls o _ _)+              | o `isin` already = Just []+              | f `elem` fls = if null d+                               then error $ "Bad default option: '"++f+                                        ++"' requires an argument, but no "+                                        ++"argument given."+                               else Just [o d]+          choose_option (DarcsMultipleChoiceOption os)+              | os `arein` already = Just []+              | otherwise = listToMaybe $ mapMaybe choose_option os+          choose_option _ = Nothing++default_content :: IO [String] -> IO [(String,String,String)]+default_content = fmap (catMaybes . map (doline.words))+    where doline (c:a:r) = Just (c, drop_dashdash a, unwords r)+          doline _ = Nothing+          drop_dashdash ('-':'-':a) = a+          drop_dashdash a = a++\end{code}+
+ src/Darcs/Arguments.lhs view
@@ -0,0 +1,1618 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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.++\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Arguments ( DarcsFlag( .. ), flagToString,+                         maxCount,+                         isin, arein,+                         definePatches, defineChanges,+                         fixFilePathOrStd, fixUrl,+                         fixSubPaths, areFileArgs,+                         DarcsOption( .. ), option_from_darcsoption,+                         help, list_options, list_files,+                         any_verbosity, disable, restrict_paths,+                         notest, test, working_repo_dir,+                         testByDefault,+                         remote_repo,+                         leave_test_dir,+                         possibly_remote_repo_dir, get_repourl,+                         list_registered_files, list_unregistered_files,+                         author, get_author, get_easy_author, get_sendmail_cmd,+                         patchname_option, distname_option,+                         logfile, rmlogfile, from_opt, subject, get_subject,+                         in_reply_to, get_in_reply_to,+                         target, cc, get_cc, output, output_auto_name,+                         recursive, inventory_choices, get_inventory_choices,+                         askdeps, ignoretimes, lookforadds,+                         ask_long_comment, sendmail_cmd,+                         environmentHelpSendmail,+                         sign, verify, edit_description,+                         reponame, tagname, creatorhash,+                         apply_conflict_options, reply,+                         pull_conflict_options, use_external_merge,+                         deps_sel, nocompress,+                         uncompress_nocompress, repo_combinator,+                         options_latex, reorder_patches,+                         noskip_boring, allow_problematic_filenames,+                         applyas, human_readable,+                         changes_reverse, only_to_files,+                         changes_format, match_one_context, match_one_nontag,+                         match_maxcount,+                         send_to_context,+                         get_context,+                         pipe_interactive, all_interactive,+                         all_pipe_interactive,+                         summary, unified, tokens,+                         checkpoint, partial, partial_check,+                         diff_cmd_flag, diffflags, unidiff, xmloutput,+                         force_replace, dry_run, dry_run_noxml,+                         print_dry_run_message_and_exit, showFriendly,+                         match_one, match_several, match_range,+                         match_several_or_range, happy_forwarding,+                         match_several_or_last,+                         set_default,+                         fancy_move_add,+                         set_scripts_executable,+                         sibling, flagsToSiblings, relink, relink_pristine, nolinks,+                         files, directories, pending,+                         posthook_cmd, posthook_prompt,+                         get_posthook_cmd,+                         prehook_cmd, prehook_prompt,+                         get_prehook_cmd, nullFlag,+                         umask_option,+                         store_in_memory,+                         patch_select_flag,+                         network_options, no_cache,+                         allow_unrelated_repos,+                         check_or_repair+                      ) where+import System.Console.GetOpt+import System.Directory ( doesDirectoryExist )+import Data.List ( (\\), nub )+import Data.Maybe ( fromMaybe, listToMaybe )+import System.Exit ( ExitCode(ExitSuccess), exitWith )+import Data.Maybe ( catMaybes )+import Control.Monad ( when, unless )+import Data.Char ( isDigit )+#ifndef WIN32+import Printer ( renderString )+import System.Posix.Env ( setEnv )+import Darcs.Patch ( list_touched_files )+import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )+#endif++import Darcs.Hopefully ( PatchInfoAnd, info, hopefullyM )+import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xml_summary )+import Darcs.Patch.Info ( to_xml )+import Darcs.Ordered ( FL, mapFL )+import qualified Darcs.Patch ( summary )+import Darcs.Utils ( askUser, maybeGetEnv, firstNotBlank, firstJustIO,+                     withCurrentDirectory )+import Darcs.Repository.Prefs ( boring_file_filter, get_preflist, get_global )+import Darcs.URL ( is_file )+import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath,+                        makeSubPathOf, simpleSubPath,+                        ioAbsolute, ioAbsoluteOrStd,+                        makeAbsolute, makeAbsoluteOrStd, rootDirectory )+import Darcs.Patch.MatchData ( patch_match )+import Darcs.Flags ( DarcsFlag(..), maxCount )+import Darcs.Repository ( slurp_pending, withRepository, ($-) )+import Darcs.Repository.HashedRepo ( slurp_all_but_darcs )+import Darcs.SlurpDirectory ( list_slurpy )+import Darcs.Global ( darcsdir )+import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insert_before_lastline,+                 prefix )+import URL ( pipeliningEnabledByDefault )+#include "impossible.h"++data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String+                   deriving (Eq, Show, Ord)++-- getContent is very tedious to write, but this is the only way (that+-- I know of) to guarantee that it works for all flags (which then+-- guarantees that isAnAbsolute, isa, flagToString, etc also work+-- properly)++-- | 'get_content' returns the content of a flag, if any.+-- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent+-- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@+getContent :: DarcsFlag -> FlagContent+getContent (PatchName s) = StringContent s+getContent (Output s) = AbsoluteOrStdContent s+getContent Verbose = NoContent+getContent Help = NoContent+getContent ListOptions = NoContent+getContent Test = NoContent+getContent NoTest = NoContent+getContent OnlyChangesToFiles = NoContent+getContent LeaveTestDir = NoContent+getContent NoLeaveTestDir = NoContent+getContent Timings = NoContent+getContent Debug = NoContent+getContent DebugVerbose = NoContent+getContent DebugHTTP = NoContent+getContent NormalVerbosity = NoContent+getContent Quiet = NoContent+getContent (Target s) = StringContent s+getContent (Cc s) = StringContent s+getContent (Subject s) = StringContent s+getContent (InReplyTo s) = StringContent s+getContent (SendmailCmd s) = StringContent s+getContent (Author s) = StringContent s+getContent (OnePatch s) = StringContent s+getContent (SeveralPatch s) = StringContent s+getContent (AfterPatch s) = StringContent s+getContent (UpToPatch s) = StringContent s+getContent (TagName s) = StringContent s+getContent (LastN s) = StringContent (show s)+getContent (MaxCount s) = StringContent (show s)+getContent (OneTag s) = StringContent s+getContent (AfterTag s) = StringContent s+getContent (UpToTag s) = StringContent s+getContent (Context s) = AbsoluteContent s+getContent (LogFile s) = AbsoluteContent s+getContent (OutputAutoName s) = AbsoluteContent s+getContent NumberPatches = NoContent+getContent (PatchIndexRange _ _) = NoContent -- FIXME this doesn't fit into a neat category+getContent Count = NoContent+getContent All = NoContent+getContent Recursive = NoContent+getContent NoRecursive = NoContent+getContent Reorder = NoContent+getContent RestrictPaths = NoContent+getContent DontRestrictPaths = NoContent+getContent AskDeps = NoContent+getContent NoAskDeps = NoContent+getContent RmLogFile = NoContent+getContent (DistName s) = StringContent s+getContent (CreatorHash s) = StringContent s+getContent (SignAs s) = StringContent s+getContent (SignSSL s) = StringContent s+getContent (Verify s) = AbsoluteContent s+getContent (VerifySSL s) = AbsoluteContent s+getContent IgnoreTimes = NoContent+getContent LookForAdds = NoContent+getContent NoLookForAdds = NoContent+getContent AnyOrder = NoContent+getContent Intersection = NoContent+getContent Unified = NoContent+getContent Union = NoContent+getContent Complement = NoContent+getContent Sign = NoContent+getContent NoSign = NoContent+getContent HappyForwarding = NoContent+getContent SSHControlMaster = NoContent+getContent NoSSHControlMaster = NoContent+getContent (Toks s) = StringContent s+getContent (WorkRepoDir s) = StringContent s+getContent (WorkRepoUrl s) = StringContent s+getContent (RemoteRepo s) = StringContent s+getContent (NewRepo s) = StringContent s+getContent (Reply s) = StringContent s+getContent EditDescription = NoContent+getContent NoEditDescription = NoContent+getContent EditLongComment = NoContent+getContent NoEditLongComment = NoContent+getContent PromptLongComment = NoContent+getContent AllowConflicts = NoContent+getContent MarkConflicts = NoContent+getContent NoAllowConflicts = NoContent+getContent Boring = NoContent+getContent AllowCaseOnly = NoContent+getContent AllowWindowsReserved = NoContent+getContent DontGrabDeps = NoContent+getContent DontPromptForDependencies = NoContent+getContent PromptForDependencies = NoContent+getContent Compress = NoContent+getContent NoCompress = NoContent+getContent UnCompress = NoContent+getContent MachineReadable = NoContent+getContent HumanReadable = NoContent+getContent Pipe = NoContent+getContent Interactive = NoContent+getContent Summary = NoContent+getContent NoSummary = NoContent+getContent (ApplyAs s) = StringContent s+getContent (DiffCmd s) = StringContent s+getContent (ExternalMerge s) = StringContent s+getContent (DiffFlags s) = StringContent s+getContent (OnePattern _) = NoContent -- FIXME!!!+getContent (SeveralPattern _) = NoContent -- FIXME!!!+getContent (UpToPattern _) = NoContent -- FIXME!!!+getContent (AfterPattern _) = NoContent -- FIXME!!!+getContent Reverse = NoContent+getContent CheckPoint = NoContent+getContent Partial = NoContent+getContent Complete = NoContent+getContent Lazy = NoContent+getContent Ephemeral = NoContent+getContent (FixFilePath _ _) = NoContent -- FIXME!!!+getContent XMLOutput = NoContent+getContent ForceReplace = NoContent+getContent NonApply = NoContent+getContent NonVerify = NoContent+getContent NonForce = NoContent+getContent DryRun = NoContent+getContent SetDefault = NoContent+getContent NoSetDefault = NoContent+getContent FancyMoveAdd = NoContent+getContent NoFancyMoveAdd = NoContent+getContent Disable = NoContent+getContent SetScriptsExecutable = NoContent+getContent DontSetScriptsExecutable = NoContent+getContent UseHashedInventory = NoContent+getContent UseOldFashionedInventory = NoContent+getContent UseFormat2 = NoContent+getContent PristinePlain = NoContent+getContent PristineNone = NoContent+getContent NoUpdateWorking = NoContent+getContent Relink = NoContent+getContent RelinkPristine = NoContent+getContent NoLinks = NoContent+getContent Files = NoContent+getContent NoFiles = NoContent+getContent Directories = NoContent+getContent NoDirectories = NoContent+getContent Pending = NoContent+getContent NoPending = NoContent+getContent NoPosthook = NoContent+getContent AskPosthook = NoContent+getContent (Sibling s) = AbsoluteContent s+getContent (PosthookCmd s) = StringContent s+getContent RunPosthook = NoContent+getContent NoPrehook = NoContent+getContent RunPrehook = NoContent+getContent AskPrehook = NoContent+getContent StoreInMemory = NoContent+getContent HTTPPipelining = NoContent+getContent NoHTTPPipelining = NoContent+getContent NoCache = NoContent+getContent NullFlag = NoContent+getContent (PrehookCmd s) = StringContent s+getContent (UMask s) = StringContent s+getContent AllowUnrelatedRepos = NoContent+getContent Check = NoContent+getContent Repair = NoContent++get_content :: DarcsFlag -> Maybe String+get_content f = do StringContent s <- Just $ getContent f+                   return s++-- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument.+-- @b@ typically is a Flag constructor expecting a string+-- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true.+isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool+a `isa` b = case get_content a of+            Nothing -> False+            Just s -> a == b s++-- | @a `'isAnAbsolute'` b@ tests whether @a@ is flag @b@ with an absolute path argument.+-- @b@ typically is a Flag constructor expecting an absolute path argument+-- For example, @(Context contextfile) `isAnAbsolute` Context@ returns true.+isAnAbsolute :: DarcsFlag -> (AbsolutePath -> DarcsFlag) -> Bool+isAnAbsolute f x = case getContent f of+                  AbsoluteContent s -> f == x s+                  _ -> False++-- | @a `'isAnAbsoluteOrStd'` b@ tests whether @a@ is flag @b@ with a path argument.+-- @b@ typically is a Flag constructor expecting a path argument+-- For example, @(Output o) `isAnAbsoluteOrStd` @ returns true.+isAnAbsoluteOrStd :: DarcsFlag -> (AbsolutePathOrStd -> DarcsFlag) -> Bool+isAnAbsoluteOrStd f x = case getContent f of+                          AbsoluteOrStdContent s -> f == x s+                          _ -> False++isin :: (String->DarcsFlag) -> [DarcsFlag] -> Bool+f `isin` fs = any (`isa` f) fs++arein :: [DarcsOption] -> [DarcsFlag] -> Bool+(DarcsNoArgOption _ _ f _ : dos') `arein` fs+    = f `elem` fs || dos' `arein` fs+(DarcsArgOption _ _ f _ _ : dos') `arein` fs+    = f `isin` fs || dos' `arein` fs+(DarcsAbsPathOption _ _ f _ _ : dos') `arein` fs+    = any (`isAnAbsolute` f) fs || dos' `arein` fs+(DarcsAbsPathOrStdOption _ _ f _ _ : dos') `arein` fs+    = any (`isAnAbsoluteOrStd` f) fs || dos' `arein` fs+(DarcsOptAbsPathOption _ _ _ f _ _ : dos') `arein` fs+    = any (`isAnAbsolute` f) fs || dos' `arein` fs+(DarcsMultipleChoiceOption os: dos') `arein` fs+    = os `arein` fs || dos' `arein` fs+[] `arein` _ = False++-- | A type for darcs' options. The value contains the command line+-- switch(es) for the option, a help string, and a function to build a+-- @DarcsFlag@ from the command line arguments.  for each constructor,+-- 'shortSwitches' represents the list of short command line switches+-- which invoke the option, longSwitches the list of long command line+-- switches, optDescr the description of the option, and argDescr the description+-- of its argument, if any. mkFlag is a function which makes a @DarcsFlag@ from+-- the arguments of the option.+data DarcsOption+    = DarcsArgOption [Char] [String] (String->DarcsFlag) String String+    -- ^ @DarcsArgOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@+    -- The constructor for options with a string argument, such as+    -- @--tag@++    | DarcsAbsPathOption [Char] [String] (AbsolutePath -> DarcsFlag) String String+    -- ^ @DarcsAbsPathOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@+    -- The constructor for options with an absolute path argument, such as+    -- @--sibling@++    | DarcsAbsPathOrStdOption [Char] [String] (AbsolutePathOrStd -> DarcsFlag) String String+    -- ^ @DarcsAbsPathOrStdOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@+    -- The constructor for options with a path argument, such as @-o@++    | DarcsOptAbsPathOption [Char] [String] String (AbsolutePath -> DarcsFlag) String String+    -- ^ @DarcsOptAbsPathOrStdOption shortSwitches longSwitches defaultPath+    -- mkFlag ArgDescr OptDescr@ where defaultPath is a default value+    -- for the Path, as a string to be parsed as if it had been given+    -- on the command line.+    -- The constructor for options with an optional path argument, such as @-O@++    | DarcsNoArgOption [Char] [String] DarcsFlag String+    -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@+    -- The constructon fon options with no arguments.++    | DarcsMultipleChoiceOption [DarcsOption]+    -- ^ A constructor for grouping related options together, such as+    -- @--hashed@, @--darcs-2@ and @--old-fashioned-inventory@.++option_from_darcsoption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]+option_from_darcsoption _ (DarcsNoArgOption a b c h) = [Option a b (NoArg c) h]+option_from_darcsoption _ (DarcsArgOption a b c n h) = [Option a b (ReqArg c n) h]+option_from_darcsoption wd (DarcsMultipleChoiceOption os) = concatMap (option_from_darcsoption wd) os+option_from_darcsoption wd (DarcsAbsPathOrStdOption a b c n h) = [Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h]+option_from_darcsoption wd (DarcsAbsPathOption a b c n h) = [Option a b (ReqArg (c . makeAbsolute wd) n) h]+option_from_darcsoption wd (DarcsOptAbsPathOption a b d c n h) = [Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h]++-- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of+-- option, flattening any DarcsMultipleChoiceOption in the list.+concat_options :: [DarcsOption] -> DarcsOption+concat_options os = DarcsMultipleChoiceOption $ concatMap from_option os+ where+  from_option (DarcsMultipleChoiceOption xs) = xs+  from_option x = [x]++extract_fix_path :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath)+extract_fix_path [] = Nothing+extract_fix_path ((FixFilePath repo orig):_)  = Just (repo, orig)+extract_fix_path (_:fs) = extract_fix_path fs++fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath+fixFilePath opts f = case extract_fix_path opts of+                       Nothing -> bug "Can't fix path in fixFilePath"+                       Just (_,o) -> withCurrentDirectory o $ ioAbsolute f++fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd+fixFilePathOrStd opts f =+    case extract_fix_path opts of+      Nothing -> bug "Can't fix path in fixFilePathOrStd"+      Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f++fixUrl :: [DarcsFlag] -> String -> IO String+fixUrl opts f = if is_file f+                then toFilePath `fmap` fixFilePath opts f+                else return f++fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath]+fixSubPaths flags fs =+    withCurrentDirectory o $+    do fixedfs <- mapM fixit $ filter (not.null) fs+       let (good, bad) = partitionEither fixedfs+       unless (null bad) $+              putStrLn $ "Ignoring non-repository paths: " ++ unwords bad+       return $ nub good+ where+    (r,o) = case extract_fix_path flags of+            Just xxx -> xxx+            Nothing -> bug "Can't fix path in fixSubPaths"+    fixit p = do ap <- ioAbsolute p+                 case makeSubPathOf r ap of+                   Just sp -> return $ Right sp+                   Nothing -> return $ maybe (Left p) Right $ simpleSubPath p++partitionEither :: [Either a b] -> ([b],[a])+partitionEither es = ( [b | Right b <- es]+                     , [a | Left  a <- es] )++-- as opposed to just '.'+areFileArgs :: [SubPath] -> Bool+areFileArgs rps = concatMap toFilePath rps /= ""++-- | 'list_option' is an option which lists the command's arguments+list_options :: DarcsOption+list_options = DarcsNoArgOption [] ["list-options"] ListOptions+               "simply list the command's arguments"++flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String+flagToString x f = maybeHead $ catMaybes $ map f2o x+    where f2o (DarcsArgOption _ (s:_) c _ _) = do arg <- get_content f+                                                  if c arg == f+                                                      then return $ unwords [('-':'-':s), arg]+                                                      else Nothing+          f2o (DarcsNoArgOption _ (s:_) f' _) | f == f' = Just ('-':'-':s)+          f2o (DarcsMultipleChoiceOption xs) = maybeHead $ catMaybes $ map f2o xs+          f2o _ = Nothing+          maybeHead (a:_) = Just a+          maybeHead [] = Nothing++reponame :: DarcsOption+tagname :: DarcsOption+deps_sel :: DarcsOption+checkpoint :: DarcsOption+partial :: DarcsOption+partial_check :: DarcsOption+tokens :: DarcsOption+working_repo_dir :: DarcsOption+possibly_remote_repo_dir :: DarcsOption+disable :: DarcsOption+restrict_paths :: DarcsOption++pipe_interactive, all_pipe_interactive, all_interactive, all_patches, interactive, pipe,+  human_readable, diffflags, allow_problematic_filenames, noskip_boring,+  ask_long_comment, match_one_nontag, changes_reverse, creatorhash,+  changes_format, match_one_context, happy_forwarding, send_to_context,+  diff_cmd_flag, store_in_memory, use_external_merge,+  pull_conflict_options, target, cc, apply_conflict_options, reply, xmloutput,+  distname_option, patchname_option, edit_description,+  output, output_auto_name, unidiff, repo_combinator,+  unified, summary, uncompress_nocompress, subject, in_reply_to,+  nocompress, match_several_or_range, match_several_or_last,+  author, askdeps, lookforadds, ignoretimes, test, notest, help, force_replace,+  allow_unrelated_repos,+  match_one, match_range, match_several, fancy_move_add, sendmail_cmd,+  logfile, rmlogfile, leave_test_dir, from_opt, set_default++      :: DarcsOption++recursive :: String -> DarcsOption++sign, applyas, verify :: DarcsOption+\end{code}++\section{Common options to darcs commands}++\begin{options}+--help+\end{options}+Every \verb|COMMAND| accepts \verb!--help! as an argument, which tells it to+provide a bit of help.  Among other things, this help always provides an+accurate listing of the options available with that command, and is+guaranteed never to be out of sync with the version of darcs you actually+have installed (unlike this manual, which could be for an entirely+different version of darcs).+\begin{verbatim}+% darcs COMMAND --help+\end{verbatim}+\begin{code}+help = DarcsNoArgOption ['h'] ["help"] Help+       "shows brief description of command and its arguments"+\end{code}++\begin{options}+--disable+\end{options}+Every {\tt COMMAND} accepts the \verb!--disable! option, which can be used in+\verb!_darcs/prefs/defaults! to disable some commands in the repository. This+can be helpful if you want to protect the repository from accidental use of+advanced commands like obliterate, unpull, unrecord or amend-record.+\begin{code}+disable = DarcsNoArgOption [] ["disable"] Disable+        "disable this command"+\end{code}++\begin{options}+--verbose, --quiet, --normal-verbosity+\end{options}+Most commands also accept the \verb!--verbose! option, which tells darcs to+provide additional output.  The amount of verbosity varies from command to+command.  Commands that accept \verb!--verbose\verb! also accept \verb!--quiet\verb!,+which surpresses non-error output, and \verb!--normal-verbosity\verb! which can be+used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in+the defaults file.++\begin{options}+--debug, --debug-http+\end{options}+Many commands also accept the \verb!--debug! option, which causes darcs to generate+additional output that may be useful for debugging its behavior, but which otherwise+would not be interesting. Option \verb!--debug-http! makes darcs output debugging+info for libcurl.+\begin{code}+any_verbosity :: [DarcsOption]+any_verbosity =[DarcsMultipleChoiceOption+                [DarcsNoArgOption [] ["debug"] Debug+                 "give only debug output",+                 DarcsNoArgOption [] ["debug-verbose"] DebugVerbose+                 "give debug and verbose output",+                 DarcsNoArgOption [] ["debug-http"] DebugHTTP+                 "give debug output for libcurl",+                 DarcsNoArgOption ['v'] ["verbose"] Verbose+                 "give verbose output",+                 DarcsNoArgOption ['q'] ["quiet"] Quiet+                 "suppress informational output",+                 DarcsNoArgOption [] ["standard-verbosity"] NormalVerbosity+                 "neither verbose nor quiet output"],+                 DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information"]+\end{code}++\begin{options}+--repodir+\end{options}+Another common option is the \verb!--repodir! option, which allows you to+specify the directory of the repository in which to perform the command.+This option is used with commands, such as whatsnew, that ordinarily would+be performed within a repository directory, and allows you to use those+commands without actually being in the repository directory when calling the+command.  This is useful when running darcs in a pipe, as might be the case+when running \verb'apply' from a mailer.++\begin{code}+working_repo_dir = DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"+             "specify the repository directory in which to run"+possibly_remote_repo_dir = DarcsArgOption [] ["repo"] WorkRepoUrl "URL"+             "specify the repository URL"++-- | 'get_repourl' takes a list of flags and returns the url of the+-- repository specified by @Repodir \"directory\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--repodir=DIRECTORY@+get_repourl :: [DarcsFlag] -> Maybe String+get_repourl [] = Nothing+get_repourl (WorkRepoUrl d:_) | not (is_file d) = Just d+get_repourl (_:fs) = get_repourl fs+\end{code}++\begin{options}+--remote-repo+\end{options}++Some commands, such as \verb'pull' require a remote repository to be specified,+either from the command line or as a default.  The \verb!--remote-repo!+provides an alternative way to supply this remote repository path.  This flag+can be seen as temporarily ``replacing'' the default repository. Setting it+causes the command to ignore the default repository (it also does not affect,+i.e. overwrite the default repository).  On the other hand, if any other+repositories are supplied as command line arguments, this flag will be ignored+(and the default repository may be overwritten).++\begin{code}+-- | 'remote_repo' is the option used to specify the URL of the remote+-- repository to work with+remote_repo :: DarcsOption+remote_repo = DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"+             "specify the remote repository URL to work with"+\end{code}++\input{Darcs/Match.lhs}+\input{Darcs/Patch/Match.lhs}++\begin{code}+patchname_option = DarcsArgOption ['m'] ["patch-name"] PatchName "PATCHNAME"+                   "name of patch"++send_to_context = DarcsAbsPathOption [] ["context"] Context "FILENAME"+                  "send to context stored in FILENAME"++match_one_context =+    DarcsMultipleChoiceOption+    [DarcsArgOption [] ["to-match"] mp "PATTERN"+     "select changes up to a patch matching PATTERN",+     DarcsArgOption [] ["to-patch"] OnePatch "REGEXP"+     "select changes up to a patch matching REGEXP",+     __tag,+     DarcsAbsPathOption [] ["context"] Context "FILENAME"+     "version specified by the context in FILENAME"+    ]+    where mp s = OnePattern (patch_match s)++match_one = concat_options [__match, __patch, __tag, __index]+match_one_nontag = concat_options [__match, __patch, __index]+match_several    = concat_options [__matches, __patches, __tags]+match_range            = concat_options [match_to, match_from, __match, __patch, __last, __indexes]+match_several_or_range = concat_options [match_to, match_from, __last, __indexes,+                                         __matches, __patches, __tags]+match_several_or_last  = concat_options [match_from, __last, __matches, __patches, __tags]++match_to, match_from :: DarcsOption+match_to = DarcsMultipleChoiceOption+            [DarcsArgOption [] ["to-match"] uptop "PATTERN"+             "select changes up to a patch matching PATTERN",+             DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP"+             "select changes up to a patch matching REGEXP",+             DarcsArgOption [] ["to-tag"] UpToTag "REGEXP"+             "select changes up to a tag matching REGEXP"]+    where uptop s = UpToPattern (patch_match s)+match_from = DarcsMultipleChoiceOption+              [DarcsArgOption [] ["from-match"] fromp "PATTERN"+               "select changes starting with a patch matching PATTERN",+               DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP"+               "select changes starting with a patch matching REGEXP",+               DarcsArgOption [] ["from-tag"] AfterTag "REGEXP"+               "select changes starting with a tag matching REGEXP"]+    where fromp s = AfterPattern (patch_match s)++__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsOption++__tag = DarcsArgOption ['t'] ["tag"] OneTag "REGEXP"+       "select tag matching REGEXP"+__tags = DarcsArgOption ['t'] ["tags"] OneTag "REGEXP"+        "select tags matching REGEXP"++__patch = DarcsArgOption ['p'] ["patch"] OnePatch "REGEXP"+         "select a single patch matching REGEXP"+__patches = DarcsArgOption ['p'] ["patches"] SeveralPatch "REGEXP"+           "select patches matching REGEXP"++__match = DarcsArgOption [] ["match"] mp "PATTERN"+         "select a single patch matching PATTERN"+  where mp s = OnePattern (patch_match s)+__matches = DarcsArgOption [] ["matches"] mp "PATTERN"+           "select patches matching PATTERN"+  where mp s = SeveralPattern (patch_match s)++__last = DarcsArgOption [] ["last"] lastn "NUMBER"+         "select the last NUMBER patches"+    where lastn = LastN . number_string++__index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch"+    where indexrange s = if all isDigit s+                         then PatchIndexRange (read s) (read s)+                         else PatchIndexRange 0 0++__indexes = DarcsArgOption ['n'] ["index"] indexrange "N-M" "select a range of patches"+    where indexrange s = if all isokay s+                         then if '-' `elem` s+                              then let x1 = takeWhile (/= '-') s+                                       x2 = reverse $ takeWhile (/= '-') $ reverse s+                                   in PatchIndexRange (read x1) (read x2)+                              else PatchIndexRange (read s) (read s)+                         else PatchIndexRange 0 0+          isokay c = isDigit c || c == '-'++match_maxcount :: DarcsOption+match_maxcount = DarcsArgOption [] ["max-count"] mc "NUMBER"+         "return only NUMBER results"+    where mc = MaxCount . number_string+++-- | 'get_context' takes a list of flags and returns the context+-- specified by @Context c@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--context=FILE@+get_context :: [DarcsFlag] -> Maybe AbsolutePath+get_context xs = listToMaybe [ c | Context c <- xs ]++notest = DarcsMultipleChoiceOption+         [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script",+          DarcsNoArgOption [] ["test"] Test "run the test script"]+test = DarcsMultipleChoiceOption+          [DarcsNoArgOption [] ["test"] Test "run the test script",+           DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"]+leave_test_dir = DarcsMultipleChoiceOption+                 [DarcsNoArgOption [] ["leave-test-directory"]+                  LeaveTestDir "don't remove the test directory",+                  DarcsNoArgOption [] ["remove-test-directory"]+                  NoLeaveTestDir "remove the test directory"]++testByDefault :: [DarcsFlag] -> [DarcsFlag]+testByDefault o = if NoTest `elem` o then o else Test:o+\end{code}++\begin{options}+--ignore-times+\end{options}+Darcs optimizes its operations by keeping track of the modification times+of your files.  This dramatically speeds up commands such as+\verb!whatsnew! and \verb!record! which would otherwise require reading+every file in the repository and comparing it with a reference version.  However,+there are times when this can cause problems, such as when running a series+of darcs commands from a script, in which case often a file will be+modified twice in the same second, which can lead to the second+modification going unnoticed.  The solution to such predicaments is the+\verb!--ignore-times! option, which instructs darcs not to trust the file+modification times, but instead to check each file's contents explicitly.+\begin{code}+ignoretimes = DarcsNoArgOption [] ["ignore-times"] IgnoreTimes+              "don't trust the file modification times"+lookforadds =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds+     "look for (non-boring) files that could be added",+     DarcsNoArgOption [] ["dont-look-for-adds"] NoLookForAdds+     "don't look for any files that could be added [DEFAULT]"]++fancy_move_add =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["date-trick"] FancyMoveAdd+     "add files with date appended to avoid conflict [EXPERIMENTAL] ",+     DarcsNoArgOption [] ["no-date-trick"] NoFancyMoveAdd+     "don't use experimental date appending trick [DEFAULT]"]++askdeps =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["ask-deps"] AskDeps+     "ask for extra dependencies",+     DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps+     "don't ask for extra dependencies"]++ask_long_comment =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment+     "edit the long comment by default",+     DarcsNoArgOption [] ["skip-long-comment"] NoEditLongComment+     "don't give a long comment",+     DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment+     "prompt for whether to edit the long comment"]+\end{code}++\begin{options}+--author+\end{options}+\label{env:DARCS_EMAIL}+Several commands need to be able to identify you.  Conventionally, you+provide an email address for this purpose, which can include comments,+e.g.\ \verb!David Roundy <droundy@abridgegame.org>!.  The easiest way to do+this is+to define an environment variable \verb!EMAIL! or \verb!DARCS_EMAIL! (with+the latter overriding the former).  You can also override this using the+\verb!--author! flag to any command.  Alternatively, you could set your+email address on a per-repository basis using the ``defaults'' mechanism+for ``ALL'' commands, as described in Appendix~\ref{repository_format}.+Or, you could specify the author on a per-repository basis using the+\verb!_darcs/prefs/author! file as described in section~\ref{author_prefs}.++Also, a global author file can be created in your home directory with the name+\verb!.darcs/author!, on MS Windows~\ref{ms_win}.  This file overrides the+contents of the environment variables, but a repository-specific author+file overrides the global author file.++\begin{code}+logfile = DarcsAbsPathOption [] ["logfile"] LogFile "FILE"+          "give patch name and comment in file"++rmlogfile = DarcsNoArgOption [] ["delete-logfile"] RmLogFile+            "delete the logfile when done"++author = DarcsArgOption ['A'] ["author"] Author "EMAIL" "specify author id"+from_opt = DarcsArgOption [] ["from"] Author "EMAIL" "specify email address"++-- | 'get_author' takes a list of flags and returns the author of the+-- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any.+-- Otherwise, if @Pipe@ is present, asks the user who is the author and+-- returns the answer. If neither are present, try to guess the author,+-- from @_darcs/prefs@, and if it's not possible, ask the user.+get_author :: [DarcsFlag] -> IO String+get_author (Author a:_) = return a+get_author (Pipe:_) = do askUser "Who is the author? "+get_author (_:flags) = get_author flags+get_author [] = do+  easy_author <- get_easy_author+  case easy_author of+    Just a -> return a+    Nothing -> do+      aminrepo <- doesDirectoryExist (darcsdir++"/prefs")+      if aminrepo then do+          putDocLn $+            text "Each patch is attributed to its author, usually by email address (for" $$+            text "example, `Fred Bloggs <fred@example.net>').  Darcs could not determine" $$+            text "your email address, so you will be prompted for it." $$+            text "" $$+            text ("Your address will be stored in " ++ darcsdir ++ "/prefs/author.") $$+            text "It will be used for all patches recorded in this repository." $$+            text "If you move that file to ~/.darcs/author, it will be used for patches" $$+            text "you record in ALL repositories."+          add <- askUser "What is your email address? "+          writeFile (darcsdir++"/prefs/author") add+          return add+        else askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? "++-- | 'get_easy_author' tries to get the author name first from the repository preferences,+-- then from global preferences, then from environment variables. Returns 'Nothing' if it+-- could not get it.+get_easy_author :: IO (Maybe String)+get_easy_author = firstJustIO [ firstNotBlank `fmap` get_preflist "author",+                                firstNotBlank `fmap` get_global "author",+                                maybeGetEnv "DARCS_EMAIL",+                                maybeGetEnv "EMAIL" ]+\end{code}++\begin{options}+--dont-compress, --compress+\end{options}+By default, darcs commands that write patches to disk will compress the+patch files.  If you don't want this, you can choose the+\verb!--dont-compress! option, which causes darcs not to compress the patch+file.++\begin{code}+nocompress = concat_options [__compress, __dont_compress]+uncompress_nocompress = concat_options [__compress, __dont_compress, __uncompress]++__compress, __dont_compress, __uncompress :: DarcsOption+__compress = DarcsNoArgOption [] ["compress"] Compress+            "create compressed patches"+__dont_compress = DarcsNoArgOption [] ["dont-compress"] NoCompress+                  "don't create compressed patches"+__uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress+               "uncompress patches"++summary = DarcsMultipleChoiceOption+          [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes",+           DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"]+unified = DarcsNoArgOption ['u'] ["unified"] Unified+          "output patch in a darcs-specific format similar to diff -u"+unidiff = DarcsNoArgOption ['u'] ["unified"] Unified+          "pass -u option to diff"+diff_cmd_flag = DarcsArgOption [] ["diff-command"]+       DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"+store_in_memory = DarcsNoArgOption [] ["store-in-memory"] StoreInMemory+          "do patch application in memory rather than on disk"++target = DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"+cc = DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"++-- |'get_cc' takes a list of flags and returns the addresses to send a copy of+-- the patch bundle to when using @darcs send@.+-- looks for a cc address specified by @Cc \"address\"@ in that list of flags.+-- Returns the addresses as a comma separated string.+get_cc :: [DarcsFlag] -> String+get_cc fs = lt $ catMaybes $ map whatcc fs+            where whatcc (Cc t) = Just t+                  whatcc _ = Nothing+                  lt [t] = t+                  lt [t,""] = t+                  lt (t:ts) = t++" , "++lt ts+                  lt [] = ""++subject = DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject"++-- |'get_subject' takes a list of flags and returns the subject of the mail+-- to be sent by @darcs send@. Looks for a subject specified by+-- @Subject \"subject\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--subject=SUBJECT@+get_subject :: [DarcsFlag] -> Maybe String+get_subject (Subject s:_) = Just s+get_subject (_:fs) = get_subject fs+get_subject [] = Nothing++in_reply_to = DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"+get_in_reply_to :: [DarcsFlag] -> Maybe String+get_in_reply_to (InReplyTo s:_) = Just s+get_in_reply_to (_:fs) = get_in_reply_to fs+get_in_reply_to [] = Nothing++output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"+         "specify output filename"++output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"+                   "output to automatically named file in DIRECTORY, default: current directory"++edit_description =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["edit-description"] EditDescription+                          "edit the patch bundle description",+     DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription+                      "don't edit the patch bundle description"]++distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"+                  "name of version"++recursive h+    = DarcsMultipleChoiceOption+      [DarcsNoArgOption ['r'] ["recursive"] Recursive h,+       DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)]++inventory_choices :: DarcsOption+inventory_choices =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["hashed"] UseHashedInventory+                          "Some new features. Compatible with older repos",+     DarcsNoArgOption [] ["darcs-2"] UseFormat2+                          "All features. Related repos must use same format [DEFAULT]",+     DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory+                          "Minimal features. What older repos use."]++get_inventory_choices :: DarcsOption+get_inventory_choices =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["hashed"] UseHashedInventory+                          "Convert darcs-1 format to hashed format",+     DarcsNoArgOption [] ["old-fashioned-inventory"] UseOldFashionedInventory+                          "Convert from hashed to darcs-1 format"]++xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput+        "generate XML formatted output"++creatorhash = DarcsArgOption [] ["creator-hash"] CreatorHash "HASH"+              "specify hash of creator patch (see docs)"++sign = DarcsMultipleChoiceOption+       [DarcsNoArgOption [] ["sign"] Sign+        "sign the patch with your gpg key",+        DarcsArgOption [] ["sign-as"] SignAs "KEYID"+        "sign the patch with a given keyid",+        DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE"+        "sign the patch using openssl with a given private key",+        DarcsNoArgOption [] ["dont-sign"] NoSign+        "don't sign the patch"]+applyas = DarcsMultipleChoiceOption+           [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME"+            "apply patch as another user using sudo",+            DarcsNoArgOption [] ["apply-as-myself"] NonApply+            "don't use sudo to apply as another user [DEFAULT]"]+happy_forwarding = DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding+                   "forward unsigned messages without extra header"+set_default = DarcsMultipleChoiceOption+              [DarcsNoArgOption [] ["set-default"] SetDefault+               "set default repository [DEFAULT]",+               DarcsNoArgOption [] ["no-set-default"] NoSetDefault+               "don't set default repository"]++verify = DarcsMultipleChoiceOption+         [DarcsAbsPathOption [] ["verify"] Verify "PUBRING"+          "verify that the patch was signed by a key in PUBRING",+          DarcsAbsPathOption [] ["verify-ssl"] VerifySSL "KEYS"+          "verify using openSSL with authorized keys from file KEYS",+          DarcsNoArgOption [] ["no-verify"] NonVerify+          "don't verify patch signature"]++reponame = DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"+           "path of output directory" --repodir is there for compatibility+                                      --should be removed eventually+tagname = DarcsArgOption ['t'] ["tag"] TagName "TAGNAME"+          "name of version to checkpoint"+deps_sel = DarcsMultipleChoiceOption+       [DarcsNoArgOption [] ["no-deps"] DontGrabDeps+        "don't automatically fulfill dependencies",+        DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies+        "don't ask about patches that are depended on by matched patches (with --match or --patch)",+        DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies+        "prompt about patches that are depended on by matched patches [DEFAULT]"]+checkpoint = DarcsNoArgOption [] ["checkpoint"] CheckPoint+             "create a checkpoint file (see get --partial)"+tokens = DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""+         "define token to contain these characters"++partial       = concat_options [__partial, __lazy, __ephemeral, __complete]+partial_check = concat_options [__complete, __partial]++__partial, __lazy, __ephemeral, __complete :: DarcsOption+__partial = DarcsNoArgOption [] ["partial"] Partial+            "get partial repository using checkpoint (old-fashioned format only)"+__lazy = DarcsNoArgOption [] ["lazy"] Lazy+              "get patch files only as needed"+__ephemeral = DarcsNoArgOption [] ["ephemeral"] Ephemeral+              "don't save patch files in the repository"+__complete = DarcsNoArgOption [] ["complete"] Complete+             "get a complete copy of the repository"++force_replace = DarcsMultipleChoiceOption+                [DarcsNoArgOption ['f'] ["force"] ForceReplace+                 "proceed with replace even if 'new' token already exists",+                 DarcsNoArgOption [] ["no-force"]+                 NonForce "don't force the replace if it looks scary"]++reply = DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address"+apply_conflict_options+    = DarcsMultipleChoiceOption+      [DarcsNoArgOption [] ["mark-conflicts"]+       MarkConflicts "mark conflicts",+       DarcsNoArgOption [] ["allow-conflicts"]+       AllowConflicts "allow conflicts, but don't mark them",+       DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts+       "equivalent to --dont-allow-conflicts, for backwards compatibility",+       DarcsNoArgOption [] ["dont-allow-conflicts"]+       NoAllowConflicts "fail on patches that create conflicts [DEFAULT]"]+pull_conflict_options+    = DarcsMultipleChoiceOption+      [DarcsNoArgOption [] ["mark-conflicts"]+       MarkConflicts "mark conflicts [DEFAULT]",+       DarcsNoArgOption [] ["allow-conflicts"]+       AllowConflicts "allow conflicts, but don't mark them",+       DarcsNoArgOption [] ["dont-allow-conflicts"]+       NoAllowConflicts "fail on patches that create conflicts"]+use_external_merge = DarcsArgOption [] ["external-merge"]+                     ExternalMerge "COMMAND" "use external tool to merge conflicts"+\end{code}++\begin{options}+--dry-run+\end{options}+The \verb!--dry-run! option will cause darcs not to actually take the specified+action, but only print what would have happened.  Not all commands accept+\verb!--dry-run!, but those that do should accept the \verb!--summary!  option.++\begin{options}+--summary, --no-summary+\end{options}+The \verb!--summary! option shows a summary of the patches that would have been+pulled/pushed/whatever. The format is similar to the output format of+\verb!cvs update! and looks like this:++\begin{verbatim}+A  ./added_but_not_recorded.c+A! ./added_but_not_recorded_conflicts.c+a  ./would_be_added_if_look_for_adds_option_was_used.h++M  ./modified.t -1 +1+M! ./modified_conflicts.t -1 +1++R  ./removed_but_not_recorded.c+R! ./removed_but_not_recorded_conflicts.c++\end{verbatim}++You can probably guess what the flags mean from the clever file names.+\begin{description}+\item{\texttt{A}} is for files that have been added but not recorded yet.+\item{\texttt{a}} is for files found using the \verb!--look-for-adds! option available for+\verb!whatsnew! and \verb!record!. They have not been added yet, but would be+added automatically if \verb!--look-for-adds! were used with the next+\verb!record! command.++\item{\texttt{M}} is for files that have been modified in the working directory but not+recorded yet. The number of added and subtracted lines is also shown.++\item{\texttt{R}}  is for files that have been removed, but the removal is not+recorded yet.+\end{description}+An exclamation mark appears next to any option that has a conflict.++\begin{code}+-- NOTE: I'd rather work to have no uses of dry_run_noxml, so that any time+-- --dry-run is a possibility, automated users can examine the results more+-- easily with --xml.+dry_run_noxml :: DarcsOption+dry_run_noxml = DarcsNoArgOption [] ["dry-run"] DryRun+                "don't actually take the action"++dry_run :: [DarcsOption]+dry_run = [dry_run_noxml, xmloutput]++-- | @'showFriendly' flags patch@ returns a 'Doc' representing the right+-- way to show @patch@ given the list @flags@ of flags darcs was invoked with.+showFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> Doc+showFriendly opts p | Verbose `elem` opts = showNicely p+                    | Summary `elem` opts = Darcs.Patch.summary p+                    | otherwise           = description p++-- | @'print_dry_run_message_and_exit' action opts patches@ prints a string+-- representing the action that would be taken if the @--dry-run@ option+-- had not been passed to darcs. Then darcs exits successfully.+-- @action@ is the name of the action being taken, like @\"push\"@+-- @opts@ is the list of flags which were sent to darcs+-- @patches@ is the sequence of patches which would be touched by @action@.+print_dry_run_message_and_exit :: RepoPatch p => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()+print_dry_run_message_and_exit action opts patches =+     do when (DryRun `elem` opts) $ do+          putInfo $ text $ "Would " ++ action ++ " the following changes:"+          putDocLn $ put_mode+          putInfo $ text $ ""+          putInfo $ text $ "Making no changes:  this is a dry run."+          exitWith ExitSuccess+        when (All `elem` opts && Summary `elem` opts) $ do+          putInfo $ text $ "Will " ++ action ++ " the following changes:"+          putDocLn $ put_mode+     where put_mode = if XMLOutput `elem` opts+                      then (text "<patches>" $$+                            vcat (mapFL (indent . xml_info) patches) $$+                            text "</patches>")+                      else (vsep $ mapFL (showFriendly opts) patches)+           putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn+           xml_info pl+              | Summary `elem` opts = xml_with_summary pl+              | otherwise = (to_xml . info) pl+            +           xml_with_summary hp+               | Just p <- hopefullyM hp = insert_before_lastline+                                            (to_xml $ info hp) (indent $ xml_summary p)+           xml_with_summary hp = to_xml (info hp)+           indent = prefix "    "+++\end{code}++\input{Darcs/Resolution.lhs}++\begin{code}+noskip_boring = DarcsNoArgOption [] ["boring"]+                Boring "don't skip boring files"+allow_problematic_filenames = DarcsMultipleChoiceOption+                [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly+                 "don't refuse to add files differing only in case"+                ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved+                 "don't refuse to add files with Windows-reserved names"+                ]+diffflags = DarcsArgOption [] ["diff-opts"]+            DiffFlags "OPTIONS" "options to pass to diff"++changes_format = DarcsMultipleChoiceOption+                 [DarcsNoArgOption [] ["context"]+                  (Context rootDirectory) "give output suitable for get --context",+                  xmloutput,+                  human_readable,+                  DarcsNoArgOption [] ["number"] NumberPatches "number the changes",+                  DarcsNoArgOption [] ["count"] Count "output count of changes"+                 ]+changes_reverse = DarcsNoArgOption [] ["reverse"] Reverse+                  "show changes in reverse order"++only_to_files :: DarcsOption+only_to_files = DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles+                "show only changes to specified files"++human_readable = DarcsNoArgOption [] ["human-readable"]+                 HumanReadable "give human-readable output"+pipe = DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata"++interactive =+    DarcsNoArgOption ['i'] ["interactive"] Interactive+                         "prompt user interactively"+all_patches = DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches"++all_interactive = DarcsMultipleChoiceOption [all_patches, interactive]++all_pipe_interactive+    = DarcsMultipleChoiceOption [all_patches,pipe,interactive]++pipe_interactive =+    DarcsMultipleChoiceOption [pipe, interactive]++repo_combinator =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["intersection"] Intersection+     "take intersection of all repositories",+     DarcsNoArgOption [] ["union"] Union+     "take union of all repositories [DEFAULT]",+     DarcsNoArgOption [] ["complement"] Complement+     "take complement of repositories (in order listed)"]++-- | 'list_files' returns the list of all non-boring files in the repository+list_files :: IO [String]+list_files = do s <- slurp_all_but_darcs "."+                skip_boring <- boring_file_filter+                return (map drop_dotslash $ skip_boring $ list_slurpy s)++drop_dotslash :: String -> String+drop_dotslash ('.':'/':x) = drop_dotslash x+drop_dotslash x = x++-- | 'list_unregistered_files' returns the list of all non-boring unregistered+-- files in the repository.+list_unregistered_files :: IO [String]+list_unregistered_files = withRepository [] $- \repository ->+    do s <- slurp_all_but_darcs "."+       skip_boring <- boring_file_filter+       regs <- slurp_pending repository+       return $ map drop_dotslash $ (skip_boring $ list_slurpy s) \\ (list_slurpy regs)++-- | 'list_registered_files' returns the list of all registered files in the repository.+list_registered_files :: IO [String]+list_registered_files =+    (map drop_dotslash . list_slurpy) `fmap` (withRepository [] slurp_pending)++options_latex :: [DarcsOption] -> String+options_latex opts = "\\begin{tabular}{lll}\n"+++                     unlines (map option_latex opts)+++                     "\\end{tabular}\n"++latex_help :: String -> String+latex_help h+    = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n"++option_latex :: DarcsOption -> String+option_latex (DarcsNoArgOption a b _ h) =+    show_short_options a ++ show_long_options b ++ latex_help h ++ "\\\\"+option_latex (DarcsArgOption a b _ arg h) =+    show_short_options a +++    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"+option_latex (DarcsAbsPathOrStdOption a b _ arg h) =+    show_short_options a +++    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"+option_latex (DarcsAbsPathOption a b _ arg h) =+    show_short_options a +++    show_long_options (map (++(" "++arg)) b) ++ latex_help h ++ "\\\\"+option_latex (DarcsOptAbsPathOption a b _ _ arg h) =+    show_short_options a +++    show_long_options (map (++("[="++arg++"]")) b) ++ latex_help h ++ "\\\\"+option_latex (DarcsMultipleChoiceOption os) =+    unlines (map option_latex os)++show_short_options :: [Char] -> String+show_short_options [] = "&"+show_short_options [c] = "\\verb!-"++[c]++"! &"+show_short_options (c:cs) = "\\verb!-"++[c]++"!,"++show_short_options cs++show_long_options :: [String] -> String+show_long_options [] = " &"+show_long_options [s] = "\\verb!--" ++ s ++ "! &"+show_long_options (s:ss)+    = "\\verb!--" ++ s ++ "!,"++ show_long_options ss++set_scripts_executable :: DarcsOption+set_scripts_executable = DarcsMultipleChoiceOption+                              [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable+                               "make scripts executable",+                               DarcsNoArgOption [] ["dont-set-scripts-executable"] DontSetScriptsExecutable+                               "don't make scripts executable"]++relink, relink_pristine, sibling :: DarcsOption+relink = DarcsNoArgOption [] ["relink"] Relink+         "relink random internal data to a sibling"++relink_pristine = DarcsNoArgOption [] ["relink-pristine"] RelinkPristine+                  "relink pristine tree (not recommended)"++sibling = DarcsAbsPathOption [] ["sibling"] Sibling "URL"+          "specify a sibling directory"++-- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags.+flagsToSiblings :: [DarcsFlag] -> [AbsolutePath]+flagsToSiblings ((Sibling s) : l) = s : (flagsToSiblings l)+flagsToSiblings (_ : l) = flagsToSiblings l+flagsToSiblings [] = []++nolinks :: DarcsOption+nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks+          "do not link repository or pristine to sibling"++reorder_patches :: DarcsOption+reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder+                  "reorder the patches in the repository"+\end{code}+\begin{options}+--sendmail-command+\end{options}+\darcsEnv{SENDMAIL}++\begin{code}+sendmail_cmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"++environmentHelpSendmail :: ([String], [String])+environmentHelpSendmail = (["SENDMAIL"], [+ "On Unix, the `darcs send' command relies on sendmail(8).  The",+ "`--sendmail-command' or $SENDMAIL environment variable can be used to",+ "provide an explicit path to this program; otherwise the standard",+ "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."])+-- FIXME: mention the following also:+-- * sendmail(8) is not sendmail-specific;+-- * nowadays, desktops often have no MTA or an unconfigured MTA --+--   which is awful, because it accepts mail but doesn't relay it;+-- * in this case, can be a sendmail(8)-emulating wrapper on top of an+--   MUA that sends mail directly to a smarthost; and+-- * on a multi-user system without an MTA and on which you haven't+--   got root, can be msmtp.++-- |'get_sendmail_cmd' takes a list of flags and returns the sendmail command+-- to be used by @darcs send@. Looks for a command specified by+-- @SendmailCmd \"command\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@+-- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present.+get_sendmail_cmd :: [DarcsFlag] -> IO String +get_sendmail_cmd (SendmailCmd a:_) = return a+get_sendmail_cmd (_:flags) = get_sendmail_cmd flags+get_sendmail_cmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]+                         case easy_sendmail of+                            Just a -> return a+                            Nothing -> return ""++files :: DarcsOption+files = DarcsMultipleChoiceOption+        [DarcsNoArgOption [] ["files"] Files+         "include files in output [DEFAULT]",+         DarcsNoArgOption [] ["no-files"] NoFiles+         "don't include files in output"]++directories :: DarcsOption+directories = DarcsMultipleChoiceOption+              [DarcsNoArgOption [] ["directories"] Directories+               "include directories in output [DEFAULT]",+               DarcsNoArgOption [] ["no-directories"] NoDirectories+               "don't include directories in output"]++pending :: DarcsOption+pending = DarcsMultipleChoiceOption+              [DarcsNoArgOption [] ["pending"] Pending+               "reflect pending patches in output [DEFAULT]",+               DarcsNoArgOption [] ["no-pending"] NoPending+               "only included recorded patches in output"]++nullFlag :: DarcsOption        -- "null" is already taken+nullFlag = DarcsNoArgOption ['0'] ["null"] NullFlag+       "separate file names by NUL characters"+\end{code}+\begin{options}+--posthook=COMMAND, --no-posthook+\end{options}+To provide a command that should be run whenever a darcs command completes+successfully, use \verb!--posthook! to specify the command.  This is useful+for people who want to have a command run whenever a patch is applied.  Using+\verb!--no-posthook! will disable running the command.+\begin{options}+--run-posthook, --prompt-posthook+\end{options}+These options control prompting before running the posthook.  Use+\verb!--prompt-posthook! to have darcs prompt before running the+posthook command.  You may use --run-posthook to reenable the default+behavior of running user-specified posthooks.++Some darcs commands export to the posthook command information about the+changes being made.  In particular, three environment variables are defined.+\verb!DARCS_PATCHES! contains a human-readable summary of the patches being+acted upon. The format is the same as "darcs changes".  \verb!DARCS_PATCHES_XML!+Contains the same details, in the same XML format as "darcs changes". Finally,+\verb!DARCS_FILES! contains a list of the files affected, one file per line.+If your repository has filenames including newlines, you'll just have to+cope.  Note, however, that \emph{none} of these environment variables are+defined when running under windows.  Note also that we refuse to pass+environment variables greater in size than 10k, in order to avoid triggering+\verb!E2BIG! errors.++\begin{code}+definePatches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> IO ()+#ifndef WIN32+definePatches ps = do let k = "Defining environment variables"+                      beginTedious k+                      tediousSize k 3+                      finishedOneIO k "DARCS_PATCHES"+                      setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps)+                      finishedOneIO k "DARCS_PATCHES_XML"+                      setEnvCautiously "DARCS_PATCHES_XML"+                                 (renderString $ text "<patches>" $$+                                                 vcat (mapFL (to_xml . info) ps) $$+                                                 text "</patches>")+                      finishedOneIO k "DARCS_FILES"+                      setEnvCautiously "DARCS_FILES" (unlines$ list_touched_files ps)+                      endTedious k++setEnvCautiously :: String -> String -> IO ()+setEnvCautiously e v | toobig (10*1024) v = return ()+                     | otherwise = setEnv e v True+    where toobig :: Int -> [a] -> Bool+          toobig 0 _ = True+          toobig _ [] = False+          toobig n (_:xs) = toobig (n-1) xs+#else+definePatches _ = return ()+#endif++defineChanges :: Patchy p => p C(x y) -> IO ()+#ifndef WIN32+defineChanges ps = setEnvCautiously "DARCS_FILES" (unlines $ list_touched_files ps)+#else+defineChanges _ = return ()+#endif++posthook_cmd :: DarcsOption+posthook_cmd = DarcsMultipleChoiceOption+               [DarcsArgOption [] ["posthook"] PosthookCmd+                "COMMAND" "specify command to run after this darcs command",+                DarcsNoArgOption [] ["no-posthook"] NoPosthook+                "don't run posthook command"]++posthook_prompt :: DarcsOption+posthook_prompt = DarcsMultipleChoiceOption+                  [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook+                   "prompt before running posthook [DEFAULT]",+                   DarcsNoArgOption [] ["run-posthook"] RunPosthook+                   "run posthook command without prompting"]++-- | 'get_posthook_cmd' takes a list of flags and returns the posthook command+--  specified by @PosthookCmd a@ in that list of flags, if any.+get_posthook_cmd :: [DarcsFlag] -> Maybe String+get_posthook_cmd (PosthookCmd a:_) = Just a+get_posthook_cmd (_:flags) = get_posthook_cmd flags+get_posthook_cmd [] = Nothing+\end{code}+\begin{options}+--prehook=COMMAND, --no-prehook+\end{options}+To provide a command that should be run before a darcs command is executed,+ use \verb!--prehook! to specify the command.  An example use is+for people who want to have a command run whenever a patch is to be recorded, such as+translating line endings before recording patches.  Using+\verb!--no-prehook! will disable running the command.+\begin{options}+--run-prehook, --prompt-prehook+\end{options}+These options control prompting before running the prehook.  See the+posthook documentation above for details.+\begin{code}+prehook_cmd :: DarcsOption+prehook_cmd = DarcsMultipleChoiceOption+               [DarcsArgOption [] ["prehook"] PrehookCmd+                "COMMAND" "specify command to run before this darcs command",+                DarcsNoArgOption [] ["no-prehook"] NoPrehook+                "don't run prehook command"]++prehook_prompt :: DarcsOption+prehook_prompt = DarcsMultipleChoiceOption+                  [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook+                   "prompt before running prehook [DEFAULT]",+                   DarcsNoArgOption [] ["run-prehook"] RunPrehook+                   "run prehook command without prompting"]++-- | 'get_prehook_cmd' takes a list of flags and returns the prehook command+--  specified by @PrehookCmd a@ in that list of flags, if any.+get_prehook_cmd :: [DarcsFlag] -> Maybe String+get_prehook_cmd (PrehookCmd a:_) = Just a+get_prehook_cmd (_:flags) = get_prehook_cmd flags+get_prehook_cmd [] = Nothing+\end{code}++\begin{options}+--ssh-cm, --no-ssh-cm+\end{options}++For commands which invoke ssh, darcs will normally multiplex ssh+sessions over a single connection as long as your version of ssh has+the ControlMaster feature from OpenSSH versions 3.9 and above.  This+option will avoid darcs trying to use this feature even if your ssh+supports it.++\begin{options}+--http-pipelining, --no-http-pipelining+\end{options}++When compiled with libcurl (version 7.18.0 and above), darcs can+use HTTP pipelining. It is enabled by default for libcurl+(version 7.19.1 and above). This option will make darcs enable or+disable HTTP pipelining, overwriting default. Note that if HTTP+pipelining is really used depends on the server.++\begin{options}+--no-cache+\end{options}++Do not use patch caches.+\begin{code}+network_options :: [DarcsOption]+network_options =+    [DarcsMultipleChoiceOption+     [DarcsNoArgOption [] ["ssh-cm"] SSHControlMaster+                           "use SSH ControlMaster feature",+      DarcsNoArgOption [] ["no-ssh-cm"] NoSSHControlMaster+                           "don't use SSH ControlMaster feature [DEFAULT]"],+     DarcsMultipleChoiceOption+     [DarcsNoArgOption [] ["http-pipelining"] HTTPPipelining+                           pipelining_description,+      DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining+                           no_pipelining_description],+      no_cache+     ]+    where pipelining_description =+              "enable HTTP pipelining"+++              (if pipeliningEnabledByDefault then " [DEFAULT]" else "")+          no_pipelining_description =+              "disable HTTP pipelining"+++              (if pipeliningEnabledByDefault then "" else " [DEFAULT]")++no_cache :: DarcsOption+no_cache = DarcsNoArgOption [] ["no-cache"] NoCache+                          "don't use patch caches"+\end{code}+\begin{options}+--umask+\end{options}+By default, Darcs will use your current umask.  The option+\verb|--umask| will cause Darcs to switch to a different umask before+writing to the repository.++\begin{code}+umask_option :: DarcsOption+umask_option =+    DarcsArgOption [] ["umask"] UMask "UMASK"+        "specify umask to use when writing"+\end{code}++\begin{options}+--dont-restrict-paths, --restrict-paths+\end{options}+By default darcs is only allowed to manage and modify files and directories+contained inside the current repository and not being part of any darcs+repository's meta data (including the current one). This is mainly for+security, to protect you from spoofed patches modifying arbitrary files+with sensitive data---say, in your home directory---or tampering with any+repository's meta data to switch off this safety guard.++But sometimes you may want to manage a group of ``sub'' repositories'+preference files with a global repository, or use darcs in some other+advanced way. The best way is probably to put+\verb!ALL dont-restrict-paths! in \verb!_darcs/prefs/defaults!. This turns+off all sanity checking for file paths in patches.++Path checking can be temporarily turned on with \verb!--restrict-paths! on+the command line, when pulling or applying unknown patches.++\begin{code}+restrict_paths =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths+     "don't allow darcs to touch external files or repo metadata",+     DarcsNoArgOption [] ["dont-restrict-paths"] DontRestrictPaths+     "allow darcs to modify any file or directory (unsafe)"]+\end{code}++\begin{options}+--allow-unrelated-repos+\end{options}+By default darcs checks and warns user if repositories are unrelated when+doing pull, push and send. This option makes darcs skip this check.++\begin{code}+allow_unrelated_repos =+    DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos+                         "do not check if repositories are unrelated"+\end{code}++\begin{code}+check, repair, check_or_repair :: DarcsOption+\end{code}++\begin{options}+--check+\end{options}+This option specifies checking mode.++\begin{code}+check =+    DarcsNoArgOption [] ["check"] Check+                        "Specify checking mode"+\end{code}++\begin{options}+--repair+\end{options}+This option specifies repair mode.++\begin{code}+repair =+    DarcsNoArgOption [] ["repair"] Repair+                        "Specify repair mode"++check_or_repair = concat_options [check, repair]++-- | @'patch_select_flag' f@ holds whenever @f@ is a way of selecting+-- patches such as @PatchName n@.+patch_select_flag :: DarcsFlag -> Bool+patch_select_flag All = True+patch_select_flag (PatchName _) = True+patch_select_flag (OnePatch _) = True+patch_select_flag (SeveralPatch _) = True+patch_select_flag (AfterPatch _) = True+patch_select_flag (UpToPatch _) = True+patch_select_flag (TagName _) = True+patch_select_flag (LastN _) = True+patch_select_flag (OneTag _) = True+patch_select_flag (AfterTag _) = True+patch_select_flag (UpToTag _) = True+patch_select_flag (OnePattern _) = True+patch_select_flag (SeveralPattern _) = True+patch_select_flag (AfterPattern _) = True+patch_select_flag (UpToPattern _) = True+patch_select_flag _ = False++-- | The integer corresponding to a string, if it's only composed of digits.+--   Otherwise, -1.+number_string :: String -> Int+number_string s = if and (map isDigit s) then read s else (-1)+\end{code}
+ src/Darcs/Bug.hs view
@@ -0,0 +1,27 @@+-- Reporting bugs in darcs.  See also impossible.h.+module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust+                 ) where++import Printer ( Doc, errorDoc, text, ($$) )++type BugStuff = (String, Int, String, String)++_bug :: BugStuff -> String -> a+_bug bs s = _bugDoc bs (text s)++_bugDoc :: BugStuff -> Doc -> a+_bugDoc bs s = errorDoc $+   text ("bug at " ++ _bugLoc bs) $$ s $$+   text ("See http://wiki.darcs.net/index.html/BugTrackerHowto " +++         "for help on bug reporting.")++_bugLoc :: BugStuff -> String+_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date++_impossible :: BugStuff -> a+_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs++_fromJust :: BugStuff -> Maybe a -> a+_fromJust bs mx =+  case mx of Nothing -> _bug bs $ "fromJust error at "++_bugLoc bs+             Just x  -> x
+ src/Darcs/CheckFileSystem.hs view
@@ -0,0 +1,59 @@+-- Copyright (C) 2004 David Roundy+--+-- 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.++module Darcs.CheckFileSystem ( can_I_use_mmap ) where++import System.Directory ( removeFile, removeDirectory, setCurrentDirectory,+                          createDirectory,+                        )+import Control.Exception ( block )++import Darcs.Utils ( withCurrentDirectory )+import Darcs.Lock ( withOpenTemp )++-- Beware that the below test will return true in any directory where we+-- don't have write permission.  This is risky, but means we'll do the+-- right thing in the common case where we're dealing with posix+-- filesystems and directories in which we don't have permission to write.++can_I_remove_open_files :: IO Bool+can_I_remove_open_files = block $ +   (withOpenTemp $ \ (_,f) ->+       (do { removeFile f; return True}) `catch` \_ -> return False)+   `catch` \_ -> return True++can_I_remove_directories_holding_open_files :: IO Bool+can_I_remove_directories_holding_open_files = block $+   (do createDirectory "darcs_testing_for_nfs"+       okay <- (withCurrentDirectory "darcs_testing_for_nfs" $+                do withOpenTemp $ \ (_,f) -> +                       (do removeFile f+                           setCurrentDirectory ".."+                           removeDirectory "darcs_testing_for_nfs"+                           return True+                       ) `catch` \_ -> return False+               ) `catch` \_ -> return True+       removeDirectory "darcs_testing_for_nfs" `catch` \_ -> return ()+       return okay+   ) `catch` \_ -> return True++can_I_use_mmap :: IO Bool+can_I_use_mmap = do a <- can_I_remove_open_files+                    if a then can_I_remove_directories_holding_open_files+                         else return False++
+ src/Darcs/ColorPrinter.hs view
@@ -0,0 +1,281 @@+{-# OPTIONS -fno-warn-orphans #-}+module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where++import Debug.Trace ( trace )+import System.IO ( stderr )+import Darcs.External (getTermNColors)+import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),+                invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,+                unsafeText, unsafeChar, space, unsafePackedString,+                renderStringWith, prefix )+import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr, intToDigit )+import Data.Bits ( bit, xor )+import System.Environment ( getEnv )+import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)+import qualified Data.ByteString       as B (null, init)+import System.IO.Unsafe ( unsafePerformIO )+import System.IO ( hIsTerminalDevice, Handle )++dollar, cr :: Doc+dollar = unsafeBothText "$"+cr     = unsafeBothText "\r"++errorDoc :: Doc -> a+errorDoc = error . show++traceDoc :: Doc -> a -> a+traceDoc d = trace (show d)++assertDoc :: Maybe Doc -> a -> a+assertDoc Nothing x = x+assertDoc (Just e) _ = errorDoc e++instance Show Doc where+    show = renderStringWith (fancyPrinters stderr)++-- policy+-- | the 'Policy' type is a record containing the variables which control+-- how 'Doc's will be rendered on some output.+data Policy = Policy { poColor :: Bool    -- ^ overall use of color+                     , poEscape :: Bool   -- ^ overall use of escaping+                     , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)+                     , poAltColor :: Bool -- ^ alternative to color (bold, inverse)+                     , poIsprint :: Bool  -- ^ don't escape isprints+                     , po8bit  :: Bool    -- ^ don't escape 8-bit chars+                     , poNoEscX :: String   -- ^ extra chars to never escape+                     , poEscX :: String   -- ^ extra chars to always escape+                     , poTrailing :: Bool -- ^ escape trailing spaces+                     , poCR :: Bool       -- ^ ignore \r at end of lines+                     , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)+                     }++{-# NOINLINE getPolicy #-}+-- | 'getPolicy' returns a suitable policy for a given handle.+-- The policy is chosen according to environment variables, and to the+-- type of terminal which the handle represents+getPolicy :: Handle -> Policy+getPolicy handle = unsafePerformIO $+ do isTerminal <- hIsTerminalDevice handle+    nColors <- if isTerminal then getTermNColors else return 0++    envDontEscapeAnything  <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"+    envDontEscapeIsprint   <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"+    envUseIsprint          <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility+    envDontEscape8bit      <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"++    envDontEscapeExtra  <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"+    envEscapeExtra      <- getEnvString "DARCS_ESCAPE_EXTRA"++    envDontEscapeTrailingSpace  <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"+    envDontEscapeTrailingCR     <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"++    envDontColor         <- getEnvBool "DARCS_DONT_COLOR"+    envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"+    envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"+    envDoColorLines    <- getEnvBool "DARCS_DO_COLOR_LINES"++    let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))+        doColor   = not envDontColor && haveColor++    return Policy { poColor    = doColor,+                    poEscape   = not envDontEscapeAnything,+                    poLineColor= doColor && envDoColorLines,+                    poIsprint  = envDontEscapeIsprint || envUseIsprint,+                    po8bit     = envDontEscape8bit,+                    poNoEscX   = envDontEscapeExtra,+                    poEscX     = envEscapeExtra,+                    poTrailing = not envDontEscapeTrailingSpace,+                    poCR       = envDontEscapeTrailingCR,+                    poAltColor = haveColor && envAlternativeColor,++                    poSpace = False+                  }+ where+  getEnvBool s = safeGetEnv s >>= return.(/= "0")+  safeGetEnv s = getEnv s `catch` \_ -> return "0"+  getEnvString s = getEnv s `catch` \_ -> return ""+++-- printers++-- | @'fancyPrinters' h@ returns a set of printers suitable for outputting+-- to @h@+fancyPrinters :: Printers+fancyPrinters h = let policy = getPolicy h in +                      Printers { colorP = colorPrinter policy,+                             invisibleP = invisiblePrinter,+                             hiddenP = colorPrinter policy Green,+                             userchunkP = userchunkPrinter policy,+                             defP       = escapePrinter policy,+                             lineColorT = lineColorTrans policy,+                             lineColorS = lineColorSuffix policy+                           }++-- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.+-- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise+-- does nothing.+lineColorTrans :: Policy -> Color -> Doc -> Doc+lineColorTrans po | poLineColor po = \c d -> prefix (set_color c) d <?> unsafeBothText reset_color+                  | otherwise      = const id++lineColorSuffix :: Policy -> [Printable] -> [Printable]+lineColorSuffix po | poLineColor po = \d -> S reset_color : d+                   | otherwise      = id++colorPrinter :: Policy -> Color -> Printer+colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}+                | otherwise  = const $ escapePrinter po++userchunkPrinter :: Policy -> Printer+userchunkPrinter po p+ | not (poEscape po)   = simplePrinter p+ | not (poTrailing po) = escapePrinter po p+ | otherwise           = unDoc $ pr p+ where+  pr (S s)       = prString s+  pr (Both _ ps) = prPS ps+  pr (PS ps)     = prPS ps++  prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps+            in if B.null trailPS+                then Doc $ escapePrinter po p+                else Doc (escapePrinter po (PS leadPS))+                  <> Doc (escapePrinter po{poSpace=True} (PS trailPS))+                  <> mark_escape po dollar++  prString s = let (trail',lead') = span isSpace (reverse s)+                   lead = reverse lead'+                   trail = reverse trail'+               in if (not.null) trail+                   then Doc (escapePrinter po (S lead))+                     <> Doc (escapePrinter po{poSpace=True} (S trail))+                     <> mark_escape po dollar+                   else Doc (escapePrinter po p)++escapePrinter :: Policy -> Printer+escapePrinter po+ | (not.poEscape) po = simplePrinter+ | otherwise         = unDoc . crepr+ where+  crepr p | poCR po && isEndCR p = epr (initPR p) <> cr+          | otherwise            = epr p++  epr (S s)      = escape po s+  epr (PS ps)    = if BC.any (not.no_escape po) ps+                   then escape po (BC.unpack ps)+                   else unsafePackedString ps+  epr (Both s _) = escape po s++  isEndCR (S s)        = not (null s) && last s == '\r'+  isEndCR (PS ps)      = not (B.null ps) && BC.last ps == '\r'+  isEndCR (Both _ ps)  = not (B.null ps) && BC.last ps == '\r'++  initPR (S s)       = S $ init s+  initPR (PS ps)     = PS $ B.init ps+  initPR (Both s ps) = Both (init s) (B.init ps)+++-- escape assumes the input is in ['\0'..'\255']++-- | @'escape' policy string@ escapes @string@ according to the rules+-- defined in 'policy', turning it into a 'Doc'.+escape :: Policy -> String -> Doc+escape _ "" = unsafeText ""+escape po s = hcat (map escapeChar s)+ where+  escapeChar c | no_escape po c = unsafeChar c+  escapeChar ' ' = space+  escapeChar c = (emph.unsafeText.quoteChar) c+  emph = mark_escape po++-- | @'no_escape' policy c@ tells wether @c@ will be left as-is+-- when escaping according to @policy@+no_escape :: Policy -> Char -> Bool+no_escape po c | poSpace po && isSpace c = False+no_escape po c | c `elem` poEscX po = False+no_escape po c | c `elem` poNoEscX po = True+no_escape _ '\t' = True  -- tabs will likely be converted to spaces+no_escape _ '\n' = True+no_escape po c = if (poIsprint po) then isPrint c+                                   else isPrintableAscii c+                 ||  c >= '\x80' && po8bit po++-- | 'isPrintableAscii' tells wether a character is a printable character+-- of the ascii range.+isPrintableAscii :: Char -> Bool+isPrintableAscii c = isAscii c && isPrint c+++-- | 'quoteChar' represents a special character as a string.+--   * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@+--   * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the+--     hexadecimal number of the character.+quoteChar :: Char -> String+quoteChar c+ | isControl c && isPrintableAscii cHat = ['^', cHat]+ | otherwise = sHex+ where+  cHat = chr $ (bit 6 `xor`) $ ord c+  sHex = let (q, r) = quotRem (ord c) 16+         in ['\\', intToDigit q, intToDigit r]+++-- make colors and highlightings++-- | @'mark_escape' policy doc@ marks @doc@ with the appropriate+-- marking for escaped characters according to @policy@+mark_escape :: Policy -> Doc -> Doc+mark_escape po | poAltColor po  = make_invert+               | poColor po     = make_color Red+               | otherwise      = make_asciiart++-- | @'color' policy color doc@ colors @doc@ with color @color@ if+-- @policy@ is not set to use an alternative to color. In that case,+-- it makes the text bold instead.+color :: Policy -> Color -> Doc -> Doc+color po | poAltColor po = \_ -> make_bold+         | otherwise     = make_color++make_color, make_color' :: Color -> Doc -> Doc++make_color' = with_color . set_color++-- memoized version of make_color'+make_color Blue    = make_color' Blue+make_color Red     = make_color' Red+make_color Green   = make_color' Green+make_color Cyan    = make_color' Cyan+make_color Magenta = make_color' Magenta++set_color :: Color -> String+set_color Blue    = "\x1B[01;34m" -- bold blue+set_color Red     = "\x1B[01;31m" -- bold red+set_color Green   = "\x1B[01;32m" -- bold green+set_color Cyan    = "\x1B[36m"    -- light cyan+set_color Magenta = "\x1B[35m"    -- light magenta++-- | @'make_asciiart' doc@ tries to make @doc@ (usually a+-- single escaped char) stand out with the help of only plain+-- ascii, i.e., no color or font style.+make_asciiart :: Doc -> Doc+make_asciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"++-- | the string to reset the terminal's color.+reset_color :: String+reset_color = "\x1B[00m"++-- | @'with_color' color doc@ returns a colorized version of @doc@.+-- @color@ is a string that represents a color, given by 'set_color'+with_color :: String -> Doc -> Doc+with_color c =+   let c' = unsafeBothText c+       r' = unsafeBothText reset_color+   in \x -> c' <> x <> r'+++-- | 'make_bold' boldens a doc.+make_bold :: Doc -> Doc+-- | 'make_invert' returns an invert video version of a doc.+make_invert :: Doc -> Doc+make_bold   = with_color "\x1B[01m"+make_invert = with_color "\x1B[07m"
+ src/Darcs/Commands.lhs view
@@ -0,0 +1,294 @@+%  Copyright (C) 2002,2003,2005 David Roundy+%+%  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.++\begin{code}+module Darcs.Commands ( CommandControl( Command_data, Hidden_command, Group_name ),+                       DarcsCommand( DarcsCommand, command_name,+                                     command_help, command_description,+                                     command_basic_options, command_advanced_options,+                                     command_command,+                                     command_prereq,+                                     command_extra_arg_help,+                                     command_extra_args,+                                     command_argdefaults,+                                     command_get_arg_possibilities,+                                     SuperCommand,+                                     command_sub_commands ),+                       command_alias, command_stub,+                       command_options, command_alloptions,+                       disambiguate_commands, CommandArgs(..),+                       get_command_help, get_command_mini_help,+                       get_subcommands,+                       usage, subusage, chomp_newline,+                       extract_commands,+                       super_name,+                       nodefaults,+                       loggers,+                     ) where++import System.Console.GetOpt( OptDescr, usageInfo )++import Data.List ( sort, isPrefixOf )+import Darcs.Arguments ( DarcsFlag, DarcsOption, disable, help,+                         any_verbosity, posthook_cmd, posthook_prompt,+                         prehook_cmd, prehook_prompt, option_from_darcsoption )+import Darcs.RepoPath ( AbsolutePath, rootDirectory )+import Darcs.Utils ( putStrLnError )+import Printer ( Doc, putDocLn )+\end{code}++The general format of a darcs command is+\begin{verbatim}+% darcs COMMAND OPTIONS ARGUMENTS ...+\end{verbatim}+Here \verb|COMMAND| is a command such as \verb|add| or \verb|record|, which of+course may have one or more arguments.  Options have the form+\verb!--option! or \verb!-o!, while arguments vary from command to+command.  There are many options which are common to a number of different+commands, which will be summarized here.++If you wish, you may use any unambiguous beginning of a command name as a+shortcut: for \verb!darcs record!, you could type \verb!darcs recor! or+\verb!darcs rec!, but not \verb!darcs re! since that could be confused with+\verb!darcs replace!, \verb!darcs revert! and \verb!darcs remove!.++In some cases, \verb|COMMAND| actually consists of two words, a+super-command and a subcommand.  For example, the ``display the+manifest'' command has the form \verb|darcs query manifest|.++\paragraph{Command overview}++Not all commands modify the ``patches'' of your repository (that+is, the named patches which other users can pull); some commands only+affect the copy of the source tree you're working on (your ``working+directory''), and some affect both. This table summarizes what you should+expect from each one and will hopefully serve as guide when you're having+doubts about which command to use.++\begin{center}+\footnotetext[1]{But it affects the repository and working directory targeted+  by the push}+\footnotetext[2]{As for the other end, see apply}+\begin{tabular}{|c|c|c|}+\hline+affects & patches & working directory\\+\hline+record & yes & no\\+\hline+unrecord & yes & no\\+\hline+rollback & yes & yes\\+\hline+revert & no & yes\\+\hline+unrevert & no & yes\\+\hline+pull & yes & yes\\+\hline+obliterate & yes & yes\\+\hline+apply & yes & yes\\+\hline+push\footnote{But it affects the repository and working directory targeted by+the push} & no & no\\+\hline+send\footnote{As for the other end, see apply} & no & no\\+\hline+put\footnote{Creates a new repository} & no & no\\+\hline+\end{tabular}+\end{center}++\begin{code}+extract_commands, extract_hidden_commands :: [CommandControl] -> [DarcsCommand]+extract_commands cs = concatMap (\x -> case x of { Command_data cmd_d -> [cmd_d]; _ -> []}) cs+extract_hidden_commands cs = concatMap (\x -> case x of { Hidden_command cmd_d -> [cmd_d]; _ -> []}) cs+\end{code}++\input{Darcs/Arguments.lhs}++\begin{code}+data CommandControl = Command_data DarcsCommand+                    | Hidden_command DarcsCommand+                    | Group_name String++data DarcsCommand =+    DarcsCommand {command_name, command_help, command_description :: String,+                  command_extra_args :: Int,+                  command_extra_arg_help :: [String],+                  command_command :: [DarcsFlag] -> [String] -> IO (),+                  command_prereq :: [DarcsFlag] -> IO (Either String ()),+                  command_get_arg_possibilities :: IO [String],+                  command_argdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],+                  command_basic_options :: [DarcsOption],+                  command_advanced_options :: [DarcsOption]}+  | SuperCommand {command_name, command_help, command_description :: String,+                  command_prereq :: [DarcsFlag] -> IO (Either String ()),+                  command_sub_commands :: [CommandControl]}++command_alloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])+command_alloptions DarcsCommand { command_basic_options = opts1+                                , command_advanced_options = opts2 }+    = (opts1 ++ [disable, help],+       any_verbosity ++ opts2 +++                [posthook_cmd, posthook_prompt+                ,prehook_cmd, prehook_prompt])++--  Supercommands cannot be disabled.+command_alloptions SuperCommand { } = ([help],[])++--  Obtain options suitable as input to+--  System.Console.Getopt, including the --disable option (which is+--  not listed explicitly in the DarcsCommand definitions).+command_options :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])+command_options cwd c = (convert basic, convert advanced)+ where (basic, advanced) = command_alloptions c+       convert = concatMap (option_from_darcsoption cwd)++nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+nodefaults _ _ xs = return xs++get_subcommands :: DarcsCommand -> [CommandControl]+get_subcommands c@(SuperCommand {}) = command_sub_commands c+get_subcommands _ = []++command_alias :: String -> DarcsCommand -> DarcsCommand+command_alias n c =+  c { command_name = n+    , command_description = "Alias for `darcs " ++ command_name c ++ "'."+    , command_help = "The `darcs " ++ n ++ "' command is an alias for " +++                     "`darcs " ++ command_name c ++ "'.\n" +++                     command_help c+    }++command_stub :: String -> String -> String -> DarcsCommand -> DarcsCommand+command_stub n h d c =+  c { command_name = n+    , command_help = h+    , command_description = d+    , command_command = \_ _ -> putStr h+    }++usage :: [CommandControl] -> String+usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" +++           usage_helper cs ++ "\n" +++           "Use 'darcs COMMAND --help' for help on a single command.\n" +++           "Use 'darcs --version' to see the darcs version number.\n" +++           "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" +++           "Use 'darcs help patterns' for help on patch matching.\n" +++           "Use 'darcs help environment' for help on environment variables.\n" +++           "\n" +++           "Check bug reports at http://bugs.darcs.net/\n"++subusage :: DarcsCommand -> String+subusage super =+    (usageInfo+     ("Usage: darcs "++command_name super++" SUBCOMMAND ... " +++      "\n\n"++ command_description super+++      "\n\nSubcommands:\n" ++ usage_helper (get_subcommands super) ++ "\nOptions:")+     (option_from_darcsoption rootDirectory help))+    ++ "\n" ++ command_help super++usage_helper :: [CommandControl] -> String+usage_helper [] = ""+usage_helper (Hidden_command _:cs) = usage_helper cs+usage_helper ((Command_data c):cs) = "  "++pad_spaces (command_name c) 15 +++                      chomp_newline (command_description c)++"\n"++usage_helper cs+usage_helper ((Group_name n):cs) = "\n" ++ n ++ "\n" ++ usage_helper cs++chomp_newline :: String -> String+chomp_newline "" = ""+chomp_newline s = if last s == '\n' then init s else s++pad_spaces :: String -> Int -> String+pad_spaces s n = s ++ replicate (n - length s) ' '++super_name :: Maybe DarcsCommand -> String+super_name Nothing  = ""+super_name (Just x) = command_name x ++ " "++get_command_mini_help :: Maybe DarcsCommand -> DarcsCommand -> String+get_command_mini_help msuper cmd =+  get_command_help_core msuper cmd +++  "\n\nSee darcs help "+  ++ (maybe "" (\c -> command_name c ++ " ") msuper)+  ++ command_name cmd ++ " for details."++get_command_help :: Maybe DarcsCommand -> DarcsCommand -> String+get_command_help msuper cmd =+    unlines (reverse basicR)+    ++ (if null advanced then ""+        else "\nAdvanced options:\n" ++ unlines (reverse advancedR))+    ++ "\n" ++ command_help cmd+    where -- we could just call usageInfo twice, but then the advanced+          -- options might not line up with the basic ones (no short flags)+          (advancedR, basicR) =+             splitAt (length advanced) $ reverse $ lines combinedUsage+          combinedUsage = usageInfo+            (get_command_help_core msuper cmd ++ subcommands ++ "\n\nOptions:")+            (basic ++ advanced)+          (basic, advanced) = command_options rootDirectory cmd+          subcommands =+            case msuper of+            Nothing -> case get_subcommands cmd of+                       [] -> []+                       s  -> "\n\nSubcommands:\n" ++ (usage_helper s)+            -- we don't want to list subcommands if we're already specifying them+            Just _  -> ""++get_command_help_core :: Maybe DarcsCommand -> DarcsCommand -> String+get_command_help_core msuper cmd =+    "Usage: darcs "++super_name msuper++command_name cmd+++    " [OPTION]... " ++ unwords args_help +++    "\n"++ command_description cmd+    where args_help = case cmd of+            (DarcsCommand _ _ _ _ _ _ _ _ _ _ _) ->+              command_extra_arg_help cmd+            _ -> []++data CommandArgs = CommandOnly      DarcsCommand+                 | SuperCommandOnly DarcsCommand+                 | SuperCommandSub  DarcsCommand DarcsCommand++-- Parses a darcs command line with potentially abbreviated commands+disambiguate_commands :: [CommandControl] -> String -> [String]+                      -> Either String (CommandArgs, [String])+disambiguate_commands allcs cmd args =+ do c <- extract cmd allcs+    case (get_subcommands c, args) of+      ([], _)         -> return (CommandOnly c, args)+      (_ ,[])         -> return (SuperCommandOnly c, args)+      (subcs, (a:as)) -> case extract a subcs of+                         Left _   -> return (SuperCommandOnly c, args)+                         Right sc -> return (SuperCommandSub c sc, as)++extract :: String -> [CommandControl] -> Either String DarcsCommand+extract cmd cs =+ case [ c | c <- extract_commands cs, cmd `isPrefixOf` command_name c ] +++      [ h | h <- extract_hidden_commands cs,    cmd == command_name h ] of+   []  -> Left $ "No such command '" ++ cmd ++ "'\n"+   [c] -> Right c+   cs' -> Left $ "Ambiguous command...\n\n" +++                    "The command '"++cmd++"' could mean one of:\n" +++                    unwords (sort $ map command_name cs')++-- | Output functions equivalent to (putStrLn, hPutStrLn stderr, putDocLn)+loggers :: [DarcsFlag] -> ( String -> IO ()+                          , String -> IO ()+                          , Doc -> IO ())+loggers _ = (putStrLn, putStrLnError, putDocLn)+\end{code}
+ src/Darcs/Commands/Add.lhs view
@@ -0,0 +1,278 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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{add}+\begin{code}+module Darcs.Commands.Add ( add ) where++import Data.List ( (\\), nub)++import Darcs.Commands+import Darcs.Arguments (noskip_boring, allow_problematic_filenames,+                       fancy_move_add,+                       recursive, working_repo_dir, dry_run_noxml, umask_option,+                       list_files, list_unregistered_files,+                        DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive,+                                   Verbose, Quiet, FancyMoveAdd, DryRun),+                        fixSubPaths,+                      )+import Darcs.Utils ( withCurrentDirectory, nubsort )+import IsoDate ( getIsoDateTime )+import Darcs.Repository ( amInRepository, withRepoLock, ($-),+                    slurp_pending, add_to_pending )+import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move )+import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL )+import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,+                        isFileReallySymlink, doesDirectoryReallyExist, +                        doesFileReallyExist, slurp_hasdir,+                      )+import Darcs.Patch.FileName ( fp2fn )+import Darcs.RepoPath ( toFilePath )+import Control.Monad ( when, unless )+import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )+import Data.Maybe ( maybeToList )+import System.FilePath.Posix ( takeDirectory, (</>) )+import System.IO ( hPutStrLn, stderr )+import qualified System.FilePath.Windows as WindowsFilePath+import Darcs.Gorsvet( invalidateIndex )++add_description :: String+add_description = "Add one or more new files or directories."++add_help :: String+add_help =+ "Generally a repository contains both files that should be version\n" +++ "controlled (such as source code) and files that Darcs should ignore\n" +++ "(such as executables compiled from the source code).  The `darcs add'\n" +++ "command is used to tell Darcs which files to version control.\n" +++ "\n" +++ "When an existing project is first imported into a Darcs repository, it\n" +++ "is common to run `darcs add -r *' or `darcs record -l' to add all\n" +++ "initial source files into darcs.\n"+++ "\n" +++ "Adding symbolic links (symlinks) is not supported.\n\n"++add :: DarcsCommand+add = DarcsCommand {command_name = "add",+                    command_help = add_help ++ add_help' ++ add_help'',+                    command_description = add_description,+                    command_extra_args = -1,+                    command_extra_arg_help = ["<FILE or DIRECTORY> ..."],+                    command_command = add_cmd,+                    command_prereq = amInRepository,+                    command_get_arg_possibilities = list_unregistered_files,+                    command_argdefaults = nodefaults,+                    command_advanced_options = [umask_option],+                    command_basic_options =+                    [noskip_boring, allow_problematic_filenames,+                     recursive "add contents of subdirectories",+                     fancy_move_add,+                     working_repo_dir, dry_run_noxml]}++add_help' :: String+add_help' =+ "Darcs will ignore all files and folders that look `boring'.  The\n" +++ "--boring option overrides this behaviour.\n" +++ "\n" +++ "Darcs will not add file if another file in the same folder has the\n" +++ "same name, except for case.  The --case-ok option overrides this\n" +++ "behaviour.  Windows and OS X usually use filesystems that do not allow\n" +++ "files a folder to have the same name except for case (for example,\n" +++ "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" +++ "unusable on those systems!\n\n"++add_cmd :: [DarcsFlag] -> [String] -> IO ()+add_cmd opts args = withRepoLock opts $- \repository ->+ do cur <- slurp_pending repository+    origfiles <- map toFilePath `fmap` fixSubPaths opts args+    when (null origfiles) $+       putStrLn "Nothing specified, nothing added." >>+       putStrLn "Maybe you wanted to say `darcs add --recursive .'?"+    parlist <- get_parents cur origfiles+    flist' <- if Recursive `elem` opts+              then expand_dirs origfiles+              else return origfiles+    let flist = nubsort (parlist ++ flist')+    -- refuse to add boring files recursively:+    nboring <- if Boring `elem` opts+               then return darcsdir_filter+               else boring_file_filter+    let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn+    mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $+      flist \\ nboring flist+    date <- getIsoDateTime+    invalidateIndex repository+    ps <- addp msgs opts date cur $ nboring flist+    when (nullFL ps && not (null args)) $+        fail "No files were added"+    unless gotDryRun $ add_to_pending repository ps+  where+    gotDryRun = DryRun `elem` opts+    msgs | gotDryRun = dryRunMessages+         | otherwise = normalMessages++addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim)+addp msgs opts date cur0 files = do+    (ps, dups) <-+        foldr+            (\f rest cur accPS accDups -> do+                (cur', mp, mdup) <- addp' cur f+                rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))+            (\_ ps dups -> return (reverse ps, dups))+            files+            cur0 [] []+    let uniq_dups = nub dups+        caseMsg =+            if gotAllowCaseOnly then ":"+                else ";\nnote that to ensure portability we don't allow\n" +++                     "files that differ only in case. Use --case-ok to override this:"+    unless (null dups) $ do+       dupMsg <-+         case uniq_dups of+         [f] ->+           do+           isDir <- doesDirectoryReallyExist f+           if isDir+               then return $+                 "The following directory "++msg_is msgs++" already in the repository"+               else return $+                 "The following file "++msg_is msgs++" already in the repository"+         fs   ->+           do+           areDirs <- mapM doesDirectoryReallyExist fs+           if and areDirs+               then return $+                 "The following directories "++msg_are msgs++" already in the repository"+               else+                 (if or areDirs+                      then return $+                        "The following files and directories " +++                        msg_are msgs ++ " already in the repository"+                      else return $+                        "The following files " ++ msg_are msgs ++ " already in the repository")+       putInfo $ dupMsg ++ caseMsg+       mapM_ putInfo uniq_dups+    return $ concatFL $ unsafeFL ps+ where+  addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)+  addp' cur f =+    if already_has+    then return (cur, Nothing, Just f)+    else+    if is_badfilename+       then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."+               return add_failure+       else do+      isdir <- doesDirectoryReallyExist f+      if isdir+         then trypatch $ myadddir f+         else do isfile <- doesFileReallyExist f+                 if isfile+                    then trypatch $ myaddfile f+                    else do islink <- isFileReallySymlink f+                            if islink then+                               putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."+                               else putInfo $ "File "++ f ++" does not exist!"+                            return add_failure+      where already_has = if gotAllowCaseOnly+                          then slurp_has f cur+                          else slurp_has_anycase f cur+            is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)+            add_failure = (cur, Nothing, Nothing)+            trypatch p =+                case apply_to_slurpy p cur of+                Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error+                              return (cur, Nothing, Nothing)+                Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'"+                              return (s', Just p, Nothing)+            parentdir = takeDirectory f+            have_parentdir = slurp_hasdir (fp2fn parentdir) cur+            parent_error = if have_parentdir+                           then ""+                           else "couldn't add parent directory '"++parentdir+++                                "' to repository."+            myadddir d = if gotFancyMoveAdd+                         then adddir (d++"-"++date) :>:+                              move (d++"-"++date) d :>: NilFL+                         else adddir d :>: NilFL+            myaddfile d = if gotFancyMoveAdd+                          then addfile (d++"-"++date) :>:+                               move (d++"-"++date) d :>: NilFL+                          else addfile d :>: NilFL+  putVerbose = if Verbose `elem` opts || DryRun `elem` opts+               then putStrLn+               else \_ -> return ()+  putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr+  gotFancyMoveAdd = FancyMoveAdd `elem` opts+  gotAllowCaseOnly = AllowCaseOnly `elem` opts+  gotAllowWindowsReserved = AllowWindowsReserved `elem` opts++data AddMessages =+    AddMessages+    { msg_skipping  :: String+    , msg_adding    :: String+    , msg_is        :: String+    , msg_are       :: String+    }++normalMessages, dryRunMessages :: AddMessages+normalMessages =+    AddMessages+    { msg_skipping  = "Skipping"+    , msg_adding    = "Adding"+    , msg_is        = "is"+    , msg_are       = "are"+    }+dryRunMessages =+    AddMessages+    { msg_skipping  = "Would skip"+    , msg_adding    = "Would add"+    , msg_is        = "would be"+    , msg_are       = "would be"+    }++-- |FIXME: this documentation makes *no* sense to me, and the+-- ramifications of using this option are not clear. --twb, 2008+add_help'' :: String+add_help'' =+ "The --date-trick option allows you to enable an experimental trick to\n" +++ "make add conflicts, in which two users each add a file or directory\n" +++ "with the same name, less problematic.  While this trick is completely\n" +++ "safe, it is not clear to what extent it is beneficial.\n"++expand_dirs :: [FilePath] -> IO [FilePath]+expand_dirs fs = concat `fmap` mapM expand_one fs+expand_one :: FilePath -> IO [FilePath]+expand_one "" = list_files+expand_one f = do+  isdir <- doesDirectoryReallyExist f+  if not isdir then return [f]+     else do fs <- withCurrentDirectory f list_files+             return $ f: map (f </>) fs++get_parents :: Slurpy -> [FilePath] -> IO [FilePath]+get_parents cur fs =+  concat `fmap` mapM (get_parent cur) fs+get_parent :: Slurpy -> FilePath -> IO [FilePath]+get_parent cur f =+  if slurp_hasdir (fp2fn parentdir) cur+  then return []+  else do grandparents <- get_parent cur parentdir+          return (grandparents ++ [parentdir])+    where parentdir = takeDirectory f+\end{code}+
+ src/Darcs/Commands/AmendRecord.lhs view
@@ -0,0 +1,195 @@+%  Copyright (C) 2004,2007 David Roundy+%+%  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{amend-record}+\begin{code}+module Darcs.Commands.AmendRecord ( amendrecord ) where+import Data.List ( sort )+import Data.Maybe ( isJust )+import System.Exit ( ExitCode(..), exitWith )+import Control.Monad ( when )++import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName,+                               EditLongComment, PromptLongComment) )+import Darcs.Lock ( world_readable_temp )+import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info )+import Darcs.Repository ( withRepoLock, ($-), withGutsOf,+                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,+                    tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,+                    sync_repo, amInRepository,+                  )+import Darcs.Patch ( RepoPatch, description, Prim, fromPrims,+                     infopatch, getdeps, adddeps, effect,+                     sort_coalesceFL,+                     canonize )+import Darcs.Patch.Info ( pi_author, pi_name, pi_log,+                          PatchInfo, patchinfo, is_inverted, invert_name,+                        )+import Darcs.Ordered ( FL(..), (:>)(..), (+>+),+                             nullFL, mapFL_FL, concatFL )+import Darcs.SelectChanges ( with_selected_changes_to_files',+                             with_selected_patch_from_repo )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Commands.Record ( get_date, get_log )+import Darcs.Arguments ( DarcsFlag ( All ),+                         areFileArgs, fixSubPaths, defineChanges,+                        all_interactive, ignoretimes,+                        ask_long_comment, author, patchname_option,+                        leave_test_dir, nocompress, lookforadds,+                         working_repo_dir,+                        match_one_nontag, umask_option,+                        notest, testByDefault, list_registered_files,+                        get_easy_author, set_scripts_executable+                      )+import Darcs.Utils ( askUser )+import Printer ( putDocLn )+import Darcs.Gorsvet( invalidateIndex )++amendrecord_description :: String+amendrecord_description =+ "Improve a patch before it leaves your repository."++amendrecord_help :: String+amendrecord_help =+ "Amend-record updates a `draft' patch with additions or improvements,\n" +++ "resulting in a single `finished' patch.  This is better than recording\n" +++ "the additions and improvements as separate patches, because then\n" +++ "whenever the `draft' patch is copied between repositories, you would\n" +++ "need to make sure all the extra patches are copied, too.\n" +++ "\n" +++ "Do not copy draft patches between repositories, because a finished\n" +++ "patch cannot be copied into a repository that contains a draft of the\n" +++ "same patch.  If this has already happened, `darcs obliterate' can be\n" +++ "used to remove the draft patch.\n" +++ "\n" +++ -- FIXME: is the following still true in Darcs 2.1? --twb+ "Do not run amend-record in repository that other developers can pull\n" +++ "from, because if they pull while an amend-record is in progress, their\n" +++ "repository may be corrupted.\n" +++ "\n" +++ "When recording a draft patch, it is a good idea to start the name with\n" +++ "`DRAFT:' so that other developers know it is not finished.  When\n" +++ "finished, remove it with `darcs amend-record --edit-long-comment'.\n" +++ "To change the patch name without starting an editor, use --patch-name.\n" +++ "\n" +++ "Like `darcs record', if you call amend-record with files as arguments,\n" +++ "you will only be asked about changes to those files.  So to amend a\n" +++ "patch to foo.c with improvements in bar.c, you would run:\n" +++ "\n" +++ "    darcs amend-record --match 'touch foo.c' bar.c\n" +++ "\n" +++ "It is usually a bad idea to amend another developer's patch.  To make\n" +++ "amend-record only ask about your own patches by default, you can add\n" +++ "something like `amend-record match David Roundy' to ~/.darcs/defaults, \n" +++ "where `David Roundy' is your name. " ++ + "On Windows use C:/Documents And Settings/user/Application Data/darcs/defaults\n"++amendrecord :: DarcsCommand+amendrecord = DarcsCommand {command_name = "amend-record",+                            command_help = amendrecord_help,+                            command_description = amendrecord_description,+                            command_extra_args = -1,+                            command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                            command_command = amendrecord_cmd,+                            command_prereq = amInRepository,+                            command_get_arg_possibilities = list_registered_files,+                            command_argdefaults = nodefaults,+                            command_advanced_options = [nocompress, ignoretimes, umask_option,+                                                        set_scripts_executable],+                            command_basic_options = [match_one_nontag,+                                                     notest,+                                                    leave_test_dir,+                                                    all_interactive,+                                                    author, patchname_option, ask_long_comment,+                                                    lookforadds,+                                                    working_repo_dir]}++amendrecord_cmd :: [DarcsFlag] -> [String] -> IO ()+amendrecord_cmd opts args =+    let edit_metadata = has_edit_metadata opts in+    withRepoLock (testByDefault opts) $- \repository -> do+    files  <- sort `fmap` fixSubPaths opts args+    when (areFileArgs files) $+         putStrLn $ "Amending changes in "++unwords (map show files)++":\n"+    with_selected_patch_from_repo "amend" repository opts $ \ (_ :> oldp) -> do+        ch <- if All `elem` opts +              then get_unrecorded_in_files_unsorted repository (map sp2fn files)+              else get_unrecorded_in_files repository (map sp2fn files)+        case ch of+          NilFL | not edit_metadata -> putStrLn "No changes!"+          _ -> do+              date <- get_date opts+              with_selected_changes_to_files' "add" (filter (==All) opts)+                (map toFilePath files) ch $ \ (chs:>_) ->+                  if (nullFL chs && not edit_metadata)+                  then putStrLn "You don't want to record anything!"+                  else do+                       let old_pinf = info oldp+                           prior    = (pi_name old_pinf, pi_log old_pinf)+                           make_log = world_readable_temp "darcs-amend-record"+                           old_author = pi_author old_pinf+                       author_here <- get_easy_author+                       case author_here of+                         Nothing -> return ()+                         Just ah -> let edit_author = isJust (get_author opts)+                                    in if (edit_author || ah == old_author)+                                       then return ()+                                       else do yorn <- askUser $ "You're not "++old_author+                                                                 ++"! Amend anyway? "+                                               case yorn of ('y':_) -> return ()+                                                            _ -> exitWith $ ExitSuccess+                       (new_name, new_log, _) <- get_log opts (Just prior) make_log chs+                       let new_author = case get_author opts of+                                        Just a  -> a+                                        Nothing -> pi_author old_pinf+                           maybe_invert = if is_inverted old_pinf then invert_name else id+                       new_pinf <- maybe_invert `fmap` patchinfo date new_name+                                                                 new_author new_log+                       let newp = fixp oldp chs new_pinf+                       defineChanges newp+                       invalidateIndex repository+                       withGutsOf repository $ do+                         tentativelyRemovePatches repository opts (hopefully oldp :>: NilFL)+                         tentativelyAddPatch repository opts newp+                         finalizeRepositoryChanges repository+                       sync_repo repository+                       putStrLn "Finished amending patch:"+                       putDocLn $ description newp++has_edit_metadata :: [DarcsFlag] -> Bool+has_edit_metadata (Author _:_) = True+has_edit_metadata (LogFile _:_) = True+has_edit_metadata (PatchName _:_) = True+has_edit_metadata (EditLongComment:_) = True+has_edit_metadata (PromptLongComment:_) = True+has_edit_metadata (_:fs) = has_edit_metadata fs+has_edit_metadata [] = False++get_author :: [DarcsFlag] -> Maybe String+get_author (Author a:_) = Just a+get_author (_:as) = get_author as+get_author []     = Nothing++fixp :: RepoPatch p => PatchInfoAnd p -> FL Prim -> PatchInfo -> PatchInfoAnd p+fixp oldp chs new_pinf =+    let pdeps = getdeps $ hopefully oldp+        oldchs = effect oldp+        infodepspatch pinfo deps p = adddeps (infopatch pinfo p) deps+    in n2pia $ infodepspatch new_pinf pdeps $ fromPrims $ concatFL $ mapFL_FL canonize+           $ sort_coalesceFL $ concatFL $ mapFL_FL canonize $ oldchs +>+ chs+\end{code}
+ src/Darcs/Commands/Annotate.lhs view
@@ -0,0 +1,411 @@+%  Copyright (C) 2003 David Roundy+%+%  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{annotate}+\begin{code}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}++#include "gadts.h"++module Darcs.Commands.Annotate ( annotate, created_as_xml ) where++import Control.Monad ( when )+import Data.List ( sort )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,+                         summary, unified, human_readable,+                        xmloutput, creatorhash,+                        fixSubPaths,+                        list_registered_files,+                        match_one,+                      )+import Darcs.SlurpDirectory ( slurp )+import Darcs.Repository ( Repository, PatchSet, amInRepository, withRepository, ($-), read_repo,+                          getMarkedupFile )+import Darcs.Patch ( RepoPatch, Named, LineMark(..), patch2patchinfo, xml_summary )+import qualified Darcs.Patch ( summary )+import Darcs.Ordered ( mapRL, concatRL )+import qualified Data.ByteString.Char8 as BC ( unpack, ByteString )+import Darcs.PrintPatch ( printPatch, contextualPrintPatch )+import Darcs.Patch.Info ( PatchInfo, human_friendly, to_xml, make_filename,+                   showPatchInfo )+import Darcs.PopulationData ( Population(..), PopTree(..), DirMark(..),+                        nameI, modifiedByI, modifiedHowI,+                        createdByI, creationNameI,+                      )+import Darcs.Population ( getRepoPopVersion, lookup_pop, lookup_creation_pop,+                    modified_to_xml,+                  )+import Darcs.Hopefully ( info )+import Darcs.RepoPath ( SubPath, toFilePath )+import Darcs.Match ( match_patch, have_nonrange_match, get_first_match )+import Darcs.Lock ( withTempDir )+import Darcs.Sealed ( Sealed2(..), unseal2 )+import Printer ( putDocLn, text, errorDoc, ($$), prefix, (<+>),+                 Doc, empty, vcat, (<>), renderString, packedString )+#include "impossible.h"++annotate_description :: String+annotate_description = "Display which patch last modified something."++annotate_help :: String+annotate_help =+ "Annotate displays which patches created or last modified a directory\n"+++ "file or line. It can also display the contents of a particular patch\n"+++ "in darcs format.\n"++annotate :: DarcsCommand+annotate = DarcsCommand {command_name = "annotate",+                         command_help = annotate_help,+                         command_description = annotate_description,+                         command_extra_args = -1,+                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                         command_command = annotate_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = list_registered_files,+                         command_argdefaults = nodefaults,+                         command_advanced_options = [],+                         command_basic_options = [summary,unified,+                                                 human_readable,+                                                 xmloutput,+                                                 match_one, creatorhash,+                                                 working_repo_dir]}+\end{code}++\begin{options}+--human-readable, --summary, --unified, --xml--output+\end{options}++When called with just a patch name, annotate outputs the patch in darcs format,+which is the same as \verb!--human-readable!.++\verb!--xml-output! is the alternative to \verb!--human-readable!.++\verb!--summary! can be used with either the \verb!--xml-output! or the  +\verb!--human-readable! options to alter the results. It is documented+fully in the `common options' portion of the manual. ++Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes+the output to remain in a darcs-specific format that is similar to that produced+by \verb!diff --unified!.+\begin{code}+annotate_cmd :: [DarcsFlag] -> [String] -> IO ()+annotate_cmd opts [] = withRepository opts $- \repository -> do+  when (not $ have_nonrange_match opts) $+      fail $ "Annotate requires either a patch pattern or a " +++               "file or directory argument."+  Sealed2 p <- match_patch opts `fmap` read_repo repository+  if Summary `elem` opts+     then do putDocLn $ showpi $ patch2patchinfo p+             putDocLn $ show_summary p+     else if Unified `elem` opts+          then withTempDir "context" $ \_ ->+               do get_first_match repository opts+                  c <- slurp "."+                  contextualPrintPatch c p+          else printPatch p+    where showpi | MachineReadable `elem` opts = showPatchInfo+                 | XMLOutput `elem` opts       = to_xml+                 | otherwise                   = human_friendly+          show_summary :: RepoPatch p => Named p C(x y) -> Doc+          show_summary = if XMLOutput `elem` opts+                         then xml_summary+                         else Darcs.Patch.summary+\end{code}++If a directory name is given, annotate will output details of the last+modifying patch for each file in the directory and the directory itself. The+details look like this:++\begin{verbatim}+ # Created by [bounce handling patch+ # mark**20040526202216]  as ./test/m7/bounce_handling.pl+    bounce_handling.pl+\end{verbatim}++If a patch name and a directory are given, these details are output for the time after+that patch was applied.  If a directory and a tag name are given, the+details of the patches involved in the specified tagged version will be output.+\begin{code}+annotate_cmd opts args@[_] = withRepository opts $- \repository -> do+  r <- read_repo repository+  (rel_file_or_directory:_) <- fixSubPaths opts args+  let file_or_directory = rel_file_or_directory+  pinfo <- if have_nonrange_match opts+           then return $ patch2patchinfo `unseal2` (match_patch opts r)+           else case mapRL info $ concatRL r of+                [] -> fail "Annotate does not currently work correctly on empty repositories."+                (x:_) -> return x+  pop <- getRepoPopVersion "." pinfo++  -- deal with --creator-hash option+  let maybe_creation_pi = find_creation_patchinfo opts r+      lookup_thing = case maybe_creation_pi of+                     Nothing -> lookup_pop+                     Just cp -> lookup_creation_pop cp++  if toFilePath file_or_directory == ""+    then case pop of (Pop _ pt) -> annotate_pop opts pinfo pt+    else case lookup_thing (toFilePath file_or_directory) pop of+      Nothing -> fail $ "There is no file or directory named '"+++                 toFilePath file_or_directory++"'"+      Just (Pop _ pt@(PopDir i _))+          | modifiedHowI i == RemovedDir && modifiedByI i /= pinfo ->+              errorDoc $ text ("The directory '" ++ toFilePath rel_file_or_directory +++                               "' was removed by")+                      $$ human_friendly (modifiedByI i)+          | otherwise -> annotate_pop opts pinfo pt+      Just (Pop _ pt@(PopFile i))+          | modifiedHowI i == RemovedFile && modifiedByI i /= pinfo ->+              errorDoc $ text ("The file '" ++ toFilePath rel_file_or_directory +++                               "' was removed by")+                      $$ human_friendly (modifiedByI i)+          | otherwise -> annotate_file repository opts pinfo file_or_directory pt++annotate_cmd _ _ = fail "annotate accepts at most one argument"++annotate_pop :: [DarcsFlag] -> PatchInfo -> PopTree -> IO ()+annotate_pop opts pinfo pt = putDocLn $ p2format pinfo pt+    where p2format = if XMLOutput `elem` opts+                     then p2xml+                     else p2s++indent :: Doc -> [Doc]+-- This is a bit nasty:+indent = map (text . i) . lines . renderString+    where i "" = ""+          i ('#':s) = ('#':s)+          i s = "    "++s++-- Annotate a directory listing+p2s :: PatchInfo -> PopTree -> Doc+p2s pinfo (PopFile inf) =+    created_str+ $$ f <+> file_change+    where f = packedString $ nameI inf+          file_created = text "Created by"+                     <+> showPatchInfo (fromJust $ createdByI inf)+                     <+> text "as"+                     <+> packedString (fromJust $ creationNameI inf)+          created_str = prefix "# " file_created+          file_change = if modifiedByI inf == pinfo+                        then text $ show (modifiedHowI inf)+                        else empty+p2s pinfo (PopDir inf pops) =+    created_str+ $$ dir <+> dir_change+ $$ vcat (map (vcat . indent . p2s pinfo) $ sort pops)+    where dir = packedString (nameI inf) <> text "/"+          dir_created =+              if createdByI inf /= Nothing+              then text "Created by "+               <+> showPatchInfo (fromJust $ createdByI inf)+               <+> text "as"+               <+> packedString (fromJust $ creationNameI inf) <> text "/"+              else text "Root directory"+          created_str = prefix "# " dir_created+          dir_change = if modifiedByI inf == pinfo+                       then text $ show (modifiedHowI inf)+                       else empty++escapeXML :: String -> Doc+escapeXML = text . strReplace '\'' "&apos;" . strReplace '"' "&quot;" .+  strReplace '>' "&gt;" . strReplace '<' "&lt;" . strReplace '&' "&amp;"++strReplace :: Char -> String -> String -> String+strReplace _ _ [] = []+strReplace x y (z:zs)+  | x == z    = y ++ (strReplace x y zs)+  | otherwise = z : (strReplace x y zs)++created_as_xml :: PatchInfo -> String -> Doc+created_as_xml pinfo as = text "<created_as original_name='"+                       <> escapeXML as+                       <> text "'>"+                    $$    to_xml pinfo+                    $$    text "</created_as>"+--removed_by_xml :: PatchInfo -> String+--removed_by_xml pinfo = "<removed_by>\n"++to_xml pinfo++"</removed_by>\n"++p2xml_open :: PatchInfo -> PopTree -> Doc+p2xml_open _ (PopFile inf) =+    text "<file name='" <> escapeXML f <> text "'>"+ $$ created+ $$ modified+    where f = BC.unpack $ nameI inf+          created = case createdByI inf of+                    Nothing -> empty+                    Just ci -> created_as_xml ci+                               (BC.unpack $ fromJust $ creationNameI inf)+          modified = modified_to_xml inf+p2xml_open _ (PopDir inf _) =+    text "<directory name='" <> escapeXML f <> text "'>"+ $$ created+ $$ modified+    where f = BC.unpack $ nameI inf+          created = case createdByI inf of+                    Nothing -> empty+                    Just ci -> created_as_xml ci+                               (BC.unpack $ fromJust $ creationNameI inf)+          modified = modified_to_xml inf++p2xml_close :: PatchInfo -> PopTree -> Doc+p2xml_close _(PopFile _) = text "</file>"+p2xml_close _ (PopDir _ _) = text "</directory>"++p2xml :: PatchInfo -> PopTree -> Doc+p2xml pinf p@(PopFile _) = p2xml_open pinf p $$ p2xml_close pinf p+p2xml pinf p@(PopDir _ pops) = p2xml_open pinf p+                            $$ vcat (map (p2xml pinf) $ sort pops)+                            $$ p2xml_close pinf p+\end{code}++If a file name is given, the last modifying patch details of that file will be output, along+with markup indicating patch details when each line was last (and perhaps next) modified.++If a patch name and a file name are given, these details are output for the time after+that patch was applied.++\begin{code}+annotate_file :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfo -> SubPath -> PopTree -> IO ()+annotate_file repository opts pinfo f (PopFile inf) = do+  if XMLOutput `elem` opts+     then putDocLn $ p2xml_open pinfo (PopFile inf)+     else if createdByI inf /= Nothing+          then putAnn $ text ("File "++toFilePath f++" created by ")+                     <> showPatchInfo ci <> text (" as " ++ createdname)+          else putAnn $ text $ "File "++toFilePath f+  mk <- getMarkedupFile repository ci createdname+  old_pis <- (dropWhile (/= pinfo).mapRL info.concatRL) `fmap` read_repo repository+  mapM_ (annotate_markedup opts pinfo old_pis) mk+  when (XMLOutput `elem` opts) $  putDocLn $ p2xml_close pinfo (PopFile inf)+  where ci = fromJust $ createdByI inf+        createdname = BC.unpack $ fromJust $ creationNameI inf+annotate_file _ _ _ _ _ = impossible++annotate_markedup :: [DarcsFlag] -> PatchInfo -> [PatchInfo]+                  -> (BC.ByteString, LineMark) -> IO ()+annotate_markedup opts | XMLOutput `elem` opts = xml_markedup+                       | otherwise = text_markedup++text_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()+text_markedup _ _ (l,None) = putLine ' ' l+text_markedup pinfo old_pis (l,RemovedLine wheni)+    | wheni == pinfo       = putLine '-' l+    | wheni `elem` old_pis = return ()+    | otherwise            = putLine ' ' l+text_markedup pinfo old_pis (l,AddedLine wheni)+    | wheni == pinfo       = putLine '+' l+    | wheni `elem` old_pis = do putAnn $ text "Following line added by "+                                      <> showPatchInfo wheni+                                putLine ' ' l+    | otherwise            = return ()+text_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)+    | whenadd == pinfo = do putAnn $ text "Following line removed by "+                                  <> showPatchInfo whenrem+                            putLine '+' l+    | whenrem == pinfo = do putAnn $ text "Following line added by "+                                  <> showPatchInfo whenadd+                            putLine '-' l+    | whenadd `elem` old_pis && not (whenrem `elem` old_pis) =+        do putAnn $ text "Following line removed by " <> showPatchInfo whenrem+           putAnn $ text "Following line added by " <> showPatchInfo whenadd+           putLine ' ' l+    | otherwise = return ()++putLine :: Char -> BC.ByteString -> IO ()+putLine c s = putStrLn $ c : BC.unpack s+putAnn :: Doc -> IO ()+putAnn s = putDocLn $ prefix "# " s++xml_markedup :: PatchInfo -> [PatchInfo] -> (BC.ByteString, LineMark) -> IO ()+xml_markedup _ _ (l,None) = putLine ' ' l+xml_markedup pinfo old_pis (l,RemovedLine wheni)+    | wheni == pinfo       = putDocLn $ text "<removed_line>"+                             $$ escapeXML (BC.unpack l)+                             $$ text "</removed_line>"+    | wheni `elem` old_pis = return ()+    | otherwise            = putDocLn $ text "<normal_line>"+                             $$ text "<removed_by>"+                             $$ to_xml wheni+                             $$ text "</removed_by>"+                             $$ escapeXML (BC.unpack l)+                             $$ text "</normal_line>"+xml_markedup pinfo old_pis (l,AddedLine wheni)+    | wheni == pinfo       = putDocLn $ text "<added_line>"+                             $$ escapeXML (BC.unpack l)+                             $$ text "</added_line>"+    | wheni `elem` old_pis = putDocLn $ text "<normal_line>"+                             $$ text "<added_by>"+                             $$ to_xml wheni+                             $$ text "</added_by>"+                             $$ escapeXML (BC.unpack l)+                             $$ text "</normal_line>"+    | otherwise            = return ()+xml_markedup pinfo old_pis (l,AddedRemovedLine whenadd whenrem)+    | whenadd == pinfo =+        putDocLn $ text "<added_line>"+                $$ text "<removed_by>"+                $$ to_xml whenrem+                $$ text "</removed_by>"+                $$ escapeXML (BC.unpack l)+                $$ text "</added_line>"+    | whenrem == pinfo =+        putDocLn $ text "<removed_line>"+                $$ text "<added_by>"+                $$ to_xml whenadd+                $$ text "</added_by>"+                $$ escapeXML (BC.unpack l)+                $$ text "</removed_line>"+    | whenadd `elem` old_pis && not (whenrem `elem` old_pis) =+        putDocLn $ text "<normal_line>"+                $$ text "<removed_by>"+                $$ to_xml whenrem+                $$ text "</removed_by>"+                $$ text "<added_by>"+                $$ to_xml whenadd+                $$ text "</added_by>"+                $$ escapeXML (BC.unpack l)+                $$ text "</normal_line>"+    | otherwise = return ()+\end{code}++\begin{options}+--creator-hash HASH+\end{options}++The \verb!--creator-hash! option should only be used in combination with a+file or directory to be annotated.  In this case, the name of that file or+directory is interpreted to be its name \emph{at the time it was created},+and the hash given along with \verb!--creator-hash! indicates the patch+that created the file or directory.  This allows you to (relatively) easily+examine a file even if it has been renamed multiple times.++\begin{code}+find_creation_patchinfo :: [DarcsFlag] -> PatchSet p C(x) -> Maybe PatchInfo+find_creation_patchinfo [] _ = Nothing+find_creation_patchinfo (CreatorHash h:_) r = find_hash h $ mapRL info $ concatRL r+find_creation_patchinfo (_:fs) r = find_creation_patchinfo fs r++find_hash :: String -> [PatchInfo] -> Maybe PatchInfo+find_hash _ [] = Nothing+find_hash h (pinf:pinfs)+    | take (length h) (make_filename pinf) == h = Just pinf+    | otherwise = find_hash h pinfs+\end{code}
+ src/Darcs/Commands/Apply.lhs view
@@ -0,0 +1,431 @@+%  Copyright (C) 2003-2005 David Roundy+%+%  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{apply}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Apply ( apply ) where+import System.Exit ( ExitCode(..), exitWith )+import Prelude hiding ( catch )+import System.IO ( hClose, stdin, stdout, stderr )+import Control.Exception ( catch, throw, Exception( ExitException ) )+import Control.Monad ( when )++import Darcs.Hopefully ( n2pia, conscientiously, info )+import Darcs.SignalHandler ( withSignalsBlocked )+import Darcs.Commands ( DarcsCommand(..) )+import Darcs.CommandsAux ( check_paths )+import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All,+                                    Verbose, HappyForwarding ),+                         definePatches,+                         get_cc, working_repo_dir,+                        notest, nocompress, apply_conflict_options,+                        use_external_merge,+                        ignoretimes, get_sendmail_cmd,+                        reply, verify, list_files,+                        fixFilePathOrStd, umask_option,+                        all_interactive, sendmail_cmd,+                        leave_test_dir, happy_forwarding, +                        dry_run, print_dry_run_message_and_exit,+                        set_scripts_executable, restrict_paths+                      )+import qualified Darcs.Arguments as DarcsArguments ( cc )+import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )+import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository,+                          tentativelyMergePatches,+                    sync_repo, read_repo,+                    finalizeRepositoryChanges,+                    applyToWorking,+                  )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Info ( human_friendly )+import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL,+                             mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL )+import Darcs.SlurpDirectory ( wait_a_moment )++import ByteStringUtils ( linesPS, unlinesPS )+import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop)+import qualified Data.ByteString.Char8 as BC (unpack, last, pack)++import Darcs.External ( sendEmail, sendEmailDoc, resendEmail,+                  verifyPS )+import Darcs.Email ( read_email )+import Darcs.Lock ( withStdoutTemp, readBinFile )+import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing )+import Darcs.SelectChanges ( with_selected_changes )+import Darcs.Patch.Bundle ( scan_bundle )+import Darcs.Sealed ( Sealed(Sealed) )+import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++apply_description :: String+apply_description = "Apply a patch bundle created by `darcs send'."++apply_help :: String+apply_help =+ "Apply is used to apply a bundle of patches to this repository.\n"+++ "Such a bundle may be created using send.\n"++stdindefault :: a -> [String] -> IO [String]+stdindefault _ [] = return ["-"]+stdindefault _ x = return x+apply :: DarcsCommand+apply = DarcsCommand {command_name = "apply",+                      command_help = apply_help,+                      command_description = apply_description,+                      command_extra_args = 1,+                      command_extra_arg_help = ["<PATCHFILE>"],+                      command_command = apply_cmd,+                      command_prereq = amInRepository,+                      command_get_arg_possibilities = list_files,+                      command_argdefaults = const stdindefault,+                      command_advanced_options = [reply, DarcsArguments.cc,+                                                  happy_forwarding,+                                                  sendmail_cmd,+                                                  ignoretimes, nocompress,+                                                  set_scripts_executable, umask_option,+                                                  restrict_paths],+                      command_basic_options = [verify,+                                              all_interactive]++dry_run+++                                              [apply_conflict_options,+                                              use_external_merge,+                                              notest,+                                              leave_test_dir,+                                              working_repo_dir]}++apply_cmd :: [DarcsFlag] -> [String] -> IO ()+apply_cmd _ [""] = fail "Empty filename argument given to apply!"+apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do+  patchesfile <- fixFilePathOrStd opts unfixed_patchesfile+  ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile+  am_verbose <- return $ Verbose `elem` opts+  let from_whom = get_from ps+  us <- read_repo repository+  either_them <- get_patch_bundle opts ps+  them <- case either_them of+          Right (Sealed t) -> return t+          Left er -> do forwarded <- consider_forwarding opts ps+                        if forwarded+                          then exitWith ExitSuccess+                          else fail er+  (_, us':\/:them') <- case get_common_and_uncommon_or_missing (us, them) of+                         Left pinfo ->+                            if pinfo `elem` mapRL info (concatRL us)+                                then cannotApplyPartialRepo pinfo ""+                                else cannotApplyMissing pinfo+                         Right x -> return x+  when (null $ unsafeUnRL $ head $ unsafeUnRL them') $+       do putStr $ "All these patches have already been applied.  " +++                     "Nothing to do.\n"+          exitWith ExitSuccess+  let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch "+                                                          ++"bundle, since we're missing:") $$))+                 $ reverseRL $ head $ unsafeUnRL them'+  with_selected_changes "apply" fixed_opts their_ps $+                            \ (to_be_applied:>_) -> do+   print_dry_run_message_and_exit "apply" opts to_be_applied+   when (nullFL to_be_applied) $+        do putStrLn "You don't want to apply any patches, so I'm exiting!"+           exitWith ExitSuccess+   check_paths opts to_be_applied+   redirect_output opts from_whom $ do+    when am_verbose $ putStrLn "We have the following extra patches:"+    when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us'+    when am_verbose $ putStrLn "Will apply the following patches:"+    when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied+    definePatches to_be_applied+    Sealed pw <- tentativelyMergePatches repository "apply" opts+                 (reverseRL $ head $ unsafeUnRL us') to_be_applied+    invalidateIndex repository+    withSignalsBlocked $ do finalizeRepositoryChanges repository+                            wait_a_moment -- so work will be more recent than rec+                            applyToWorking repository opts pw `catch` \e ->+                                fail ("Error applying patch to working dir:\n" ++ show e)+    sync_repo repository+    putStrLn "Finished applying..."+     where fixed_opts = if Interactive `elem` opts+                        then opts+                        else All : opts+           cannotApplyMissing pinfo+               = errorDoc $ text "Cannot apply this patch bundle, since we're missing:"+                         $$ human_friendly pinfo+           cannotApplyPartialRepo pinfo e+               = errorDoc $ text ("Cannot apply this patch bundle, "+                               ++ "this is a \"--partial repository")+                         $$ text "We don't have the following patch:"+                         $$ human_friendly pinfo $$ text e+apply_cmd _ _ = impossible+\end{code}++Darcs apply accepts a single argument, which is the name of the patch+file to be applied.  If you omit this argument, the patch is read from+standard input.  Darcs also interprets an argument of `\-' to mean it+should read the file from standard input. This allows you to use apply+with a pipe from your email program, for example.++\begin{options}+--verify+\end{options}++If you specify the \verb!--verify PUBRING! option, darcs will check that+the patch was GPG-signed by a key which is in \verb!PUBRING! and will+refuse to apply the patch otherwise.++\begin{code}+get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString+                 -> IO (Either String (SealedPatchSet p))+get_patch_bundle opts fps = do+    mps <- verifyPS opts $ read_email fps+    mops <- verifyPS opts fps+    case (mps, mops) of+      (Nothing, Nothing) ->+          return $ Left "Patch bundle not properly signed, or gpg failed."+      (Just ps, Nothing) -> return $ scan_bundle ps+      (Nothing, Just ps) -> return $ scan_bundle ps+      -- We use careful_scan_bundle only below because in either of the two+      -- above case we know the patch was signed, so it really shouldn't+      -- need stripping of CRs.+      (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of+                              Left _ -> return $ careful_scan_bundle ps2+                              Right x -> return $ Right x+          where careful_scan_bundle ps =+                    case scan_bundle ps of+                    Left e -> case scan_bundle $ stripCrPS ps of+                              Right x -> Right x+                              _ -> Left e+                    x -> x+                stripCrPS :: B.ByteString -> B.ByteString+                stripCrPS ps = unlinesPS $ map stripline $ linesPS ps+                stripline p | B.null p = p+                            | BC.last p == '\r' = B.init p+                            | otherwise = p+\end{code}++\begin{options}+--cc, --reply+\end{options}++If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the+results of the application to the sender of the patch.  This only works if+the patch is in the form of email with its headers intact, so that darcs+can actually know the origin of the patch.  The reply email will indicate+whether or not the patch was successfully applied.  The \verb!FROM! flag is+the email address that will be used as the ``from'' address when replying.+If the darcs apply is being done automatically, it is important that this+address not be the same as the address at which the patch was received, in+order to avoid automatic email loops.++If you want to also send the apply email to another address (for example,+to create something like a ``commits'' mailing list), you can use the+\verb!--cc! option to specify additional recipients.  Note that the+\verb!--cc! option \emph{requires} the \verb!--reply! option, which+provides the ``From'' address.++The \verb!--reply! feature of apply is intended primarily for two uses.+When used by itself, it is handy for when you want to apply patches sent to+you by other developers so that they will know when their patch has been+applied.  For example, in my \verb!.muttrc! (the config file for my mailer)+I have:+\begin{verbatim}+macro pager A "<pipe-entry>darcs apply --verbose \+        --reply droundy@abridgegame.org --repodir ~/darcs+\end{verbatim}+which allows me to apply a patch to darcs directly from my mailer, with the+originator of that patch being sent a confirmation when the patch is+successfully applied.  NOTE: In an attempt to make sure no one else+can read your email, mutt seems to set the umask+such that patches created with the above macro are not world-readable, so+use it with care.++When used in combination with the \verb!--verify! option, the+\verb!--reply! option allows for a nice pushable repository.  When these+two options are used together, any patches that don't pass the verify will+be forwarded to the \verb!FROM! address of the \verb!--reply! option.  This+allows you to set up a repository so that anyone who is authorized can push+to it and have it automatically applied, but if a stranger pushes to it,+the patch will be forwarded to you.  Please (for your own sake!)\ be certain+that the \verb!--reply FROM! address is different from the one used to send+patches to a pushable repository, since otherwise an unsigned patch will be+forwarded to the repository in an infinite loop.++If you use \verb!darcs apply --verify PUBRING --reply! to create a+pushable repository by applying patches automatically as they are received by+email, you will also want to use the \verb!--dont-allow-conflicts! option.++\begin{options}+--dont-allow-conflicts+\end{options}+The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a+patch would cause conflicts.  This flag is recommended on repositories+which will be pushed to or sent to.++\begin{options}+--allow-conflicts+\end{options}++\verb!--allow-conflicts! will allow conflicts, but will keep the local and+recorded versions in sync on the repository.  This means the conflict will exist+in both locations until it is resolved.++\begin{options}+--mark-conflicts+\end{options}++\verb!--mark-conflicts! will add conflict markers to illustrate the the+conflict.++\begin{options}+--external-merge+\end{options}++You can use an external interactive merge tool to resolve conflicts with the+flag \verb!--external-merge!.  For more details see+subsection~\ref{resolution}.++\begin{options}+--all, --interactive+\end{options}++If you provide the \verb!--interactive! flag, darcs will+ask you for each change in the patch bundle whether or not you wish to+apply that change.  The opposite is the \verb!--all! flag, which can be+used to override an \verb!interactive! which might be set in your+``defaults'' file.++\begin{options}+--sendmail-command+\end{options}++If you want to use a command different from the default one for sending mail,+you need to specify a command line with the \verb!--sendmail-command! option.+The command line can contain the format specifier \verb!%t! for to+and you can add \verb!%<! to the end of the command line if the command+expects the complete mail on standard input. For example, the command line for+msmtp looks like this:++\begin{verbatim}+msmtp -t %<+\end{verbatim}+++\begin{code}+get_from :: B.ByteString -> String+get_from ps = readFrom $ linesPS ps+    where readFrom [] = ""+          readFrom (x:xs)+           | B.take 5 x == from_start = BC.unpack $ B.drop 5 x+           | otherwise = readFrom xs++redirect_output :: [DarcsFlag] -> String -> IO a -> IO a+redirect_output opts to doit = ro opts+    where+  cc = get_cc opts+  ro [] = doit+  ro (Reply f:_) =+    withStdoutTemp $ \tempf-> do {a <- doit;+                                  hClose stdout;+                                  hClose stderr;+                                  return a;+                                 } `catch` (sendit tempf)+        where sendit tempf e@(ExitException ExitSuccess) =+                do sendSanitizedEmail opts f to "Patch applied" cc tempf+                   throwIO e+              sendit tempf (ExitException _) =+                do sendSanitizedEmail opts f to "Patch failed!" cc tempf+                   throwIO $ ExitException ExitSuccess+              sendit tempf e =+                do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $+                             tempf ++ "\n\nCaught exception:\n"+++                             show e++"\n"+                   throwIO $ ExitException ExitSuccess+  ro (_:fs) = ro fs++-- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd+-- It takes @DacrsFlag@ options a file with the mail contents,+-- To:, Subject:, CC:, and mail body+sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()+sendSanitizedEmail opts file to subject cc mailtext =+    do scmd <- get_sendmail_cmd opts+       body <- sanitizeFile mailtext+       sendEmail file to subject cc scmd body++-- sanitizeFile is used to clean up the stdout/stderr before sticking it in+-- an email.++sanitizeFile :: FilePath -> IO String+sanitizeFile f = sanitize `fmap` readBinFile f+    where sanitize s = wash $ remove_backspaces "" s+          wash ('\000':s) = "\\NUL" ++ wash s+          wash ('\026':s) = "\\EOF" ++ wash s+          wash (c:cs) = c : wash cs+          wash [] = []+          remove_backspaces rev_sofar "" = reverse rev_sofar+          remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s+          remove_backspaces "" ('\008':s) = remove_backspaces "" s+          remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss++throwIO :: Exception -> IO a+throwIO e = return $ throw e++forwarding_message :: B.ByteString+forwarding_message = BC.pack $+    "The following patch was either unsigned, or signed by a non-allowed\n"+++    "key, or there was a GPG failure.\n"++consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool+consider_forwarding opts m = cf opts (get_cc opts)+    where cf [] _ = return False+          cf (Reply t:_) cc =+              case break is_from (linesPS m) of+              (m1, f:m2) ->+                  let m_lines = forwarding_message:m1 ++ m2+                      m' = unlinesPS m_lines+                      f' = BC.unpack (B.drop 5 f) in+                      if t == f' || t == init f'+                      then return False -- Refuse possible email loop.+                      else do+                        scmd <- get_sendmail_cmd opts+                        if HappyForwarding `elem` opts+                         then resendEmail t scmd m+                         else sendEmailDoc f' t "A forwarded darcs patch" cc+                                           scmd (Just (empty,empty))+                                           (packedString m')+                        return True+              _ -> return False -- Don't forward emails lacking headers!+          cf (_:fs) cc = cf fs cc+          is_from l = B.take 5 l == from_start++from_start :: B.ByteString+from_start = BC.pack "From:"+\end{code}++\begin{options}+--no-test, --test+\end{options}++If you specify the \verb!--test! option, apply will run the test (if a test+exists) prior to applying the patch.  If the test fails, the patch is not+applied.  In this case, if the \verb!--reply! option was used, the results+of the test are sent in the reply email.  You can also specify the+\verb!--no-test! option, which will override the \verb!--test! option, and+prevent the test from being run.  This is helpful when setting up a+pushable repository, to keep users from running code.++
+ src/Darcs/Commands/Changes.lhs view
@@ -0,0 +1,294 @@+%  Copyright (C) 2003-2004 David Roundy+%+%  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{changes}+\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, PatternGuards #-}++module Darcs.Commands.Changes ( changes ) where++import Data.List ( intersect, sort )+import Data.Maybe ( fromMaybe )+import Control.Monad ( when, unless )++import Darcs.Hopefully ( hopefullyM, info )+import Darcs.Patch.Depends ( slightly_optimize_patchset )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable,+                                   Interactive, OnlyChangesToFiles, Count,+                                   NumberPatches, XMLOutput, Summary,+                                   Reverse, Verbose, Debug),+                         fixSubPaths, changes_format,+                         possibly_remote_repo_dir, get_repourl,+                         working_repo_dir, only_to_files,+                         summary, changes_reverse,+                         match_several_or_range,+                         match_maxcount, maxCount,+                         all_interactive, showFriendly,+                         network_options+                      )+import Darcs.RepoPath ( toFilePath, rootDirectory )+import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path )+import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd,+                          get_unrecorded_in_files_unsorted,+                          withRepositoryDirectory, ($-), findRepository,+                          read_repo )+import Darcs.Patch.Info ( to_xml, showPatchInfo )+import Darcs.Patch.Depends ( get_common_and_uncommon )+import Darcs.Patch.TouchesFiles ( look_touch )+import Darcs.Patch ( RepoPatch, invert, xml_summary, description, apply_to_filepaths,+                     list_touched_files, effect, identity )+import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,+                             EqCheck(..), filterFL )+import Darcs.Match ( first_match, second_match,+               match_a_patchread, have_nonrange_match,+               match_first_patchset, match_second_patchset,+             )+import Darcs.Commands.Annotate ( created_as_xml )+import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),+                 renderString, prefix, text, vcat, vsep, +                 ($$), empty, errorDoc, insert_before_lastline )+import Darcs.ColorPrinter ( fancyPrinters )+import Progress ( setProgressMode, debugMessage )+import Darcs.SelectChanges ( view_changes )+import Darcs.Sealed ( unsafeUnseal )+#include "impossible.h"++changes_description :: String+changes_description = "Gives a changelog-style summary of the repository history."++changes_help :: String+changes_help =+ "Changes gives a changelog-style summary of the repository history,\n"+++ "including options for altering how the patches are selected and displayed.\n"++changes :: DarcsCommand+changes = DarcsCommand {command_name = "changes",+                        command_help = changes_help,+                        command_description = changes_description,+                        command_extra_args = -1,+                        command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                        command_get_arg_possibilities = return [],+                        command_command = changes_cmd,+                        command_prereq = findRepository,+                        command_argdefaults = nodefaults,+                        command_advanced_options = network_options,+                        command_basic_options = [match_several_or_range,+                                                 match_maxcount,+                                                 only_to_files,+                                                 changes_format,+                                                 summary,+                                                 changes_reverse,+                                                 possibly_remote_repo_dir,+                                                 working_repo_dir,+                                                 all_interactive]}++changes_cmd :: [DarcsFlag] -> [String] -> IO ()+changes_cmd [Context _] [] = return ()+changes_cmd opts args | Context rootDirectory `elem` opts =+  let repodir = fromMaybe "." (get_repourl opts) in+  withRepositoryDirectory opts repodir $- \repository -> do+  when (args /= []) $ fail "changes --context cannot accept other arguments"+  changes_context repository opts+changes_cmd opts args =+  let repodir = fromMaybe "." (get_repourl opts) in+  withRepositoryDirectory opts repodir $- \repository -> do+  unless (Debug `elem` opts) $ setProgressMode False+  files <- sort `fmap` fixSubPaths opts args+  unrec <- if null files then return identity+             else get_unrecorded_in_files_unsorted repository (map (fp2fn . toFilePath) files)+           `catch` \_ -> return identity -- this is triggered when repository is remote+  let filez = map (fn2fp . norm_path . fp2fn) $ apply_to_filepaths (invert unrec) $ map toFilePath files+      filtered_changes p = maybe_reverse $ get_changes_info opts filez p+  debugMessage "About to read the repository..."+  patches <- read_repo repository+  debugMessage "Done reading the repository."+  if Interactive `elem` opts+    then do let (fp_and_fs, _, _) = filtered_changes patches+                fp = map fst fp_and_fs+            view_changes opts (unsafeFL fp)+    else do when (not (null files) && not (XMLOutput `elem` opts)) $+                 putStrLn $ "Changes to "++unwords filez++":\n"+            debugMessage "About to print the changes..."+            let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters+            ps <- read_repo repository -- read repo again to prevent holding onto+                                       -- values forced by filtered_changes+            putDocLnWith printers $ changelog opts ps $ filtered_changes patches+  where maybe_reverse (xs,b,c) = if Reverse `elem` opts+                                 then (reverse xs, b, c)+                                 else (xs, b, c)+\end{code}++When given one or more files or directories as an argument, changes lists only+those patches which affect those files or the contents of those directories or,+of course, the directories themselves. This includes changes that happened to+files before they were moved or renamed.++\begin{options}+--from-match, --from-patch, --from-tag+\end{options}++If changes is given a \verb!--from-patch!, \verb!--from-match!, or+\verb!--from-tag! option, it outputs only those changes since that tag or+patch.++Without any options to limit the scope of the changes, history will be displayed+going back as far as possible.++\begin{options}+--max-count+\end{options}++If changes is given a \verb!--max-count! option, it only outputs up to as that+number of changes.++\begin{code}+get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p+                 -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)+get_changes_info opts plain_fs ps =+  case get_common_and_uncommon (p2s,p1s) of+  (_,us:\/:_) -> filter_patches_by_names (maxCount opts) fs $ filter pf $ unsafeUnRL $ concatRL us+  where fs = map (\x -> "./" ++ x) $ plain_fs+        p1s = if first_match opts then unsafeUnseal $ match_first_patchset opts ps+                                  else NilRL:<:NilRL+        p2s = if second_match opts then unsafeUnseal $ match_second_patchset opts ps+                                   else ps+        pf = if have_nonrange_match opts+             then match_a_patchread opts+             else \_ -> True++-- | Take a list of filenames and patches and produce a list of+-- patches that actually touch the given files with list of touched+-- file names, a new file list that represents the same set of files+-- as in input, before the returned patches would have been applied,+-- and possibly an error. Additionaly, the function takes a "depth+-- limit" -- maxcount, that could be Nothing (return everything) or+-- "Just n" -- returns at most n patches touching the file (starting+-- from the beginning of the patch list).+filter_patches_by_names :: RepoPatch p =>+                           Maybe Int -- ^ maxcount+                        -> [FilePath] -- ^ filenames+                        -> [PatchInfoAnd p] -- ^ patchlist+                        -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc)+filter_patches_by_names (Just 0) _ _ = ([], [], empty)+filter_patches_by_names _ _ [] = ([], [], empty)+filter_patches_by_names maxcount [] (hp:ps) =+    (hp, []) -:- filter_patches_by_names (subtract 1 `fmap` maxcount) [] ps+filter_patches_by_names maxcount fs (hp:ps)+    | Just p <- hopefullyM hp =+    case look_touch fs (invert p) of+    (True, []) -> ([(hp, fs)], fs, empty)+    (True, fs') -> (hp, fs) -:- filter_patches_by_names+                                (subtract 1 `fmap` maxcount) fs' ps+    (False, fs') -> filter_patches_by_names maxcount fs' ps+filter_patches_by_names _ _ (hp:_) =+    ([], [], text "Can't find changes prior to:" $$ description hp)++-- | Note, lazy pattern matching is required to make functions like+-- filter_patches_by_names lazy in case you are only not interested in+-- the first element. E.g.:+--+--   let (fs, _, _) = filter_patches_by_names ...+(-:-) :: a -> ([a],b,c) -> ([a],b,c)+x -:- ~(xs,y,z) = (x:xs,y,z)++changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)+          -> Doc+changelog opts patchset (pis_and_fs, orig_fs, errstring)+    | Count `elem` opts = text $ show $ length pis_and_fs+    | MachineReadable `elem` opts =+        if renderString errstring == ""+        then vsep $ map (showPatchInfo.info) pis+        else errorDoc errstring+    | XMLOutput `elem` opts =+         text "<changelog>"+      $$ vcat xml_file_names+      $$ vcat actual_xml_changes+      $$ text "</changelog>"+    | Summary `elem` opts || Verbose `elem`  opts =+           vsep (map (number_patch change_with_summary) pis_and_fs)+        $$ errstring+    | otherwise = vsep (map (number_patch description') pis_and_fs)+               $$ errstring+    where change_with_summary (hp, fs)+              | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts+                                          then description hp $$ text "" $$+                                               indent (showFriendly opts (filterFL xx $ effect p))+                                          else showFriendly opts p+              | otherwise = description hp+                            $$ indent (text "[this patch is unavailable]")+              where xx x = case list_touched_files x of+                             ys | null $ ys `intersect` fs -> IsEq+                             _ -> NotEq+          xml_with_summary hp+              | Just p <- hopefullyM hp = insert_before_lastline+                                           (to_xml $ info hp) (indent $ xml_summary p)+          xml_with_summary hp = to_xml (info hp)+          indent = prefix "    "+          actual_xml_changes = if Summary `elem` opts+                               then map xml_with_summary pis+                               else map (to_xml.info) pis+          xml_file_names = map (created_as_xml first_change) orig_fs+          first_change = if Reverse `elem` opts+                         then info $ head pis+                         else info $ last pis+          number_patch f x = if NumberPatches `elem` opts+                             then case get_number (fst x) of+                                  Just n -> text (show n++":") <+> f x+                                  Nothing -> f x+                             else f x+          get_number :: PatchInfoAnd p -> Maybe Int+          get_number y = gn 1 (concatRL patchset)+              where iy = info y+                    gn n (b:<:bs) | seq n (info b) == iy = Just n+                                  | otherwise = gn (n+1) bs+                    gn _ NilRL = Nothing+          pis = map fst pis_and_fs+          description' = description . fst++\end{code}++\begin{options}+--context, --human-readable, --xml-output+\end{options}++When given the \verb!--context! flag, darcs changes outputs sufficient+information to allow the current state of the repository to be+recreated at a later date.  This information should generally be piped to a+file, and then can be used later in conjunction with+\verb!darcs get --context! to recreate the current version.  Note that+while the \verb!--context! flag may be used in conjunction with+\verb!--xml-output! or \verb!--human-readable!, in neither case will darcs+get be able to read the output.  On the other hand, sufficient information+\emph{will} be output for a knowledgeable human to recreate the current+state of the repository.+\begin{code}+changes_context :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()+changes_context repository opts = do+  r <- read_repo repository+  putStrLn "\nContext:\n"+  when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $+    putDocLnWith simplePrinters $ changelog opts' NilRL $+                 get_changes_info opts' []+                 (headRL (slightly_optimize_patchset r) :<: NilRL)+    where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts+                  then opts+                  else MachineReadable : opts+          headRL (x:<:_) = x+          headRL NilRL = impossible+\end{code}
+ src/Darcs/Commands/Check.lhs view
@@ -0,0 +1,107 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{check}+\begin{code}+module Darcs.Commands.Check ( check ) where+import Control.Monad ( when )+import System.Exit ( ExitCode(..), exitWith )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Quiet ),+                        partial_check, notest, testByDefault,+                        leave_test_dir, working_repo_dir,+                      )+import Darcs.Repository.Repair( replayRepository,+                              RepositoryConsistency(..) )+import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded,+                          testRecorded )+import Darcs.Patch ( RepoPatch, showPatch )+import Darcs.Ordered ( FL(..) )+import Darcs.Diff ( unsafeDiff )+import Darcs.Repository.Prefs ( filetype_function )+import Printer ( putDocLn, text, ($$), (<+>) )++check_description :: String+check_description = "Check the repository for consistency."++check_help :: String+check_help =+ "This command verifies that the patches in the repository, when applied\n" +++ "successively to an empty tree, result in the pristine tree.  If not,\n" +++ "the differences are printed and Darcs exits unsucessfully (with a\n" +++ "non-zero exit status).\n" +++ "\n" +++ "If the repository is in darcs-1 format and has a checkpoint, you can\n" +++ "use the --partial option to start checking from the latest checkpoint.\n" +++ "This is the default for partial darcs-1 repositories; the --complete\n" +++ "option to forces a full check.\n" +++ "\n" +++ "If a regression test is defined (see `darcs setpref') it will be run\n" +++ "by `darcs check'.  Use the --no-test option to disable this.\n"++check :: DarcsCommand+check = DarcsCommand {command_name = "check",+                      command_help = check_help,+                      command_description = check_description,+                      command_extra_args = 0,+                      command_extra_arg_help = [],+                      command_command = check_cmd,+                      command_prereq = amInRepository,+                      command_get_arg_possibilities = return [],+                      command_argdefaults = nodefaults,+                      command_advanced_options = [],+                      command_basic_options = [partial_check,+                                              notest,+                                              leave_test_dir,+                                              working_repo_dir+                                             ]}++check_cmd :: [DarcsFlag] -> [String] -> IO ()+check_cmd opts _ = withRepository opts (check' opts)++check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()+check' opts repository = do+    replayRepository repository (testByDefault opts) $ \ state -> do+      case state of+        RepositoryConsistent -> do+          putInfo $ text "The repository is consistent!"+          testRecorded repository+          exitWith ExitSuccess+        BrokenPristine newpris -> do+          brokenPristine newpris+          exitWith $ ExitFailure 1+        BrokenPatches newpris _ -> do+          brokenPristine newpris+          putInfo $ text "Found broken patches."+          exitWith $ ExitFailure 1+   where +     brokenPristine newpris = do+         putInfo $ text "Looks like we have a difference..."+         mc <- slurp_recorded repository+         ftf <- filetype_function+         putInfo $ case unsafeDiff opts ftf newpris mc of+                        NilFL -> text "Nothing"+                        patch -> text "Difference: " <+> showPatch patch+         putInfo $ text ""+                     $$ text "Inconsistent repository!"+     putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s++\end{code}+%% FIXME: this should go in "common options" or something, since+%% commands like record and amend-record also run the test command.+\input{Darcs/Test.lhs}
+ src/Darcs/Commands/Convert.lhs view
@@ -0,0 +1,260 @@+%  Copyright (C) 2002-2005,2007 David Roundy+%+%  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{convert}+\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash #-}++#include "gadts.h"++module Darcs.Commands.Convert ( convert ) where++import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,+                   createDirectory )+import Workaround ( getCurrentDirectory )+import Control.Monad ( when )+import GHC.Base ( unsafeCoerce# )+import Data.Maybe ( catMaybes )++import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( AllowConflicts, NewRepo,+                                    SetScriptsExecutable, UseFormat2, NoUpdateWorking,+                                    Verbose, Quiet ),+                        reponame,+                        set_scripts_executable,+                        network_options )+import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,+                          createRepository,+                          slurp_recorded, optimizeInventory,+                          tentativelyMergePatches, patchSetToPatches,+                          createPristineDirectoryTree,+                          revertRepositoryChanges, finalizeRepositoryChanges, sync_repo )+import Darcs.Global ( darcsdir )+import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,+                     modernize_patch,+                     adddeps, getdeps, effect, flattenFL, is_merger, patchcontents )+import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,+                             concatFL, concatRL, mapRL )+import Darcs.Patch.Info ( pi_rename, pi_tag, is_tag )+import Darcs.Patch.Commute ( public_unravel )+import Darcs.Patch.Real ( mergeUnravelled )+import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Darcs.Repository.Motd ( show_motd )+import Darcs.Utils ( clarify_errors, askUser )+import Darcs.ProgressPatches ( progressFL )+import Darcs.Sealed ( FlippedSeal(..) )+import Printer ( text, putDocLn, ($$) )+import Darcs.ColorPrinter ( traceDoc )+import Darcs.SlurpDirectory ( list_slurpy_files )+import Darcs.Lock ( writeBinFile )+import Workaround ( setExecutable )+import qualified Data.ByteString as B (isPrefixOf, readFile)+import qualified Data.ByteString.Char8 as BC (pack)+import Darcs.Gorsvet( invalidateIndex )++convert_description :: String+convert_description = "Convert a repository from a legacy format."++convert_help :: String+convert_help =+ "The current repository format is called `darcs-2'.  It was introduced\n" +++ "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" +++ "The `darcs convert' command allows existing projects to migrate to\n" +++ "this format from the older `darcs-1' format.\n" +++ "\n" +++ "This command DOES NOT modify the source repository; a new destination\n" +++ "repository is created.  It is safe to run this command more than once\n" +++ "on a repository (e.g. for testing), before the final conversion.\n" +++ "\n" +++ convert_help' +++ "\n" +++ "Due to this limitation, migrating a multi-branch project is a little\n" +++ "awkward.  Sorry!  Here is the recommended process:\n" +++ "\n" +++ " 1. for each branch `foo', tag that branch with `foo-final';\n" +++ " 2. merge all branches together (--allow-conflicts may help);\n" +++ " 3. run `darcs optimize --reorder' on the result;\n" +++ " 4. run `darcs convert' to create a merged darcs-2 repository;\n" +++ " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" +++ "    the darcs-2 repository; and finally\n" +++ " 6. use `darcs obliterate' to delete the foo-final tags.\n"++-- | This part of the help is split out because it is used twice: in+-- the help string, and in the prompt for confirmation.+convert_help' :: String+convert_help' =+ "WARNING: the repository produced by this command is not understood by\n" +++ "Darcs 1.x, and patches cannot be exchanged between repositories in\n" +++ "darcs-1 and darcs-2 formats.\n" +++ "\n" +++ "Furthermore, darcs 2 repositories created by different invocations of\n" +++ "this command SHOULD NOT exchange patches, unless those repositories\n" +++ "had no patches in common when they were converted.  (That is, within a\n" +++ "set of repos that exchange patches, no patch should be converted more\n" +++ "than once.)\n"++convert :: DarcsCommand+convert = DarcsCommand {command_name = "convert",+                    command_help = convert_help,+                    command_description = convert_description,+                    command_extra_args = -1,+                    command_extra_arg_help = ["<SOURCE>", "[<DESTINATION>]"],+                    command_command = convert_cmd,+                    command_prereq = \_ -> return $ Right (),+                    command_get_arg_possibilities = return [],+                    command_argdefaults = nodefaults,+                    command_advanced_options = network_options,+                    command_basic_options = [reponame,set_scripts_executable]}++convert_cmd :: [DarcsFlag] -> [String] -> IO ()+convert_cmd opts [inrepodir, outname] = convert_cmd (NewRepo outname:opts) [inrepodir]+convert_cmd orig_opts [inrepodir] = do+  putStrLn convert_help'+  let vow = "I understand the consequences of my action"+  putStrLn "Please confirm that you have read and understood the above"+  vow' <- askUser ("by typing `" ++ vow ++ "': ")+  when (vow' /= vow) $ fail "User didn't understand the consequences."+  let opts = UseFormat2:orig_opts+  typed_repodir <- ioAbsoluteOrRemote inrepodir+  let repodir = toPath typed_repodir+  show_motd opts repodir+  mysimplename <- make_repo_name opts repodir+  createDirectory mysimplename+  setCurrentDirectory mysimplename+  createRepository opts+  writeBinFile (darcsdir++"/hashed_inventory") ""+  withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo ->+    withRepositoryDirectory opts repodir $- \themrepobar -> do+      -- We really ought to have special versions of withRepoLock and+      -- withRepositoryDirectory that check at runtime that it's the right+      -- sort of repository and accept a function of (Repository Patch) or+      -- (Repository (FL RealPatch)), but that seems like a lot of work+      -- when these functions would be used exactly once, right here.  So I+      -- go with a horrible evil hack.++      -- The other alternative (which is what we used to do) is to use+      -- "universal" functions to do the conversion, but that's also+      -- unsatisfying.++      let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch)+          themrepo = unsafeCoerce# themrepobar :: Repository Patch+      theirstuff <- read_repo themrepo+      let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff+          inOrderTags = iot theirstuff+              where iot ((t:<:NilRL):<:r) = info t : iot r+                    iot (NilRL:<:r) = iot r+                    iot NilRL = []+                    iot ((_:<:x):<:y) = iot (x:<:y)+          outOfOrderTags = catMaybes $ mapRL oot $ concatRL theirstuff+              where oot t = if is_tag (info t) && not (info t `elem` inOrderTags)+                            then Just (info t, getdeps $ hopefully t)+                            else Nothing+          fixDep p = case lookup p outOfOrderTags of+                     Just d -> p : concatMap fixDep d+                     Nothing -> [p]+          convertOne :: Patch -> FL RealPatch+          convertOne x | is_merger x = case mergeUnravelled $ public_unravel $ modernize_patch x of+                                       Just (FlippedSeal y) ->+                                           case effect y =/\= effect x of+                                           IsEq -> y :>: NilFL+                                           NotEq ->+                                               traceDoc (text "lossy conversion:" $$+                                                         showPatch x)+                                               fromPrims (effect x)+                                       Nothing -> traceDoc (text+                                                            "lossy conversion of complicated conflict:" $$+                                                            showPatch x)+                                                  fromPrims (effect x)+                       | otherwise = case flattenFL x of+                                     NilFL -> NilFL+                                     (x':>:NilFL) -> fromPrims $ effect x'+                                     xs -> concatFL $ mapFL_FL convertOne xs+          convertNamed :: Named Patch -> PatchInfoAnd (FL RealPatch)+          convertNamed n = n2pia $+                           adddeps (infopatch (convertInfo $ patch2patchinfo n) $+                                              convertOne $ patchcontents n)+                                   (map convertInfo $ concatMap fixDep $ getdeps n)+          convertInfo n | n `elem` inOrderTags = n+                        | otherwise = maybe n (\t -> pi_rename n ("old tag: "++t)) $ pi_tag n+          applySome xs = do tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs+                            finalizeRepositoryChanges repository -- this is to clean out pristine.hashed+                            revertRepositoryChanges repository+      sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches+      invalidateIndex repository+      revertable $ createPristineDirectoryTree repository "."+      when (SetScriptsExecutable `elem` opts) $+               do putVerbose $ text "Making scripts executable"+                  c <- list_slurpy_files `fmap` slurp_recorded repository+                  let setExecutableIfScript f =+                            do contents <- B.readFile f+                               when (BC.pack "#!" `B.isPrefixOf` contents) $ do+                                 putVerbose $ text ("Making executable: " ++ f)+                                 setExecutable f True+                  mapM_ setExecutableIfScript c+      sync_repo repository+      optimizeInventory repository+      putInfo $ text "Finished converting."+      where am_verbose = Verbose `elem` orig_opts+            am_informative = not $ Quiet `elem` orig_opts+            putVerbose s = when am_verbose $ putDocLn s+            putInfo s = when am_informative $ putDocLn s+            revertable x = x `clarify_errors` unlines+                  ["An error may have left your new working directory an inconsistent",+                   "but recoverable state. You should be able to make the new",+                   "repository consistent again by running darcs revert -a."]++convert_cmd _ _ = fail "You must provide 'convert' with either one or two arguments."++make_repo_name :: [DarcsFlag] -> FilePath -> IO String+make_repo_name (NewRepo n:_) _ =+    do exists <- doesDirectoryExist n+       file_exists <- doesFileExist n+       if exists || file_exists+          then fail $ "Directory or file named '" ++ n ++ "' already exists."+          else return n+make_repo_name (_:as) d = make_repo_name as d+make_repo_name [] d =+  case dropWhile (=='.') $ reverse $+       takeWhile (\c -> c /= '/' && c /= ':') $+       dropWhile (=='/') $ reverse d of+  "" -> modify_repo_name "anonymous_repo"+  base -> modify_repo_name base++modify_repo_name :: String -> IO String+modify_repo_name name =+    if head name == '/'+    then mrn name (-1)+    else do cwd <- getCurrentDirectory+            mrn (cwd ++ "/" ++ name) (-1)+ where+  mrn :: String -> Int -> IO String+  mrn n i = do+    exists <- doesDirectoryExist thename+    file_exists <- doesFileExist thename+    if not exists && not file_exists+       then do when (i /= -1) $+                    putStrLn $ "Directory '"++ n +++                               "' already exists, creating repository as '"+++                               thename ++"'"+               return thename+       else mrn n $ i+1+    where thename = if i == -1 then n else n++"_"++show i+                        +\end{code}
+ src/Darcs/Commands/Diff.lhs view
@@ -0,0 +1,245 @@+%  Copyright (C) 2003-2004 David Roundy+%+%  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{diff}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Diff ( diff_command ) where++import System.FilePath.Posix ( takeFileName )+import System.Directory ( setCurrentDirectory )+import Workaround ( getCurrentDirectory )+import Darcs.Utils ( askUser, withCurrentDirectory )+import Control.Monad ( when )+import Data.List ( (\\) )++import Darcs.External( diff_program )+import CommandLine ( parseCmd )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(DiffFlags, Unified, DiffCmd,+                                   LastN, AfterPatch),+                        match_range, store_in_memory, +                        diff_cmd_flag, diffflags, unidiff,+                         working_repo_dir, fixSubPaths,+                      )+import Darcs.Hopefully ( info )+import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.Match ( get_partial_first_match, get_partial_second_match,+                     first_match, second_match,+                     match_first_patchset, match_second_patchset )+import Darcs.Repository ( PatchSet, withRepository, ($-), read_repo,+                          amInRepository, slurp_recorded_and_unrecorded,+                          createPristineDirectoryTree,+                          createPartialsPristineDirectoryTree )+import Darcs.SlurpDirectory ( get_path_list, writeSlurpy )+import Darcs.Patch ( RepoPatch )+import Darcs.Ordered ( mapRL, concatRL )+import Darcs.Patch.Info ( PatchInfo, human_friendly )+import Darcs.External ( execPipeIgnoreError, clonePaths )+import Darcs.Lock ( withTempDir )+import Darcs.Sealed ( unsafeUnseal )+import Printer ( Doc, putDoc, vcat, empty, ($$) )+#include "impossible.h"++diff_description :: String+diff_description = "Create a diff between two versions of the repository."++diff_help :: String+diff_help =+ "Diff can be used to create a diff between two versions which are in your\n"+++ "repository.  Specifying just --from-patch will get you a diff against\n"+++ "your working copy.  If you give diff no version arguments, it gives\n"+++ "you the same information as whatsnew except that the patch is\n"+++ "formatted as the output of a diff command\n"++diff_command :: DarcsCommand+diff_command = DarcsCommand {command_name = "diff",+                             command_help = diff_help,+                             command_description = diff_description,+                             command_extra_args = -1,+                             command_extra_arg_help+                                 = ["[FILE or DIRECTORY]..."],+                             command_command = diff_cmd,+                             command_prereq = amInRepository,+                             command_get_arg_possibilities = return [],+                             command_argdefaults = nodefaults,+                             command_advanced_options = [],+                             command_basic_options = [match_range,+                                                     diff_cmd_flag,+                                                     diffflags, unidiff,+                                                     working_repo_dir, store_in_memory]}+\end{code}++\begin{options}+--diff-opts+\end{options}++Diff calls an external ``diff'' command to do the actual work, and passes+any unrecognized flags to this diff command.  Thus you can call+\begin{verbatim}+% darcs diff -t 0.9.8 -t 0.9.10 -- -u+\end{verbatim}+to get a diff in the unified format.  Actually, thanks to the wonders of+getopt you need the ``\verb!--!'' shown above before any arguments to diff.+You can also specify additional arguments to diff using the+\verb!--diff-opts! flag.  The above command would look like this:+\begin{verbatim}+% darcs diff --diff-opts -u -t 0.9.8 -t 0.9.10+\end{verbatim}+This may not seem like an improvement, but it really pays off when you want+to always give diff the same options.  You can do this by adding+\begin{verbatim}+% diff diff-opts -udp+\end{verbatim}+to your \verb!_darcs/prefs/defaults! file.++\begin{code}+get_diff_opts :: [DarcsFlag] -> [String]+get_diff_opts [] = []+get_diff_opts (Unified:fs) = "-u" : get_diff_opts fs+get_diff_opts (DiffFlags f:fs) = f : get_diff_opts fs+get_diff_opts (_:fs) = get_diff_opts fs++has_diff_cmd_flag :: [DarcsFlag] -> Bool+has_diff_cmd_flag (DiffCmd _:_) = True+has_diff_cmd_flag (_:t) = has_diff_cmd_flag t+has_diff_cmd_flag []  = False++-- | Returns the command we should use for diff as a tuple (command, arguments).+-- This will either be whatever the user specified via --diff-command  or the+-- default 'diff_program'.  Note that this potentially involves parsing the+-- user's diff-command, hence the possibility for failure with an exception.+get_diff_cmd_and_args :: String -> [DarcsFlag] -> String -> String+                      -> Either String (String, [String])+get_diff_cmd_and_args cmd opts f1 f2 = helper opts where+  helper (DiffCmd c:_) =+    case parseCmd [ ('1', f1) , ('2', f2) ] c of+    Left err        -> Left $ show err+    Right ([],_)    -> bug $ "parseCmd should never return empty list"+    Right ((h:t),_) -> Right (h,t)+  helper [] = -- if no command specified, use 'diff'+    Right (cmd, ("-rN":get_diff_opts opts++[f1,f2]))+  helper (_:t) = helper t+\end{code}++If you want to view only the differences to one or more files, you can do+so with a command such as+\begin{verbatim}+% darcs diff foo.c bar.c baz/+\end{verbatim}++\begin{options}+--diff-command+\end{options}++You can use a different program to view differences by including+the flag \verb!--diff-command!, e.g.+\begin{verbatim}+--diff-command 'opendiff %1 %2'.+\end{verbatim}+The \verb!%1! and \verb!%2!  are replaced with the two versions to be+merged.  The above example works with the FileMerge.app tool that comes with+Apple's developer tools.  To use xxdiff, you would use+\begin{verbatim}+--diff-command 'xxdiff %1 %2'+\end{verbatim}+To use \verb!kdiff3!, you can use+\begin{verbatim}+--diff-command 'kdiff3 %1 %2'+\end{verbatim}++Note that the command is split into space-separated words and the first one is+\verb!exec!ed with the rest as arguments---it is not a shell command.  Also+the substitution of the \verb!%! escapes is only done on complete words.+See \ref{resolution} for how you might work around this fact, for example,+with Emacs' Ediff package.++Note also that the \verb!--diff-opts! flag is ignored if you use this option.++\begin{code}+diff_cmd :: [DarcsFlag] -> [String] -> IO ()+diff_cmd opts args = withRepository opts $- \repository -> do+  when (not (null [i | LastN i <- opts])+       && not (null [p | AfterPatch p <- opts])+       ) $+    fail ("using --patch and --last at the same time with the 'diff' command"+         ++ " doesn't make sense. Use --from-patch to create a diff from this"+         ++ " patch to the present, or use just '--patch' to view this specific"+         ++ " patch.")+  formerdir <- getCurrentDirectory+  path_list <- if null args+               then return []+               else map sp2fn `fmap` fixSubPaths opts args+  thename <- return $ takeFileName formerdir+  withTempDir ("old-"++thename) $ \odir -> do+    setCurrentDirectory formerdir+    withTempDir ("new-"++thename) $ \ndir -> do+    if first_match opts+       then withCurrentDirectory odir $+            get_partial_first_match repository opts path_list+       else if null path_list+            then createPristineDirectoryTree repository (toFilePath odir)+            else createPartialsPristineDirectoryTree repository path_list (toFilePath odir)+    if second_match opts+       then withCurrentDirectory ndir $+            get_partial_second_match repository opts path_list+       else do (_, s) <- slurp_recorded_and_unrecorded repository+               let ps = concatMap (get_path_list s . toFilePath) path_list+               if null path_list+                  then withCurrentDirectory ndir $ writeSlurpy s "."+                  else clonePaths formerdir (toFilePath ndir) ps+    thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $+                   case path_list of+                   [] -> rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)+                   fs -> vcat `fmap`+                         mapM (\f -> rundiff+                               (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f)+                               (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs+    morepatches <- read_repo repository+    putDoc $ changelog (get_diff_info opts morepatches)+            $$ thediff+    where rundiff :: String -> String -> IO Doc+          rundiff f1 f2 = do+            cmd <- diff_program+            case get_diff_cmd_and_args cmd opts f1 f2 of+             Left err -> fail err+             Right (d_cmd, d_args) ->+              let other_diff = has_diff_cmd_flag opts in+              do when other_diff $ putStrLn $+                   "Running command '" ++ unwords (d_cmd:d_args) ++ "'"+                 output <- execPipeIgnoreError d_cmd d_args empty+                 when other_diff $ do+                    askUser "Hit return to move on..."+                    return ()+                 return output++get_diff_info :: RepoPatch p => [DarcsFlag] -> PatchSet p -> [PatchInfo]+get_diff_info opts ps =+    let pi1s = mapRL info $ concatRL $ if first_match opts+                                       then unsafeUnseal $ match_first_patchset opts ps+                                       else ps+        pi2s = mapRL info $ concatRL $ if second_match opts+                                       then unsafeUnseal $ match_second_patchset opts ps+                                       else ps+        in pi2s \\ pi1s++changelog :: [PatchInfo] -> Doc+changelog pis = vcat $ map human_friendly pis+\end{code}+
+ src/Darcs/Commands/Dist.lhs view
@@ -0,0 +1,156 @@+%  Copyright (C) 2003 David Roundy+%+%  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{dist}+\begin{code}+module Darcs.Commands.Dist ( dist ) where+import System.Directory ( setCurrentDirectory )+import Workaround ( getCurrentDirectory )+import System.Exit ( ExitCode(..), exitWith )+import System.Cmd ( system )+import System.FilePath.Posix ( takeFileName, (</>) )+import Data.Char ( isAlphaNum )+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,+                        command_description, command_extra_args,+                        command_extra_arg_help, command_command,+                        command_prereq, command_get_arg_possibilities,+                        command_argdefaults,+                        command_advanced_options, command_basic_options),+                        nodefaults )+import Darcs.Arguments ( DarcsFlag(Verbose, DistName), distname_option,+                         working_repo_dir, match_one, store_in_memory,+                         fixSubPaths )+import Darcs.Match ( get_nonrange_match, have_nonrange_match )+import Darcs.Repository ( amInRepository, withRepoReadLock, ($-), --withRecorded,+                          createPartialsPristineDirectoryTree )+import Darcs.Repository.Prefs ( get_prefval )+import Darcs.Lock ( withTemp, withTempDir, readBinFile )+import Darcs.RepoPath ( AbsolutePath, toFilePath )+import Darcs.Utils ( withCurrentDirectory )+import Exec ( exec, Redirect(..) )++dist_description :: String+dist_description = "Create a distribution tarball."++dist_help :: String+dist_help =+ "The `darcs dist' command creates a compressed archive (a `tarball') in\n" +++ "the repository's root directory, containing the recorded state of the\n" +++ "working tree (unrecorded changes and the _darcs directory are\n" +++ "excluded).\n" +++ "\n" +++ "If a predist command is set (see `darcs setpref'), that command will\n" +++ "be run on the tarball contents prior to archiving.  For example,\n" +++ "autotools projects would set it to `autoconf && automake'.\n" +++ "\n" +++ "By default, the tarball (and the top-level directory within the\n" +++ "tarball) has the same name as the repository, but this can be\n" +++ "overridden with the --dist-name option.\n"++ -- FIXME: this is tedious and ugly.+ {-+ ++ "\n" +++ "Suppose you use a version numbering scheme `major.minor.patch', and\n" +++ "you tag each release `major.minor'.  You can then calculate the\n" +++ "version number by taking the newest tag and appending a dot and the\n" +++ "number of patches since that tag.  If you use the directory name as\n" +++ "the project name, you can make tarballs of the form name-version.tgz\n" +++ "using the following shell script:\n" +++ "\n" +++ "  major_minor=$(darcs show tags | head -1) &&\n" +++ "  patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" +++ "  version=$major_minor.$patch_level &&\n" +++ "  project=${PWD##*/} &&\n" +++ "  darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n"+ -}++dist :: DarcsCommand+dist = DarcsCommand {command_name = "dist",+                     command_help = dist_help,+                     command_description = dist_description,+                     command_extra_args = 0,+                     command_extra_arg_help = [],+                     command_command = dist_cmd,+                     command_prereq = amInRepository,+                     command_get_arg_possibilities = return [],+                     command_argdefaults = nodefaults,+                     command_advanced_options = [],+                     command_basic_options = [distname_option,+                                              working_repo_dir,+                                              match_one,+                                              store_in_memory]}++dist_cmd :: [DarcsFlag] -> [String] -> IO ()+dist_cmd opts args = withRepoReadLock opts $- \repository -> do+  distname <- get_dist_name opts+  verb <- return $ Verbose `elem` opts+  predist <- get_prefval "predist"+  formerdir <- getCurrentDirectory+  path_list <- if null args+               then return [""]+               else map toFilePath `fmap` fixSubPaths opts args+  resultfile <- return (formerdir</>distname++".tar.gz")+  withTemp $ \tarfile ->+    withTempDir "darcsdist" $ \tempdir -> do+      setCurrentDirectory (formerdir)+      withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do+        if have_nonrange_match opts+          then withCurrentDirectory ddir $ get_nonrange_match repository opts+          else createPartialsPristineDirectoryTree repository path_list (toFilePath ddir)+        ec <- case predist of Nothing -> return ExitSuccess+                              Just pd -> system pd+        if (ec == ExitSuccess) then do_dist verb tarfile tempdir ddir resultfile+            else+                do+                putStrLn "Dist aborted due to predist failure"+                exitWith ec++-- | This function performs the actual distribution action itself.+-- NB - it does /not/ perform the pre-dist, that should already+-- have completed successfully before this is invoked.+do_dist :: Bool -> FilePath -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()+do_dist verb tarfile tempdir ddir resultfile = do+  setCurrentDirectory (toFilePath tempdir)+  exec "tar" ["-cf", "-", safename $ takeFileName $ toFilePath ddir]+             (Null, File tarfile, AsIs)+  when verb $ withTemp $ \tar_listing -> do+                exec "tar" ["-tf", "-"]+                     (File tarfile, File tar_listing, Stdout)+                to <- readBinFile tar_listing+                putStr to+  exec "gzip" ["-c"]+       (File tarfile, File resultfile, AsIs)+  putStrLn $ "Created dist as "++resultfile+  where+    safename n@(c:_) | isAlphaNum c  = n+    safename n = "./" ++ n++guess_repo_name :: IO String+guess_repo_name = do+  pwd <- getCurrentDirectory+  if '/' `elem` pwd+     then return $ reverse $ takeWhile (/='/') $ reverse pwd+     else return "cantguessreponame"++get_dist_name :: [DarcsFlag] -> IO String+get_dist_name (DistName dn:_) = return dn+get_dist_name (_:fs) = get_dist_name fs+get_dist_name _ = guess_repo_name+\end{code}+
+ src/Darcs/Commands/GZCRCs.lhs view
@@ -0,0 +1,180 @@+%  Copyright (C) 2009 Ganesh Sittampalam+%+%  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.++\subsection{darcs gzcrcs}+\darcsCommand{gzcrcs}+\begin{code}+module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where++import Control.Arrow ( (***) )+import Control.Monad ( when )+import Control.Monad.Trans ( liftIO )+import Control.Monad.Writer ( runWriter, runWriterT, tell )+import Data.List ( intersperse )+import Data.Monoid ( Any(..), Sum(..) )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist )+import System.Exit ( ExitCode(..), exitWith )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair ),+                        check_or_repair, working_repo_dir,+                      )+import Darcs.Repository ( Repository, amInRepository, withRepository )+import Darcs.Patch ( RepoPatch )+import Printer ( putDocLn, text )+import ByteStringUtils ( isGZFile )+import Darcs.Lock ( gzWriteAtomicFilePSs )++-- This command needs access beyond the normal repository APIs (to+-- get at the caches and inspect them directly)+-- Could move the relevant code into Darcs.Repository modules+-- but it doesn't really seem worth it.+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.Cache ( Cache(..), writable, hashedFilePath, allHashedDirs )+++#ifdef HAVE_HASKELL_ZLIB+import Darcs.Global ( getCRCWarnings, resetCRCWarnings )+import ByteStringUtils ( gzDecompress )+#else+-- These functions aren't available unless we have the Haskell zlib.+-- The gzcrcs command shouldn't be enabled in this case, but we would+-- still like to typecheck this module as much as possible so we include+-- dummy versions +noChecking :: String -> a+noChecking what = error $ "Darcs.Commands.GZCRCs." ++ what ++ ": gz CRC checking is not possible unless " +++                          "darcs has been built with the Haskell zlib. This code should be unreachable."+getCRCWarnings :: IO [FilePath]+getCRCWarnings = noChecking "getCRCWarnings"+resetCRCWarnings :: IO ()+resetCRCWarnings = noChecking "resetCRCWarnings"+gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString]+gzDecompress = noChecking "gzDecompress"+#endif++gzcrcs_description :: String+gzcrcs_description = "Check or repair the CRCs of compressed files in the repository."++gzcrcs_help :: String+gzcrcs_help = formatText+  [+   "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " +++   "with bad CRCs (but valid data) to be written out. CRCs were not checked on " +++   "reading, so this bug wasn't noticed.",+   "This command inspects your repository and caches for this corruption and optionally " +++   "repairs it.",+   "You may wish to also run 'darcs check --complete' before repairing the corruption. " +++   "This is not done automatically because it might result in needing to fetch extra " +++   "patches if the repository is lazy.",+   "If there are any other problems with your repository, you can still repair the CRCs, " +++   "but you are advised to first make a backup copy in case the CRC errors are actually " +++   "caused by bad data and the old CRCs might be useful in recovering that data.",+   "If you were warned about CRC errors during an operation involving another repository, " +++   "then it is possible that the other repository contains the corrupt CRCs, so you " +++   "should arrange for that repository to also be checked/repaired.",+   "Note that readonly caches, or other repositories that were sources for lazy gets, " +++   "will be checked but not repaired. Also, this command will abort if it encounters " +++   "any non-CRC corruption in compressed files."+  ]++formatText :: [String] -> String+formatText = unlines . concat . intersperse [""] . map (map unwords . para 80 . words)++-- |Take a list of words and split it up so that each chunk fits into the specified width+-- when spaces are included. Any words longer than the specified width end up in a chunk+-- of their own.+para :: Int -> [[a]] -> [[[a]]]+para w = para'+  where para' [] = []+        para' xs = uncurry (:) $ para'' w xs+        para'' r (x:xs) | w == r || length x < r = ((x:) *** id) $ para'' (r - length x - 1) xs+        para'' _ xs = ([], para' xs)++-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand+doCRCWarnings :: Bool -> IO ()+doCRCWarnings verbose = do+   files <- getCRCWarnings+   resetCRCWarnings+   when (not . null $ files) $ do+      putStr . formatText $+          ["",+           "Warning: CRC errors found. These are probably harmless but should " +++           "be repaired. See 'darcs gzcrcs --help' for more information.",+           ""]+      when verbose $ putStrLn $ unlines ("The following corrupt files were found:":files)++gzcrcs :: DarcsCommand+gzcrcs = DarcsCommand {command_name = "gzcrcs",+                       command_help = gzcrcs_help,+                       command_description = gzcrcs_description,+                       command_extra_args = 0,+                       command_extra_arg_help = [],+                       command_command = gzcrcs_cmd,+                       command_prereq = amInRepository,+                       command_get_arg_possibilities = return [],+                       command_argdefaults = nodefaults,+                       command_advanced_options = [],+                       command_basic_options = [check_or_repair,+                                                working_repo_dir+                                               ]}++gzcrcs_cmd :: [DarcsFlag] -> [String] -> IO ()+gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts)+gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs"++gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()+gzcrcs' opts repo = do+  let Ca locs = extractCache repo+  ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do+     let w = writable loc+     flip mapM_ allHashedDirs $ \hdir -> do+        let dir = hashedFilePath loc hdir ""+        exists <- liftIO $ doesDirectoryExist dir+        when exists $ do+           liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")+           files <- liftIO $ getDirectoryContents dir+           ((), Sum (count :: Int)) <- runWriterT $ flip mapM_ files $ \file -> do+              let fn = dir ++ file+              isfile <- liftIO $ doesFileExist fn+              when isfile $ do+                 gz <- liftIO $ isGZFile fn+                 case gz of+                    Nothing -> return ()+                    Just len -> do+                       contents <- liftIO $ B.readFile fn+                       let (uncompressed, Any isCorrupt)+                             = runWriter . gzDecompress (tell (Any True)) (Just len) . BL.fromChunks $ [contents]+                       when isCorrupt $ do+                          tell (Sum 1) -- count of files in current directory+                          liftIO $ putVerbose $ text $ "Corrupt: " ++ fn+                          when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed+           when (count > 0) $ do+              liftIO $ putInfo $ text $+                 "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") +++                 (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")+              tell (Any True) -- something corrupt somewhere+  when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1++ where+     putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s+     putVerbose s = when (Verbose `elem` opts) $ putDocLn s++\end{code}
+ src/Darcs/Commands/Get.lhs view
@@ -0,0 +1,347 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{get}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Get ( get, clone ) where++import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,+                          createDirectory )+import Workaround ( getCurrentDirectory )+import Data.Maybe ( isJust )+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy,+                                    UseFormat2, UseOldFashionedInventory, UseHashedInventory,+                                    SetScriptsExecutable, Quiet, OnePattern ),+                        get_context, get_inventory_choices,+                        partial, reponame,+                        match_one_context, set_default, set_scripts_executable, nolinks,+                        network_options )+import Darcs.Repository ( Repository, withRepository, ($-), withRepoLock, identifyRepositoryFor, read_repo,+                          createPristineDirectoryTree,+                          tentativelyRemovePatches, patchSetToPatches, patchSetToRepository,+                          copyRepository, tentativelyAddToPending,+                          finalizeRepositoryChanges, sync_repo, setScriptsExecutable )+import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,+                                 RepoProperty ( Darcs2, HashedInventory ), format_has )+import Darcs.Repository.DarcsRepo ( write_inventory )+import qualified Darcs.Repository.DarcsRepo as DR ( read_repo )+import Darcs.Repository ( PatchSet, SealedPatchSet, copy_oldrepo_patches,+                        createRepository)+import Darcs.Repository.ApplyPatches ( apply_patches )+import Darcs.Repository.Checkpoint ( write_checkpoint_patch, get_checkpoint )+import Darcs.Patch ( RepoPatch, Patch, apply, patch2patchinfo, invert,+                     effect, description )+import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeUnRL, mapRL, concatRL, reverseRL, lengthFL )+import Darcs.External ( copyFileOrUrl, Cachable(..) )+import Darcs.Patch.Depends ( get_common_and_uncommon, get_patches_beyond_tag )+import Darcs.Repository.Prefs ( set_defaultrepo )+import Darcs.Repository.Motd ( show_motd )+import Darcs.Repository.Pristine ( identifyPristine, createPristineFromWorking, )+import Darcs.SignalHandler ( catchInterrupt )+import Darcs.Commands.Init ( initialize )+import Darcs.Match ( have_patchset_match, get_one_patchset )+import Darcs.Utils ( catchall, formatPath, withCurrentDirectory, prettyError )+import Progress ( debugMessage )+import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, )+import Darcs.Lock ( writeBinFile )+import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)+import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )+import Darcs.Global ( darcsdir )+import English ( englishNum, Noun(..) )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++get_description :: String+get_description = "Create a local copy of a repository."++get_help :: String+get_help =+ "Get creates a local copy of a repository.  The optional second\n" +++ "argument specifies a destination directory for the new copy; if\n" +++ "omitted, it is inferred from the source location.\n" +++ "\n" +++ "By default Darcs will copy every patch from the original repository.\n" +++ "This means the copy is completely independent of the original; you can\n" +++ "operate on the new repository even when the original is inaccessible.\n" +++ "If you expect the original repository to remain accessible, you can\n" +++ "use --lazy to avoid copying patches until they are needed (`copy on\n" +++ "demand').  This is particularly useful when copying a remote\n" +++ "repository with a long history that you don't care about.\n" +++ "\n" +++ "The --lazy option isn't as useful for local copies, because Darcs will\n" +++ "automatically use `hard linking' where possible.  As well as saving\n" +++ "time and space, you can move or delete the original repository without\n" +++ "affecting a complete, hard-linked copy.  Hard linking requires that\n" +++ "the copy be on the same filesystem and the original repository, and\n" +++ "that the filesystem support hard linking.  This includes NTFS, HFS+\n" +++ "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" +++ "FAT does not support hard links.\n" +++ "\n" +++ "Darcs get will not copy unrecorded changes to the source repository's\n" +++ "working tree.\n" +++ "\n" +++ get_help_tag +++ "\n" +++ -- The remaining help text covers backwards-compatibility options.+ get_help_partial +++ "\n" +++ "A repository created by `darcs get' will be in the best available\n" +++ "format: it will be able to exchange patches with the source\n" +++ "repository, but will not be directly readable by Darcs binaries older\n" +++ "than 2.0.0.  Use the `--old-fashioned-inventory' option if the latter\n" +++ "is required.\n"++get :: DarcsCommand+get = DarcsCommand {command_name = "get",+                    command_help = get_help,+                    command_description = get_description,+                    command_extra_args = -1,+                    command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],+                    command_command = get_cmd,+                    command_prereq = contextExists,+                    command_get_arg_possibilities = return [],+                    command_argdefaults = nodefaults,+                    command_advanced_options = network_options +++                                               command_advanced_options initialize,+                    command_basic_options = [reponame,+                                            partial,+                                            match_one_context,+                                            set_default,+                                            set_scripts_executable,+                                             nolinks,+                                             get_inventory_choices]}++clone :: DarcsCommand+clone = command_alias "clone" get++get_cmd :: [DarcsFlag] -> [String] -> IO ()+get_cmd opts [inrepodir, outname] = get_cmd (NewRepo outname:opts) [inrepodir]+get_cmd opts [inrepodir] = do+  debugMessage "Starting work on get..."+  typed_repodir <- ioAbsoluteOrRemote inrepodir+  let repodir = toPath typed_repodir+  show_motd opts repodir+  when (Partial `elem` opts) $ debugMessage "Reading checkpoint..."+  rfsource_or_e <- identifyRepoFormat repodir+  rfsource <- case rfsource_or_e of Left e -> fail e+                                    Right x -> return x+  debugMessage $ "Found the format of "++repodir++"..."+  mysimplename <- make_repo_name opts repodir+  createDirectory mysimplename+  setCurrentDirectory mysimplename+  when (format_has Darcs2 rfsource && UseOldFashionedInventory `elem` opts) $+    putInfo $ text "Warning: 'old-fashioned-inventory' is ignored with a darcs-2 repository\n"+  let opts' = if format_has Darcs2 rfsource+              then UseFormat2:opts+              else if not (UseOldFashionedInventory `elem` opts)+                   then UseHashedInventory:filter (/= UseFormat2) opts+                   else UseOldFashionedInventory:filter (/= UseFormat2) opts+  createRepository opts'+  debugMessage "Finished initializing new directory."+  set_defaultrepo repodir opts++  rf_or_e <- identifyRepoFormat "."+  rf <- case rf_or_e of Left e -> fail e+                        Right x -> return x+  if format_has HashedInventory rf -- refactor this into repository+    then writeBinFile (darcsdir++"/hashed_inventory") ""+    else write_inventory "." (NilRL:<:NilRL :: PatchSet Patch)++  if not (null [p | OnePattern p <- opts]) -- --to-match given+     && not (Partial `elem` opts) && not (Lazy `elem` opts)+    then withRepository opts $- \repository -> do+      debugMessage "Using economical get --to-match handling"+      fromrepo <- identifyRepositoryFor  repository repodir+      Sealed patches_to_get <- get_one_patchset fromrepo opts+      patchSetToRepository fromrepo patches_to_get opts+      debugMessage "Finished converting selected patch set to new repository"+    else copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo+        where am_informative = not $ Quiet `elem` opts+              putInfo s = when am_informative $ putDocLn s++get_cmd _ _ = fail "You must provide 'get' with either one or two arguments."++-- | called by get_cmd+-- assumes that the target repo of the get is the current directory, and that an inventory in the+-- right format has already been created.+copy_repo_and_go_to_chosen_version :: [DarcsFlag] -> String -> RepoFormat -> RepoFormat -> (Doc -> IO ()) -> IO ()+copy_repo_and_go_to_chosen_version opts repodir rfsource rf putInfo = do+  copy_repo `catchInterrupt` (putInfo $ text "Using lazy repository.")+  withRepository opts $- \repository -> go_to_chosen_version repository putInfo opts+  putInfo $ text "Finished getting."+      where copy_repo =+                withRepository opts $- \repository -> do+                  if format_has HashedInventory rf || format_has HashedInventory rfsource+                     then do debugMessage "Identifying and copying repository..."+                             identifyRepositoryFor repository repodir >>= copyRepository+                             when (SetScriptsExecutable `elem` opts) setScriptsExecutable+                     else copy_repo_old_fashioned repository opts repodir++make_repo_name :: [DarcsFlag] -> FilePath -> IO String+make_repo_name (NewRepo n:_) _ =+    do exists <- doesDirectoryExist n+       file_exists <- doesFileExist n+       if exists || file_exists+          then fail $ "Directory or file named '" ++ n ++ "' already exists."+          else return n+make_repo_name (_:as) d = make_repo_name as d+make_repo_name [] d =+  case dropWhile (=='.') $ reverse $+       takeWhile (\c -> c /= '/' && c /= ':') $+       dropWhile (=='/') $ reverse d of+  "" -> modify_repo_name "anonymous_repo"+  base -> modify_repo_name base++modify_repo_name :: String -> IO String+modify_repo_name name =+    if head name == '/'+    then mrn name (-1)+    else do cwd <- getCurrentDirectory+            mrn (cwd ++ "/" ++ name) (-1)+ where+  mrn :: String -> Int -> IO String+  mrn n i = do+    exists <- doesDirectoryExist thename+    file_exists <- doesFileExist thename+    if not exists && not file_exists+       then do when (i /= -1) $+                    putStrLn $ "Directory '"++ n +++                               "' already exists, creating repository as '"+++                               thename ++"'"+               return thename+       else mrn n $ i+1+    where thename = if i == -1 then n else n++"_"++show i++get_help_tag :: String+get_help_tag =+ "It is often desirable to make a copy of a repository that excludes\n" +++ "some patches.  For example, if releases are tagged then `darcs get\n" +++ "--tag .' would make a copy of the repository as at the latest release.\n" +++ "\n" +++ "An untagged repository state can still be identified unambiguously by\n" +++ "a context file, as generated by `darcs changes --context'.  Given the\n" +++ "name of such a file, the --context option will create a repository\n" +++ "that includes only the patches from that context.  When a user reports\n" +++ "a bug in an unreleased version of your project, the recommended way to\n" +++ "find out exactly what version they were running is to have them\n" +++ "include a context file in the bug report.\n" +++ "\n" +++ "You can also make a copy of an untagged state using the --to-patch or\n" +++ "--to-match options, which exclude patches `after' the first matching\n" +++ "patch.  Because these options treat the set of patches as an ordered\n" +++ "sequence, you may get different results after reordering with `darcs\n" +++ "optimize', so tagging is preferred.\n"++contextExists :: [DarcsFlag] -> IO (Either String ())+contextExists opts =+   case get_context opts of+     Nothing -> return $ Right ()+     Just f  -> do exists <- doesFileExist $ toFilePath f+                   if exists+                      then return $ Right ()+                      else return . Left $ "Context file "++toFilePath f++" does not exist"++go_to_chosen_version :: RepoPatch p => Repository p -> (Doc -> IO ())+                     -> [DarcsFlag] -> IO ()+go_to_chosen_version repository putInfo opts =+    when (have_patchset_match opts) $ do+       debugMessage "Going to specified version..."+       patches <- read_repo repository+       Sealed context <- get_one_patchset repository opts+       let (_,us':\/:them') = get_common_and_uncommon (patches, context)+       case them' of+           NilRL:<:NilRL -> return ()+           _ -> errorDoc $ text "Missing these patches from context:"+                        $$ (vcat $ mapRL description $ head $ unsafeUnRL them')+       let ps = patchSetToPatches us'+       putInfo $ text $ "Unapplying " ++ (show $ lengthFL ps) ++ " " +++                   (englishNum (lengthFL ps) (Noun "patch") "")+       invalidateIndex repository+       withRepoLock opts $- \_ ->+           do tentativelyRemovePatches repository opts ps+              tentativelyAddToPending repository opts $ invert $ effect ps+              finalizeRepositoryChanges repository+              apply opts (invert $ effect ps) `catch` \e ->+                  fail ("Couldn't undo patch in working dir.\n" ++ show e)+              sync_repo repository+++get_help_partial :: String+get_help_partial =+ "If the source repository is in a legacy darcs-1 format and contains at\n" +++ "least one checkpoint (see `darcs optimize'), the --partial option will\n" +++ "create a partial repository.  A partial repository discards history\n" +++ "from before the checkpoint in order to reduce resource requirements.\n" +++ "For modern darcs-2 repositories, --partial is a deprecated alias for\n" +++ "the --lazy option.\n"++copy_repo_old_fashioned :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> IO ()+copy_repo_old_fashioned repository opts repodir = do+  myname <- getCurrentDirectory+  fromrepo <- identifyRepositoryFor repository repodir+  mch <- get_checkpoint fromrepo+  patches <- read_repo fromrepo+  debugMessage "Getting the inventory..."+  write_inventory "." patches+  debugMessage "Copying patches..."+  copy_oldrepo_patches opts fromrepo "."+  debugMessage "Patches copied"+  Sealed local_patches <- DR.read_repo opts "." :: IO (SealedPatchSet Patch)+  debugMessage "Repo read"+  repo_is_local <- doesDirectoryExist repodir+  debugMessage $ "Repo local: " ++ formatPath (show repo_is_local)+  if repo_is_local && not (Partial `elem` opts)+     then do+       debugMessage "Copying prefs"+       copyFileOrUrl opts+          (repodir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)+          `catchall` return ()+       debugMessage "Writing working directory"+       createPristineDirectoryTree fromrepo myname+       withCurrentDirectory myname $ do+           -- note: SetScriptsExecutable is normally checked in PatchApply+           -- but darcs get on local repositories does not apply patches+           if SetScriptsExecutable `elem` opts+              then setScriptsExecutable+              else return ()+     else do+       setCurrentDirectory myname+       if Partial `elem` opts && isJust mch+          then let Sealed p_ch = fromJust mch+                   pi_ch = patch2patchinfo p_ch+                   needed_patches = reverseRL $ concatRL $ unsafeUnflippedseal $+                                    get_patches_beyond_tag pi_ch local_patches+                   in do write_checkpoint_patch p_ch+                         apply opts p_ch `catch`+                             \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e)+                         apply_patches opts needed_patches+          else apply_patches opts $ reverseRL $ concatRL local_patches+  debugMessage "Writing the pristine"+  pristine <- identifyPristine+  createPristineFromWorking pristine+  setCurrentDirectory myname+  debugMessage "Syncing the repository..."+  sync_repo repository+  debugMessage "Repository synced."++\end{code}
+ src/Darcs/Commands/Help.lhs view
@@ -0,0 +1,266 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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 Darcs.Commands.Help (+ help_cmd,+ command_control_list, environmentHelp,          -- these are for preproc.hs+ print_version,+ list_available_commands ) where++import Darcs.Arguments ( DarcsFlag(..), environmentHelpSendmail )+import Darcs.Commands (+ CommandArgs(..), CommandControl(..), DarcsCommand(..),+ disambiguate_commands, extract_commands, get_command_help, nodefaults, usage )+import Darcs.External ( viewDoc )+import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir )+import Darcs.Patch.Match ( helpOnMatchers )+import Darcs.Repository.Prefs ( binaries_file_help, 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 ThisVersion ( darcs_version )+import URL (environmentHelpProxy, environmentHelpProxyPassword)+import Workaround ( getCurrentDirectory )+import qualified Darcs.TheCommands as TheCommands++help_description :: String+help_description = "Display help about darcs and darcs commands."++help_help :: String+help_help =+ "Without arguments, `darcs help' prints a categorized list of darcs\n" +++ "commands and a short description of each one.  With an extra argument,\n" +++ "`darcs help foo' prints detailed help about the darcs command foo.\n"++help :: DarcsCommand+help = DarcsCommand {command_name = "help",+                     command_help = help_help,+                     command_description = help_description,+                     command_extra_args = -1,+                     command_extra_arg_help = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "],+                     command_command = \ x y -> help_cmd x y >> exitWith ExitSuccess,+                     command_prereq = \_ -> return $ Right (),+                     command_get_arg_possibilities = return [],+                     command_argdefaults = nodefaults,+                     command_advanced_options = [],+                     command_basic_options = []}++help_cmd :: [DarcsFlag] -> [String] -> IO ()+help_cmd _ ["manpage"] = putStr $ unlines manpageLines+help_cmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers+help_cmd _ ["environment"] = viewDoc $ text $ helpOnEnvironment+help_cmd _ [] = viewDoc $ text $ usage command_control_list++help_cmd _ (cmd:args) =+    let disambiguated = disambiguate_commands command_control_list cmd args+    in case disambiguated of+         Left err -> fail err+         Right (cmds,_) ->+             let msg = case cmds of+                         CommandOnly c       -> get_command_help Nothing  c+                         SuperCommandOnly c  -> get_command_help Nothing  c+                         SuperCommandSub c s -> get_command_help (Just c) s+             in viewDoc $ text msg++list_available_commands :: IO ()+list_available_commands =+    do here <- getCurrentDirectory+       is_valid <- sequence $ map+                   (\c-> withCurrentDirectory here $ (command_prereq c) [])+                   (extract_commands command_control_list)+       putStr $ unlines $ map (command_name . fst) $+                filter (isRight.snd) $+                zip (extract_commands command_control_list) is_valid+       putStrLn "--help"+       putStrLn "--version"+       putStrLn "--exact-version"+       putStrLn "--overview"+    where isRight (Right _) = True+          isRight _ = False++print_version :: IO () +print_version = putStrLn $ "darcs version " ++ darcs_version++-- avoiding a module import cycle between Help and TheCommands+command_control_list :: [CommandControl] +command_control_list =+  Command_data help : TheCommands.command_control_list++-- | Help on each environment variable in which Darcs is interested.+environmentHelp :: [([String], [String])]+environmentHelp = [+ -- General-purpose+ environmentHelpHome,+ environmentHelpEditor,+ environmentHelpPager,+ environmentHelpTmpdir,+ environmentHelpKeepTmpdir,+ 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 darcs "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 \"" ++ darcs_version ++ "\"",+ ".SH NAME",+ "darcs \\- an advanced revision control system",+ ".SH SYNOPSIS",+ ".B darcs", ".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 darcs.cabal, so+ -- it'll get out of date as people forget to maintain+ -- both in sync.+ "Darcs 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-committers.",+ ".TP", "\\(bu",+ "Interactive: Darcs 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: Originally developed by physicist David",+ "Roundy, darcs is based on a unique algebra of",+ "patches.",+ "This smartness lets you respond to changing demands",+ "in ways that would otherwise not be possible. Learn",+ "more about spontaneous branches with darcs.",+ ".SH OPTIONS",+ "Different options are accepted by different Darcs 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 `darcs", ".I command", "--help'.",+ ".SS " ++ helpOnMatchers, -- FIXME: this is a kludge.+ ".SH COMMANDS",+ unlines commands,+ unlines environment,+ ".SH FILES",+ ".SS \"_darcs/prefs/binaries\"",+ unlines binaries_file_help,+ ".SH BUGS",+ "At http://bugs.darcs.net/ you can find a list of known",+ "bugs in Darcs.  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 Darcs, 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 [] command_control_list+          where iter :: [String] -> CommandControl -> [String]+                iter acc (Group_name _) = acc+                iter acc (Hidden_command _) = acc+                iter acc (Command_data c@SuperCommand {}) =+                    acc ++ concatMap+                            (render (command_name c ++ " "))+                            (extract_commands (command_sub_commands c))+                iter acc (Command_data c) = acc ++ render "" c+                render :: String -> DarcsCommand -> [String]+                render prefix c =+                    [".B darcs " ++ prefix ++ command_name c] +++                    (map mangle_args $ command_extra_arg_help 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 [] command_control_list+          where iter :: [String] -> CommandControl -> [String]+                iter acc (Group_name x) = acc ++ [".SS \"" ++ x ++ "\""]+                iter acc (Hidden_command _) = acc+                iter acc (Command_data c@SuperCommand {}) =+                    acc ++ concatMap+                            (render (command_name c ++ " "))+                            (extract_commands (command_sub_commands c))+                iter acc (Command_data c) = acc ++ render "" c+                render :: String -> DarcsCommand -> [String]+                render prefix c =+                    [".B darcs " ++ prefix ++ command_name c] +++                    (map mangle_args $ command_extra_arg_help c) +++                    [".RS 4", command_help 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 ++ "\"") : ds+                     | (ks, ds) <- environmentHelp]++\end{code}
+ src/Darcs/Commands/Init.lhs view
@@ -0,0 +1,89 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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{initialize}+\begin{code}+module Darcs.Commands.Init ( initialize, initialize_cmd ) where+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, working_repo_dir,+                        inventory_choices )+import Darcs.Repository ( amNotInRepository, createRepository )++initialize_description :: String+initialize_description = "Make the current directory a repository."++initialize_help :: String+initialize_help =+ "The `darcs initialize' command turns the current directory into a\n" +++ "Darcs repository.  Any existing files and subdirectories become\n" +++ "UNSAVED changes in the working tree: record them with `darcs add -r'\n" +++ "and `darcs record'.\n" +++ "\n" +++ -- FIXME: confirm my assertion re conversion is true. --twb, 2008-12-14+ "When converting a project to Darcs from some other VCS, translating\n" +++ "the full revision history to native Darcs patches is recommended.\n" +++ "(The Darcs wiki lists utilities for this.)  Because Darcs is optimized\n" +++ "for small patches, simply importing the latest revision as a single\n" +++ "large patch can PERMANENTLY degrade Darcs performance in your\n" +++ "repository by an order of magnitude.\n" +++ "\n" +++ "This command creates the `_darcs' directory, which stores version\n" +++ "control metadata.  It also contains per-repository settings in\n" +++ "_darcs/prefs/, which you can read about in the user manual.\n" +++ "\n" +++ "In addition to the default `darcs-2' format, there are two backward\n" +++ "compatibility formats for the _darcs directory.  These formats are\n" +++ "only useful if some of your contributors do not have access to Darcs\n" +++ "2.0 or higher.  In that case, you need to use the original format\n" +++ "(called `old-fashioned inventory' or `darcs-1') for any repositories\n" +++ "those contributors access.\n" +++ "\n" +++ "As patches cannot be shared between darcs-2 and darcs-1 repositories,\n" +++ "you cannot use the darcs-2 format for private branches of such a\n" +++ "project.  Instead, you should use the `hashed' format, which provides\n" +++ "most of the features of the darcs-2 format, while retaining the\n" +++ "ability to share patches with darcs-1 repositories.  The `darcs get'\n" +++ "command will do this by default.\n" +++ "\n" +++ "Once all contributors have access to Darcs 2.0 or higher, a darcs-1\n" +++ "project can be migrated to darcs-2 using the `darcs convert' command.\n" +++ "\n" +++ "Darcs will create a hashed repository by default when you `darcs get'\n" +++ "a repository in old-fashioned inventory format.  Once all contributors\n" +++ "have upgraded to Darcs 2.0 or later, use `darcs convert' to convert\n" +++ "the project to the darcs-2 format.\n" +++ "\n" +++ "Initialize is commonly abbreviated to `init'.\n"++initialize :: DarcsCommand+initialize = DarcsCommand {command_name = "initialize",+                         command_help = initialize_help,+                         command_description = initialize_description,+                         command_extra_args = 0,+                         command_extra_arg_help = [],+                         command_prereq = amNotInRepository,+                         command_command = initialize_cmd,+                         command_get_arg_possibilities = return [],+                         command_argdefaults = nodefaults,+                         command_advanced_options = [],+                         command_basic_options = [inventory_choices,+                                                  working_repo_dir]}++initialize_cmd :: [DarcsFlag] -> [String] -> IO ()+initialize_cmd opts _ = createRepository opts+\end{code}+
+ src/Darcs/Commands/MarkConflicts.lhs view
@@ -0,0 +1,106 @@+%  Copyright (C) 2002-2003,2005 David Roundy+%+%  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{mark-conflicts}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.MarkConflicts ( markconflicts, resolve ) where+import System.Exit ( ExitCode(..), exitWith )+import Darcs.SignalHandler ( withSignalsBlocked )+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Arguments ( DarcsFlag, ignoretimes, working_repo_dir, umask_option )+import Darcs.Repository ( withRepoLock, ($-), amInRepository, add_to_pending,+                    applyToWorking,+                    read_repo, sync_repo, get_unrecorded_unsorted,+                    )+import Darcs.Patch ( invert )+import Darcs.Ordered ( FL(..) )+import Darcs.Sealed ( Sealed(Sealed) )+import Darcs.Resolution ( patchset_conflict_resolutions )+import Darcs.Utils ( promptYorn )+#include "impossible.h"++markconflicts_description :: String+markconflicts_description =+ "Mark unresolved conflicts in working tree, for manual resolution."++markconflicts_help :: String+markconflicts_help =+ "Darcs requires human guidance to unify changes to the same part of a\n" +++ "source file.  When a conflict first occurs, darcs will add both\n" +++ "choices to the working tree, delimited by the markers `v v v',\n" +++ "`* * *' and `^ ^ ^'.\n" +++ "\n" +++ "However, you might revert or manually delete these markers without\n" +++ "actually resolving the conflict.  In this case, `darcs mark-conflicts'\n" +++ "is useful to show where any unresolved conflicts.  It is also useful\n" +++ "if `darcs apply' is called with --apply-conflicts, where conflicts\n" +++ "aren't marked initially.\n" +++ "\n" +++ "Any unrecorded changes to the working tree WILL be lost forever when\n" +++ "you run this command!  You will be prompted for confirmation before\n" +++ "this takes place.\n" +++ "\n" +++ "This command was historically called `resolve', and this deprecated\n" +++ "alias still exists for backwards-compatibility.\n"++markconflicts :: DarcsCommand+markconflicts = DarcsCommand {command_name = "mark-conflicts",+                              command_help = markconflicts_help,+                              command_description = markconflicts_description,+                              command_extra_args = 0,+                              command_extra_arg_help = [],+                              command_command = markconflicts_cmd,+                              command_prereq = amInRepository,+                              command_get_arg_possibilities = return [],+                              command_argdefaults = nodefaults,+                              command_advanced_options = [umask_option],+                              command_basic_options = [ignoretimes,+                                                      working_repo_dir]}++markconflicts_cmd :: [DarcsFlag] -> [String] -> IO ()+markconflicts_cmd opts [] = withRepoLock opts $- \repository -> do+  pend <- get_unrecorded_unsorted repository+  r <- read_repo repository+  Sealed res <- return $ patchset_conflict_resolutions r+  case res of NilFL -> do putStrLn "No conflicts to mark."+                          exitWith ExitSuccess+              _ -> return ()+  case pend of+    NilFL -> return ()+    _ ->      do yorn <- promptYorn+                         ("This will trash any unrecorded changes"+++                          " in the working directory.\nAre you sure? ")+                 when (yorn /= 'y') $ exitWith ExitSuccess+                 applyToWorking repository opts (invert pend) `catch` \e ->+                    bug ("Can't undo pending changes!" ++ show e)+                 sync_repo repository+  withSignalsBlocked $+    do add_to_pending repository res+       applyToWorking repository opts res `catch` \e ->+           bug ("Problem marking conflicts in mark-conflicts!" ++ show e)+  putStrLn "Finished marking conflicts."+markconflicts_cmd _ _ = impossible++-- |resolve is an alias for mark-conflicts.+resolve :: DarcsCommand+resolve = command_alias "resolve" markconflicts+\end{code}
+ src/Darcs/Commands/Move.lhs view
@@ -0,0 +1,186 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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{move}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Move ( move, mv ) where+import Control.Monad ( when, unless, zipWithM_ )+import Data.Maybe ( catMaybes )+import Darcs.SignalHandler ( withSignalsBlocked )++import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Arguments ( DarcsFlag( AllowCaseOnly, AllowWindowsReserved ),+                         fixSubPaths, working_repo_dir,+                        list_files, allow_problematic_filenames, umask_option,+                      )+import Darcs.RepoPath ( toFilePath, sp2fn )+import System.FilePath.Posix ( (</>), takeFileName )+import System.Directory ( renameDirectory )+import Workaround ( renameFile )+import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,+                    slurp_pending, add_to_pending,+                  )+import Darcs.Ordered ( FL(..), unsafeFL )+import Darcs.Global ( debugMessage )+import qualified Darcs.Patch+import Darcs.Patch ( RepoPatch, Prim )+import Darcs.SlurpDirectory ( Slurpy, slurp, slurp_has, slurp_has_anycase,+                        slurp_remove, slurp_hasdir, slurp_hasfile )+import Darcs.Patch.FileName ( fp2fn, fn2fp, super_name )+import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++move_description :: String+move_description = "Move or rename files."++move_help :: String+move_help =+ "Darcs cannot reliably distinguish between a file being deleted and a\n" +++ "new one added, and a file being moved.  Therefore Darcs always assumes\n" +++ "the former, and provides the `darcs mv' command to let Darcs know when\n" +++ "you want the latter.  This command will also move the file in the\n" +++ "working tree (unlike `darcs remove').\n" +++ "\n" +++ -- Note that this paragraph is very similar to one in ./Add.lhs.+ "Darcs will not rename a file if another file in the same folder has\n" +++ "the same name, except for case.  The --case-ok option overrides this\n" +++ "behaviour.  Windows and OS X usually use filesystems that do not allow\n" +++ "files a folder to have the same name except for case (for example,\n" +++ "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" +++ "unusable on those systems!\n"++move :: DarcsCommand+move = DarcsCommand {command_name = "move",+                   command_help = move_help,+                   command_description = move_description,+                   command_extra_args = -1,+                   command_extra_arg_help = ["<SOURCE> ... <DESTINATION>"],+                   command_command = move_cmd,+                   command_prereq = amInRepository,+                   command_get_arg_possibilities = list_files,+                   command_argdefaults = nodefaults,+                   command_advanced_options = [umask_option],+                   command_basic_options = [allow_problematic_filenames, working_repo_dir]}+move_cmd :: [DarcsFlag] -> [String] -> IO ()+move_cmd _ [] = fail "The `darcs move' command requires at least two arguments."+move_cmd _ [_] = fail "The `darcs move' command requires at least two arguments."++move_cmd opts args@[_,_] = withRepoLock opts $- \repository -> do+  two_files <- fixSubPaths opts args+  [old,new] <- return $ case two_files of+                        [_,_] -> two_files+                        [_] -> error "Cannot rename a file or directory onto itself!"+                        xs -> bug $ "Problem in move_cmd: " ++ show xs+  work <- slurp "."+  let old_fp = toFilePath old+      new_fp = toFilePath new+  if slurp_hasdir (sp2fn new) work && slurp_has old_fp work+   then move_to_dir repository opts [old_fp] new_fp+   else do+    cur <- slurp_pending repository+    addpatch <- check_new_and_old_filenames opts cur work (old_fp,new_fp)+    invalidateIndex repository+    withSignalsBlocked $ do+      case addpatch of+        Nothing -> add_to_pending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)+        Just p -> add_to_pending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)+      move_file_or_dir work old_fp new_fp++move_cmd opts args =+   withRepoLock opts $- \repository -> do+     relpaths <- map toFilePath `fmap` fixSubPaths opts args+     let moved = init relpaths+         finaldir = last relpaths+     move_to_dir repository opts moved finaldir++move_to_dir :: RepoPatch p => Repository p -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()+move_to_dir repository opts moved finaldir =+  let movefns = map takeFileName moved+      movetargets = map (finaldir </>) movefns+      movepatches = zipWith Darcs.Patch.move moved movetargets+  in do+    cur <- slurp_pending repository+    work <- slurp "."+    addpatches <- mapM (check_new_and_old_filenames opts cur work) $ zip moved movetargets+    invalidateIndex repository+    withSignalsBlocked $ do+      add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches+      zipWithM_ (move_file_or_dir work) moved movetargets++check_new_and_old_filenames+    :: [DarcsFlag] -> Slurpy -> Slurpy -> (FilePath, FilePath) -> IO (Maybe Prim)+check_new_and_old_filenames opts cur work (old,new) = do+  unless (AllowWindowsReserved `elem` opts || WindowsFilePath.isValid new) $+     fail $ "The filename " ++ new ++ " is not valid under Windows.\n" +++            "Use --reserved-ok to allow such filenames."+  maybe_add_file_thats_been_moved <-+     if slurp_has old work -- We need to move the object+     then do unless (slurp_hasdir (super_name $ fp2fn new) work) $+                    fail $ "The target directory " +++                             (fn2fp $ super_name $ fp2fn new)+++                             " isn't known in working directory, did you forget to add it?"+             when (it_has new work) $ fail $ already_exists "working directory"+             return Nothing+     else do unless (slurp_has new work) $ fail $ doesnt_exist "working directory"+             return $ Just $ Darcs.Patch.addfile old+  if slurp_has old cur+     then do unless (slurp_hasdir (super_name $ fp2fn new) cur) $+                    fail $ "The target directory " +++                             (fn2fp $ super_name $ fp2fn new)+++                             " isn't known in working directory, did you forget to add it?"+             when (it_has new cur) $ fail $ already_exists "repository"+     else fail $ doesnt_exist "repository"+  return maybe_add_file_thats_been_moved+    where it_has f s = +            let ms2 = slurp_remove (fp2fn old) s+            in case ms2 of+               Nothing -> False+               Just s2 -> if AllowCaseOnly `elem` opts +                          then slurp_has f s2+                          else slurp_has_anycase f s2+          already_exists what_slurpy =+              if AllowCaseOnly `elem` opts+              then "A file or dir named "++new++" already exists in "+                       ++ what_slurpy ++ "."+              else "A file or dir named "++new++" (or perhaps differing"+++                       " only in case)\nalready exists in "+++                       what_slurpy ++ ".\n"+++                   "Use --case-ok to allow files differing only in case."+          doesnt_exist what_slurpy =+              "There is no file or dir named " ++ old +++              " in the "++ what_slurpy ++ "."++move_file_or_dir :: Slurpy -> FilePath -> FilePath -> IO ()+move_file_or_dir work old new =+    if slurp_hasfile (fp2fn old) work+       then do debugMessage $ unwords ["renameFile",old,new]+               renameFile old new+       else if slurp_hasdir (fp2fn old) work+            then do debugMessage $ unwords ["renameDirectory",old,new]+                    renameDirectory old new+            else return ()++mv :: DarcsCommand+mv = command_alias "mv" move+\end{code}++
+ src/Darcs/Commands/Optimize.lhs view
@@ -0,0 +1,314 @@+%  Copyright (C) 2003-2005 David Roundy+%+%  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{optimize}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Optimize ( optimize ) where+import Control.Monad ( when, unless )+import Data.Maybe ( isJust )+import Text.Regex ( mkRegex, matchRegex )+import System.Directory ( getDirectoryContents, doesDirectoryExist )++import Darcs.Hopefully ( hopefully, info )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Compress, UnCompress,+                                    NoCompress, Reorder,+                                    TagName, CheckPoint,+                                    Relink, RelinkPristine ),+                        tagname, checkpoint, reorder_patches,+                        uncompress_nocompress,+                        relink, relink_pristine, sibling,+                        flagsToSiblings,+                        working_repo_dir, umask_option,+                      )+import Darcs.Repository.Prefs ( get_preflist )+import Darcs.Repository ( Repository, PatchSet, withRepoLock, ($-), withGutsOf,+                          read_repo, optimizeInventory, slurp_recorded,+                          tentativelyReplacePatches, cleanRepository,+                          amInRepository, finalizeRepositoryChanges )+import Darcs.Repository.Checkpoint ( write_checkpoint )+import Darcs.Ordered ( RL(..), unsafeUnRL, (+<+), mapFL_FL, reverseRL, mapRL, concatRL )+import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly )+import Darcs.Patch ( RepoPatch )+import ByteStringUtils ( gzReadFilePS )+import Darcs.Patch.Depends ( deep_optimize_patchset, slightly_optimize_patchset,+                 get_patches_beyond_tag, get_patches_in_tag,+               )+import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS )+import Darcs.RepoPath ( toFilePath )+import Darcs.Utils ( withCurrentDirectory )+import Progress ( debugMessage )+import Printer ( putDocLn, text, ($$) )+import Darcs.SlurpDirectory ( slurp, list_slurpy_files )+import Darcs.Repository.Pristine ( identifyPristine, pristineDirectory )+import Darcs.Sealed ( FlippedSeal(..), unsafeUnseal )+import Darcs.Global ( darcsdir )+#include "impossible.h"++optimize_description :: String+optimize_description = "Optimize the repository."++optimize_help :: String+optimize_help =+ "The `darcs optimize' command modifies the current repository in an\n" +++ "attempt to reduce its resource requirements.  By default a single\n" +++ "fast, safe optimization is performed; additional optimization\n" +++ "techniques can be enabled by passing options to `darcs optimize'.\n" +++ "\n" ++ optimize_help_inventory +++ -- "\n" ++ optimize_help_reorder +++ "\n" ++ optimize_help_relink +++ -- checkpoints and uncompression are least useful, so they are last.+ "\n" ++ optimize_help_compression +++ "\n" ++ optimize_help_checkpoint +++ "\n" +++ "There is one more optimization which CAN NOT be performed by this\n" +++ "command.  Every time your record a patch, a new inventory file is\n" +++ "written to _darcs/inventories/, and old inventories are never reaped.\n" +++ "\n" +++ "If _darcs/inventories/ is consuming a relatively large amount of\n" +++ "space, you can safely reclaim it by using `darcs get' to make a\n" +++ "complete copy of the repo.  When doing so, don't forget to copy over\n" +++ "any unsaved changes you have made to the working tree or to\n" +++ "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n"++optimize :: DarcsCommand+optimize = DarcsCommand {command_name = "optimize",+                         command_help = optimize_help,+                         command_description = optimize_description,+                         command_extra_args = 0,+                         command_extra_arg_help = [],+                         command_command = optimize_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = return [],+                         command_argdefaults = nodefaults,+                         command_advanced_options = [uncompress_nocompress, umask_option],+                         command_basic_options = [checkpoint,+                                                 tagname,+                                                 working_repo_dir,+                                                 reorder_patches,+                                                 sibling, relink,+                                                 relink_pristine]}++optimize_cmd :: [DarcsFlag] -> [String] -> IO ()+optimize_cmd origopts _ = withRepoLock opts $- \repository -> do+    cleanRepository repository+    do_reorder opts repository+    do_optimize_inventory repository+    when (CheckPoint `elem` opts) $ do_checkpoint opts repository+    when (Compress `elem` opts || UnCompress `elem` opts) $ optimize_compression opts+    when (Relink `elem` opts || (RelinkPristine `elem` opts)) $+        do_relink opts repository+    putStrLn "Done optimizing!"+  where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts+is_tag :: PatchInfo -> Bool+is_tag pinfo = take 4 (just_name pinfo) == "TAG "++optimize_help_inventory :: String+optimize_help_inventory =+ "The default optimization moves recent patches (those not included in\n" +++ "the latest tag) to the `front', reducing the amount that a typical\n" +++ "remote command needs to download.  It should also reduce the CPU time\n" +++ "needed for some operations.\n"++do_optimize_inventory :: RepoPatch p => Repository p -> IO ()+do_optimize_inventory repository = do+    debugMessage "Writing out a nice copy of the inventory."+    optimizeInventory repository+    debugMessage "Done writing out a nice copy of the inventory."++optimize_help_checkpoint :: String+optimize_help_checkpoint =+ "If the repository is in `old-fashioned-inventory' format, the `darcs\n" +++ "optimize --checkpoint' command creates a checkpoint of the latest tag.\n" +++ "This checkpoint is used by `darcs get --partial' to create partial\n" +++ "repositories.  With the `--tag' option, checkpoints for older tags can\n" +++ "be created.  In newer repository formats, this feature has been\n" +++ "replaced by `darcs get --lazy', which does not require checkpoints.\n"++do_checkpoint :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+do_checkpoint opts repository = do+    mpi <- get_tag opts repository+    case mpi of+      Nothing -> return ()+      Just pinfo -> do putDocLn $ text "Checkpointing tag:"+                               $$ human_friendly pinfo+                       write_checkpoint repository pinfo++get_tag :: RepoPatch p => [DarcsFlag] -> Repository p -> IO (Maybe PatchInfo)+get_tag [] r = do ps <- read_repo r+                  case filter is_tag $ lasts $ mapRL (mapRL info) ps of+                      [] -> do putStrLn "There is no tag to checkpoint!"+                               return Nothing+                      (pinfo:_) -> return $ Just pinfo+get_tag (TagName t:_) r =+    do ps <- read_repo r+       case filter (match_tag t) $ lasts $ mapRL (mapRL info) ps of+         (pinfo:_) -> return $ Just pinfo+         _ -> case filter (match_tag t) $+                   lasts $ mapRL (mapRL info) $ deep_optimize_patchset ps of+              (pinfo:_) -> return $ Just pinfo+              _ -> do putStr "Cannot checkpoint any tag "+                      putStr $ "matching '"++t++"'\n"+                      return Nothing+get_tag (_:fs) r = get_tag fs r++lasts :: [[a]] -> [a]+lasts [] = []+lasts (x@(_:_):ls) = last x : lasts ls+lasts ([]:ls) = lasts ls++mymatch :: String -> PatchInfo -> Bool+mymatch r = match_name $ matchRegex (mkRegex r)+match_name :: (String -> Maybe a) -> PatchInfo -> Bool+match_name ch pinfo = isJust $ ch (just_name pinfo)+match_tag :: String -> PatchInfo -> Bool+match_tag ('^':n) = mymatch $ "^TAG "++n+match_tag n = mymatch $ "^TAG .*"++n+++optimize_help_compression :: String+optimize_help_compression =+ "By default patches are compressed with zlib (RFC 1951) to reduce\n" +++ "storage (and download) size.  In exceptional circumstances, it may be\n" +++ "preferable to avoid compression.  In this case the `--dont-compress'\n" +++ "option can be used (e.g. with `darcs record') to avoid compression.\n" +++ "\n" +++ "The `darcs optimize --uncompress' and `darcs optimize --compress'\n" +++ "commands can be used to ensure existing patches in the current\n" +++ "repository are respectively uncompressed or compressed.  Note that\n" +++ "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" +++ "extension on patch files even when uncompressed.\n"++optimize_compression :: [DarcsFlag] -> IO ()+optimize_compression opts = do+    putStrLn "Optimizing (un)compression of patches..."+    do_compress (darcsdir++"/patches")+    putStrLn "Optimizing (un)compression of inventories..."+    do_compress (darcsdir++"/inventories")+    where do_compress f =+              do isd <- doesDirectoryExist f+                 if isd then withCurrentDirectory f $+                             do fs <- filter notdot `fmap` getDirectoryContents "."+                                mapM_ do_compress fs+                        else if Compress `elem` opts+                             then gzReadFilePS f >>= gzWriteAtomicFilePS f+                             else gzReadFilePS f >>= writeAtomicFilePS f+          notdot ('.':_) = False+          notdot _ = True++optimize_help_relink :: String+optimize_help_relink =+ "The `darcs optimize --relink' command hard-links patches that the\n" +++ "current repository has in common with its peers.  Peers are those\n" +++ "repositories listed in _darcs/prefs/sources, or defined with the\n" +++ "`--sibling' option (which can be used multiple times).\n" +++ "\n" +++ "Darcs uses hard-links automatically, so this command is rarely needed.\n" +++ "It is most useful if you used `cp -r' instead of `darcs get' to copy a\n" +++ "repository, or if you pulled the same patch from a remote repository\n" +++ "into multiple local repositories.\n" +++ "\n" +++ "A `darcs optimize --relink-pristine' command is also available, but\n" +++ "generally SHOULD NOT be used.  It results in a relatively small space\n" +++ "saving at the cost of making many Darcs commands MUCH slower.\n"++do_relink :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+do_relink opts repository =+    do some_siblings <- return (flagsToSiblings opts)+       defrepolist <- get_preflist "defaultrepo"+       siblings <- return (map toFilePath some_siblings ++ defrepolist)+       if (siblings == []) +          then putStrLn "No siblings -- no relinking done."+          else do when (Relink `elem` opts) $+                      do debugMessage "Relinking patches..."+                         patches <-+                           (fmap list_slurpy_files) (slurp $ darcsdir++"/patches")+                         maybeRelinkFiles siblings patches (darcsdir++"/patches")+                  when (RelinkPristine `elem` opts) $+                      do pristine <- identifyPristine+                         case (pristineDirectory pristine) of+                             (Just d) -> do+                                 debugMessage "Relinking pristine tree..."+                                 c <- slurp_recorded repository+                                 maybeRelinkFiles+                                     siblings (list_slurpy_files c) d+                             Nothing -> return ()+                  debugMessage "Done relinking."+                  return ()+       return ()++maybeRelinkFiles :: [String] -> [String] -> String -> IO ()+maybeRelinkFiles src dst dir = +    mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst)++maybeRelinkFile :: [String] -> String -> IO ()+maybeRelinkFile [] _ = return ()+maybeRelinkFile (h:t) f =+    do done <- maybeRelink (h ++ "/" ++ f) f+       unless done $+           maybeRelinkFile t f+       return ()+++\end{code}+\begin{options}+--reorder-patches+\end{options}++The \verb|--reorder-patches| option causes Darcs to create an optimal+ordering of its internal patch inventory. This may help to produce shorter+`context' lists when sending patches, and may improve performance for some+other operations as well.  You should not run \verb!--reorder-patches! on a+repository from which someone may be simultaneously pulling or getting, as+this could lead to repository corruption.+\begin{code}++-- FIXME: someone needs to grovel through the source and determine+-- just how optimizeInventory differs from do_reorder.  The following+-- is purely speculation. --twb, 2009-04+-- optimize_help_reorder :: String+-- optimize_help_reorder =+--  "The `darcs optimize --reorder' command is a more comprehensive version\n" +++--  "of the default optimization.  It reorders patches with respect to ALL\n" +++--  "tags, rather than just the latest tag.\n"++do_reorder :: RepoPatch p => [DarcsFlag] -> Repository p -> IO ()+do_reorder opts _ | not (Reorder `elem` opts) = return ()+do_reorder opts repository = do+    debugMessage "Reordering the inventory."+    psnew <- choose_order `fmap` read_repo repository+    let ps = mapFL_FL hopefully $ reverseRL $ head $ unsafeUnRL psnew+    withGutsOf repository $ do tentativelyReplacePatches repository opts ps+                               finalizeRepositoryChanges repository+    debugMessage "Done reordering the inventory."++choose_order :: RepoPatch p => PatchSet p -> PatchSet p+choose_order ps | isJust last_tag =+    case slightly_optimize_patchset $ unsafeUnseal $ get_patches_in_tag lt ps of +    ((t:<:NilRL):<:pps) -> case get_patches_beyond_tag lt ps of+                           FlippedSeal (p :<: NilRL) -> (p+<+(t:<:NilRL)) :<: pps+                           _ -> impossible+    _ -> impossible             +    where last_tag = case filter is_tag $ mapRL info $ concatRL ps of+                     (t:_) -> Just t+                     _ -> Nothing+          lt = fromJust last_tag+choose_order ps = ps+\end{code}
+ src/Darcs/Commands/Pull.lhs view
@@ -0,0 +1,274 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{pull}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Pull ( pull ) where+import System.Exit ( ExitCode(..), exitWith )+import Workaround ( getCurrentDirectory )+import Control.Monad ( when )+import Data.List ( nub )++import Darcs.Commands ( DarcsCommand(..), loggers )+import Darcs.CommandsAux ( check_paths )+import Darcs.Arguments ( DarcsFlag( Verbose, Quiet, DryRun, MarkConflicts, XMLOutput,+                                   Intersection, Complement, AllowConflicts, NoAllowConflicts ),+                         nocompress, ignoretimes, definePatches,+                         deps_sel, pull_conflict_options, use_external_merge,+                         match_several, fixUrl,+                         all_interactive, repo_combinator,+                         print_dry_run_message_and_exit,+                         test, dry_run,+                         set_default, summary, working_repo_dir, remote_repo,+                         set_scripts_executable, nolinks,+                         network_options, umask_option, allow_unrelated_repos, restrict_paths+                      )+import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf,+                          amInRepository, withRepoLock, ($-), tentativelyMergePatches,+                          sync_repo, finalizeRepositoryChanges, applyToWorking,+                          read_repo, checkUnrelatedRepos )+import Darcs.Hopefully ( info )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Ordered ( (:>)(..), (:\/:)(..), RL(..), unsafeUnRL, concatRL,+                             mapFL, nullFL, reverseRL, mapRL )+import Darcs.Patch.Permutations ( partitionFL )+import Darcs.SlurpDirectory ( wait_a_moment )+import Darcs.Repository.Prefs ( add_to_preflist, defaultrepo, set_defaultrepo, get_preflist )+import Darcs.Repository.Motd (show_motd )+import Darcs.Patch.Depends ( get_common_and_uncommon,+                             patchset_intersection, patchset_union )+import Darcs.SelectChanges ( with_selected_changes )+import Darcs.Utils ( clarify_errors, formatPath )+import Darcs.Sealed ( Sealed(..), seal )+import Printer ( putDocLn, vcat, ($$), text )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++pull_description :: String+pull_description =+ "Copy and apply patches from another repository to this one."++pull_help :: String+pull_help =+ "Pull is used to bring changes made in another repository into the current\n"+++ "repository (that is, either the one in the current directory, or the one\n"+++ "specified with the --repodir option). Pull allows you to bring over all or\n"+++ "some of the patches that are in that repository but not in this one. Pull\n"+++ "accepts arguments, which are URLs from which to pull, and when called\n"+++ "without an argument, pull will use the repository from which you have most\n"+++ "recently either pushed or pulled.\n"++pull :: DarcsCommand+pull = DarcsCommand {command_name = "pull",+                     command_help = pull_help,+                     command_description = pull_description,+                     command_extra_args = -1,+                     command_extra_arg_help = ["[REPOSITORY]..."],+                     command_command = pull_cmd,+                     command_prereq = amInRepository,+                     command_get_arg_possibilities = get_preflist "repos",+                     command_argdefaults = defaultrepo,+                     command_advanced_options = [repo_combinator,+                                                 nocompress, nolinks,+                                                 ignoretimes,+                                                 remote_repo,+                                                 set_scripts_executable,+                                                 umask_option,+                                                 restrict_paths] +++                                                network_options,+                     command_basic_options = [match_several,+                                              all_interactive,+                                              pull_conflict_options,+                                              use_external_merge,+                                              test]++dry_run++[summary,+                                              deps_sel,+                                              set_default,+                                              working_repo_dir,+                                              allow_unrelated_repos]}++pull_cmd :: [DarcsFlag] -> [String] -> IO ()++pull_cmd opts unfixedrepodirs@(_:_) =+  let (logMessage, _, logDocLn) = loggers opts+      putInfo = if (Quiet `elem` opts || XMLOutput `elem` opts) then \_ -> return () else logDocLn+      putVerbose = if Verbose `elem` opts then putDocLn else \_ -> return ()+  in withRepoLock opts $- \repository -> do+  here <- getCurrentDirectory+  repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs+  -- Test to make sure we aren't trying to pull from the current repo+  when (null repodirs) $+        fail "Can't pull from current repository!"+  (Sealed them, Sealed compl) <- read_repos repository opts repodirs+  old_default <- get_preflist "defaultrepo"+  set_defaultrepo (head repodirs) opts+  mapM_ (add_to_preflist "repos") repodirs+  when (old_default == repodirs) $+      let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"+      in  putInfo $ text $ pulling++" from "++concatMap formatPath repodirs++"..."+  mapM_ (show_motd opts) repodirs+  us <- read_repo repository+  (common, us' :\/: them'') <- return $ get_common_and_uncommon (us, them)+  (_     ,   _ :\/: compl') <- return $ get_common_and_uncommon (us, compl)+  checkUnrelatedRepos opts common us them+  let avoided = mapRL info (concatRL compl')+  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $ reverseRL $ concatRL them''+  do when (Verbose `elem` opts) $+          do case us' of+               (x@(_:<:_):<:_) -> putDocLn $ text "We have the following new (to them) patches:"+                                             $$ (vcat $ mapRL description x)+               _ -> return ()+             when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"+                                                 $$ (vcat $ mapFL description ps)+     when (nullFL ps) $ do putInfo $ text "No remote changes to pull in!"+                           definePatches ps+                           exitWith ExitSuccess+     with_selected_changes "pull" opts ps $+      \ (to_be_pulled:>_) -> do+      print_dry_run_message_and_exit "pull" opts to_be_pulled+      definePatches to_be_pulled+      when (nullFL to_be_pulled) $ do+          logMessage "You don't want to pull any patches, and that's fine with me!"+          exitWith ExitSuccess+      check_paths opts to_be_pulled+      putVerbose $ text "Getting and merging the following patches:"+      putVerbose $ vcat $ mapFL description to_be_pulled+      let merge_opts | NoAllowConflicts `elem` opts = opts+                     | AllowConflicts   `elem` opts = opts+                     | otherwise                    = MarkConflicts : opts+      Sealed pw <- tentativelyMergePatches repository "pull" merge_opts+                   (reverseRL $ head $ unsafeUnRL us') to_be_pulled+      invalidateIndex repository+      withGutsOf repository $ do finalizeRepositoryChanges repository+                                 -- so work will be more recent than rec:+                                 revertable $ do wait_a_moment+                                                 applyToWorking repository opts pw+      sync_repo repository+      putInfo $ text "Finished pulling and applying."+          where revertable x = x `clarify_errors` unlines+                  ["Error applying patch to the working directory.","",+                   "This may have left your working directory an inconsistent",+                   "but recoverable state. If you had no un-recorded changes",+                   "by using 'darcs revert' you should be able to make your",+                   "working directory consistent again."]+pull_cmd _ [] = fail "No default repository to pull from, please specify one"++{- Read in the specified pull-from repositories.  Perform+Intersection, Union, or Complement read.  In patch-theory terms+(stated in set algebra, where + is union and & is intersection+and \ is complement):++    Union =         ((R1 + R2 + ... + Rn) \ Rc)+    Intersection =  ((R1 & R2 & ... & Rn) \ Rc)+    Complement =    (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc)++                        where Rc = local repo+                              R1 = 1st specified pull repo+                              R2, R3, Rn = other specified pull repo++Since Rc is not provided here yet, the result of read_repos is a+tuple: the first patchset(s) to be complemented against Rc and then+the second patchset(s) to be complemented against Rc.+-}++read_repos :: RepoPatch p => Repository p -> [DarcsFlag] -> [String] -> IO (SealedPatchSet p,SealedPatchSet p)+read_repos _ _ [] = impossible+read_repos to_repo opts us =+    do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u+                            ps <- read_repo r+                            return $ seal ps) us+       return $ if Intersection `elem` opts+                then (patchset_intersection rs, seal NilRL)+                else if Complement `elem` opts+                     then (head rs, patchset_union $ tail rs)+                     else (patchset_union rs, seal NilRL)++\end{code}++\begin{options}+--intersection, --union [DEFAULT], --complement+\end{options}++If you provide more than one repository as an argument to pull, darcs'+behavior is determined by the presence of the \verb!--complement!,+\verb!--intersection!, and \verb!--union!  flags.  ++\begin{itemize}++\item The default (\verb!--union!) behavior is to pull any patches+that are in any of the specified repositories ($ R_1 \bigcup R_2+\bigcup R_3 \ldots$).++\item If you instead specify the \verb!--intersection! flag, darcs+will only pull those patches which are present in all source+repositories ($ R_1 \bigcap R_2 \bigcap R_3 \ldots$).++\item If you specify the \verb!--complement! flag, darcs will only+pull elements in the first repository that do not exist in any of the+remaining repositories\footnote{The first thing darcs will do is+remove duplicates, keeping only the first specification.  This is+noticeable for the complement operation, since mathematically $ S+\backslash S \rightarrow \emptyset $, one would expect that+``\texttt{darcs pull --complement repo1 repo1}'' would result in no+pulls, but the duplicate elimination removes the second+\texttt{repo1}, reducing the above to effectively ``\texttt{darcs pull+repo1}''.  The expected functionality could be seen via+``\texttt{darcs get -a repo1 repo2; darcs pull --complement repo1+repo2}'', but there are easier ways of doing nothing!} ($ R_1+\backslash (R_2 \bigcup R_3 \bigcup \ldots$)).++\end{itemize}+++\begin{options}+--external-merge+\end{options}++You can use an external interactive merge tool to resolve conflicts with the+flag \verb!--external-merge!.  For more details see+subsection~\ref{resolution}.++\begin{options}+--matches, --patches, --tags, --no-deps+\end{options}++The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!+options can be used to select which patches to pull, as described in+subsection~\ref{selecting}.++\begin{options}+--no-test, --test+\end{options}++If you specify the \verb!--test! option, pull will run the test (if a test+exists) on a scratch copy of the repository contents prior to actually performing+the pull.  If the test fails, the pull will be aborted.++\begin{options}+--verbose+\end{options}++Adding the \verb!--verbose! option causes another section to appear in the+output which also displays a summary of patches that you have and the remote+repository lacks. Thus, the following syntax can be used to show you all the patch+differences between two repositories:++\begin{verbatim}+darcs pull --dry-run --verbose+\end{verbatim}
+ src/Darcs/Commands/Push.lhs view
@@ -0,0 +1,255 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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{push}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Push ( push ) where+import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) )+import Control.Monad ( when )+import Data.Char ( toUpper )+import Workaround ( getCurrentDirectory )+import Darcs.Commands ( DarcsCommand(..) )+import Darcs.Arguments ( DarcsFlag( DryRun, Verbose, Quiet, Sign, SignAs, NoSign, SignSSL ),+                         definePatches,+                         working_repo_dir, summary,+                         print_dry_run_message_and_exit,+                         applyas, match_several, fixUrl, deps_sel,+                         all_interactive, dry_run, nolinks,+                         remote_repo, network_options,+                         set_default, sign, allow_unrelated_repos+                      )+import Darcs.Hopefully ( hopefully )+import Darcs.Repository ( withRepoReadLock, ($-), identifyRepositoryFor,+                          read_repo, amInRepository, checkUnrelatedRepos )+import Darcs.Patch ( description )+import Darcs.Ordered ( RL(..), (:>)(..), (:\/:)(..),+                             nullFL, reverseRL, mapFL_FL, unsafeUnRL, mapRL, lengthRL )+import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist )+import Darcs.External ( maybeURLCmd, signString )+import Darcs.URL ( is_url, is_file )+import Darcs.SelectChanges ( with_selected_changes )+import Darcs.Utils ( formatPath )+import Darcs.Patch.Depends ( get_common_and_uncommon )+import Darcs.Patch.Bundle ( make_bundle )+import Printer ( vcat, empty, text, ($$), (<+>), putDocLn, errorDoc )+import Darcs.RemoteApply ( remote_apply, apply_as )+import Darcs.Email ( make_email )+import English (englishNum, Noun(..))+#include "impossible.h"++push_description :: String+push_description =+ "Copy and apply patches from this repository to another one."++push_help :: String+push_help =+ "Push is the opposite of pull.  Push allows you to copy changes from the\n"+++ "current repository into another repository.\n"++push :: DarcsCommand+push = DarcsCommand {command_name = "push",+                     command_help = push_help,+                     command_description = push_description,+                     command_extra_args = 1,+                     command_extra_arg_help = ["[REPOSITORY]"],+                     command_command = push_cmd,+                     command_prereq = amInRepository,+                     command_get_arg_possibilities = get_preflist "repos",+                     command_argdefaults = defaultrepo,+                     command_advanced_options = [applyas,+                                                 nolinks,+                                                 remote_repo] +++                                                network_options,+                     command_basic_options = [match_several, deps_sel,+                                              all_interactive,+                                              sign]++dry_run++[summary,+                                              working_repo_dir,+                                              set_default,+                                              allow_unrelated_repos]}++push_cmd :: [DarcsFlag] -> [String] -> IO ()+push_cmd opts [""] = push_cmd opts []+push_cmd opts [unfixedrepodir] =+  let am_verbose = Verbose `elem` opts+      am_quiet = Quiet `elem` opts+      putVerbose s = when am_verbose $ putDocLn s+      putInfo s = when (not am_quiet) $ putDocLn s+  in+ do+ repodir <- fixUrl opts unfixedrepodir+ -- Test to make sure we aren't trying to push to the current repo+ here <- getCurrentDirectory+ when (repodir == here) $+       fail "Cannot push from repository to itself."+       -- absolute '.' also taken into account by fix_filepath+ (bundle,num_to_pull) <- withRepoReadLock opts $- \repository -> do+  if is_url repodir then do+       when (apply_as opts /= Nothing) $+           let msg = text "Cannot --apply-as when pushing to URLs" in+             if DryRun `elem` opts+             then putInfo $ text "NOTE: " <+> msg+                         $$ text ""+             else errorDoc msg+       maybeapply <- maybeURLCmd "APPLY" repodir+       when (maybeapply == Nothing) $+         let lprot = takeWhile (/= ':') repodir+             prot = map toUpper lprot+             msg = text ("Pushing to "++lprot++" URLs is not supported.\n"+++                         "You may be able to hack this to work"+++                         " using DARCS_APPLY_"++prot) in+           if DryRun `elem` opts+           then putInfo $ text "NOTE:" <+> msg+                       $$ text ""+           else errorDoc msg+   else do+       when (want_sign opts) $+        let msg = text "Signing doesn't make sense for local repositories or when pushing over ssh."+        in if DryRun `elem` opts+            then putInfo $ text "NOTE:" <+> msg+            else errorDoc msg+  them <- identifyRepositoryFor repository repodir >>= read_repo+  old_default <- get_preflist "defaultrepo"+  set_defaultrepo repodir opts+  when (old_default == [repodir]) $+       let pushing = if DryRun `elem` opts then "Would push" else "Pushing"+       in  putInfo $ text $ pushing++" to "++formatPath repodir++"..."+  us <- read_repo repository+  case get_common_and_uncommon (us, them) of+    (common, us' :\/: them') -> do+     checkUnrelatedRepos opts common us them+     putVerbose $ text "We have the following patches to push:"+               $$ (vcat $ mapRL description $ head $ unsafeUnRL us')+     firstUs <- case us' of+                   NilRL:<:NilRL -> do putInfo $ text "No recorded local changes to push!"+                                       exitWith ExitSuccess+                   NilRL -> bug "push_cmd: us' is empty!"+                   (x:<:_) -> return x+     with_selected_changes "push" opts (reverseRL firstUs) $+      \ (to_be_pushed:>_) -> do+      definePatches to_be_pushed+      print_dry_run_message_and_exit "push" opts to_be_pushed+      when (nullFL to_be_pushed) $ do+          putInfo $+            text "You don't want to push any patches, and that's fine with me!"+          exitWith ExitSuccess+      let num_to_pull = lengthRL $ head $ unsafeUnRL them'+          bundle = make_bundle []+                     (bug "using slurpy in make_bundle called from Push")+                     common (mapFL_FL hopefully to_be_pushed)+      return (bundle, num_to_pull)+ sbundle <- signString opts bundle+ let body = if is_file repodir+            then sbundle+            else make_email repodir [] Nothing sbundle Nothing+ rval <- remote_apply opts repodir body+ let pull_reminder =+         if num_to_pull > 0+         then text $ "(By the way, the remote repository has " ++ show num_to_pull ++ " "+                     ++ englishNum num_to_pull (Noun "patch") " to pull.)"+         else empty+ case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"+                                   exitWith (ExitFailure ec)+              ExitSuccess -> putInfo $ text "Push successful." $$ pull_reminder++push_cmd _ _ = impossible++want_sign :: [DarcsFlag] -> Bool+want_sign opts = case opts of+    []            -> False+    Sign:_        -> True+    (SignAs _):_  -> True+    (SignSSL _):_ -> True+    NoSign:_      -> False+    _:opts'       -> want_sign opts'+\end{code}++For obvious reasons, you can only push to repositories to which you have+write access.  In addition, you can only push to repos that you access+either on the local file system or with ssh.  In order to apply with ssh,+darcs must also be installed on the remote computer.  The command invoked+to run ssh may be configured by the \verb!DARCS_SSH! environment variable+(see subsection~\ref{env:DARCS_SSH}).  The command invoked via ssh is always+\verb!darcs!, i.e.\ the darcs executable must be in the default path on+the remote machine.++Push works by creating a patch bundle, and then running darcs apply in the+target repository using that patch bundle.  This means that the default+options for \emph{apply} in the \emph{target} repository (such as, for+example, \verb!--test!) will affect the behavior of push.  This also means+that push is somewhat less efficient than pull.++When you receive an error message such as+\begin{verbatim}+bash: darcs: command not found+\end{verbatim}+then this means that the darcs on the remote machine could+not be started.  Make sure that the darcs executable is called+\verb!darcs! and is found in the default path.  The default path can+be different in interactive and in non-interactive shells.  Say+\begin{verbatim}+ssh login@remote.machine darcs+\end{verbatim}+to try whether the remote darcs can be found, or+\begin{verbatim}+ssh login@remote.machine 'echo $PATH'+\end{verbatim}+(note the single quotes) to check the default path.++\begin{options}+--apply-as+\end{options}++If you give the \verb!--apply-as! flag, darcs will use sudo to apply the+changes as a different user.  This can be useful if you want to set up a+system where several users can modify the same repository, but you don't+want to allow them full write access.  This isn't secure against skilled+malicious attackers, but at least can protect your repository from clumsy,+inept or lazy users.++\begin{options}+--matches, --patches, --tags, --no-deps+\end{options}++The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!+options can be used to select which patches to push, as described in+subsection~\ref{selecting}.++When there are conflicts, the behavior of push is determined by the default+flags to \verb!apply! in the \emph{target} repository.  Most commonly, for+pushed-to repositories, you'd like to have \verb!--dont-allow-conflicts! as+a default option to apply (by default, it is already the default\ldots).  If+this is the case, when there are conflicts on push, darcs will fail with an+error message.  You can then resolve by pulling the conflicting patch,+recording a resolution and then pushing the resolution together with the+conflicting patch.++Darcs does not have an explicit way to tell you which patch conflicted, only the+file name. You may want to pull all the patches from the remote repository just+to be sure. If you don't want to do this in your working directory,+you can create another darcs working directory for this purpose.++If you want, you could set the target repository to use \verb!--allow-conflicts!.+In this case conflicting patches will be applied, but the conflicts will+not be marked in the working directory.++If, on the other hand, you have \verb!--mark-conflicts! specified as a+default flag for apply in the target repository, when there is a conflict,+it will be marked in the working directory of the target repository.  In+this case, you should resolve the conflict in the target repository itself.
+ src/Darcs/Commands/Put.lhs view
@@ -0,0 +1,137 @@+\darcsCommand{put}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Put ( put ) where+import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith )+import Control.Monad ( when )+import Data.Maybe ( catMaybes )+import System.Directory ( createDirectory )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Quiet, Verbose,+                                    UseFormat2, UseHashedInventory, UseOldFashionedInventory ),+                        applyas, match_one_context, fixUrl,+                        network_options, flagToString, get_inventory_choices,+                        set_scripts_executable, working_repo_dir, set_default+                      )+import Darcs.Repository ( withRepoReadLock, ($-), patchSetToPatches, read_repo, amInRepository )+import Darcs.Repository.Format ( identifyRepoFormat,+                                 RepoProperty ( Darcs2, HashedInventory ), format_has )+import Darcs.Patch.Bundle ( make_bundle2 )+import Darcs.Ordered ( FL(..) )+import Darcs.Match ( have_patchset_match, get_one_patchset )+import Darcs.Repository.Prefs ( get_preflist, set_defaultrepo )+import Darcs.URL ( is_url, is_file )+import Darcs.Utils ( withCurrentDirectory )+import Progress ( debugMessage )+import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Darcs.SlurpDirectory ( empty_slurpy )+import Darcs.External ( execSSH )+import Darcs.RemoteApply ( remote_apply )+import Darcs.Commands.Init ( initialize )+import Darcs.Email ( make_email )+import Darcs.Sealed ( Sealed(..), seal )+#include "impossible.h"++put_description :: String +put_description =+ "Makes a copy of the repository"++put_help :: String+put_help =+ "The `darcs put' command creates a copy of the current repository.  It\n" +++ "is currently very inefficient, so when creating local copies you\n" +++ "should use `darcs get . x' instead of `darcs put x'.\n" +++ "\n" +++ "Currently this command just uses `darcs init' to create the target\n" +++ "repository, then `darcs push --all' to copy patches to it.  Options\n" +++ "passed to `darcs put' are passed to the init and/or push commands as\n" +++ "appropriate.  See those commands for an explanation of each option.\n"++put ::DarcsCommand+put = DarcsCommand {command_name = "put",+                    command_help = put_help,+                    command_description = put_description,+                    command_extra_args = 1,+                    command_extra_arg_help = ["<NEW REPOSITORY>"],+                    command_command = put_cmd,+                    command_prereq = amInRepository,+                    command_get_arg_possibilities = get_preflist "repos",+                    command_argdefaults = nodefaults,+                    command_advanced_options = [applyas] ++ network_options,+                    command_basic_options = [match_one_context, set_scripts_executable,+                                             get_inventory_choices,+                                             set_default, working_repo_dir]}++put_cmd :: [DarcsFlag] -> [String] -> IO ()+put_cmd _ [""] = fail "Empty repository argument given to put."+put_cmd opts [unfixedrepodir] =+  let am_quiet = Quiet `elem` opts+      putInfo s = when (not am_quiet) $ putStrLn s+      putVerbose = when (Verbose `elem` opts) . putStrLn+  in+ do+ repodir <- fixUrl opts unfixedrepodir+ -- Test to make sure we aren't trying to push to the current repo+ t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "."+ t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir+ let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir+     req_absolute_repo_dir = toPath t_req_absolute_repo_dir+ when (cur_absolute_repo_dir == req_absolute_repo_dir) $+       fail "Can't put to current repository!"+ when (is_url req_absolute_repo_dir) $ error "Can't put to a URL!"++ debugMessage "Creating repository"+ putVerbose "Creating repository"+ rf_or_e <- identifyRepoFormat "."+ rf <- case rf_or_e of Left e -> fail e+                       Right x -> return x+ let initopts = if format_has Darcs2 rf+                then UseFormat2:filter (/= UseOldFashionedInventory) opts+                else if format_has HashedInventory rf &&+                        not (UseOldFashionedInventory `elem` opts)+                     then UseHashedInventory:filter (/= UseFormat2) opts+                     else UseOldFashionedInventory:filter (/= UseFormat2) opts+ if is_file req_absolute_repo_dir+     then do createDirectory req_absolute_repo_dir+             withCurrentDirectory req_absolute_repo_dir $ (command_command initialize) initopts []+     else do -- is_ssh req_absolute_repo_dir+             remoteInit req_absolute_repo_dir initopts++ withCurrentDirectory cur_absolute_repo_dir $+                      withRepoReadLock opts $- \repository -> do+  set_defaultrepo req_absolute_repo_dir opts+  Sealed patchset <- if have_patchset_match opts+                     then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type+                     else read_repo repository >>= (return . seal)+  Sealed patchset2 <- if have_patchset_match opts+                      then get_one_patchset repository opts  -- todo: make sure get_one_patchset has the right type+                      else read_repo repository >>= (return . seal)+  let patches = patchSetToPatches patchset+      patches2 = patchSetToPatches patchset2+      nullFL NilFL = True+      nullFL _ = False+  when (nullFL patches) $ do+          putInfo "No patches were selected to put. Nothing to be done."+          exitWith ExitSuccess+  let bundle = (make_bundle2 opts empty_slurpy [] patches patches2)+      message = if is_file req_absolute_repo_dir+                then bundle+                else make_email req_absolute_repo_dir [] Nothing bundle Nothing+  putVerbose "Applying patches in new repository..."+  rval <- remote_apply opts req_absolute_repo_dir message+  case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"+                                    exitWith (ExitFailure ec)+               ExitSuccess -> putInfo "Put successful."+put_cmd _ _ = impossible++remoteInit :: FilePath -> [DarcsFlag] -> IO ()+remoteInit repo opts = do+    let args = catMaybes $ map (flagToString $ command_basic_options initialize) opts+        command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords args+    exitCode <- execSSH addr command+    when (exitCode /= ExitSuccess) $ +         fail "Couldn't initialize remote repository."+  where (addr,':':path) = break (==':') repo+\end{code}
+ src/Darcs/Commands/Record.lhs view
@@ -0,0 +1,511 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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{record}+\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, PatternGuards #-}++module Darcs.Commands.Record ( record, commit, get_date, get_log, file_exists ) where+import Control.Exception ( handleJust, Exception( ExitException ) )+import Control.Monad ( filterM, when )+import System.IO ( hGetContents, stdin )+import Data.List ( sort, isPrefixOf )+import System.Exit ( exitWith, exitFailure, ExitCode(..) )+import System.IO ( hPutStrLn )+import System.Directory ( doesFileExist, doesDirectoryExist, removeFile )+import Data.Maybe ( isJust )++import Darcs.Lock ( readBinFile, writeBinFile, world_readable_temp, appendToFile, removeFileMayNotExist )+import Darcs.Hopefully ( info, n2pia )+import Darcs.Repository ( Repository, amInRepository, withRepoLock, ($-),+                          get_unrecorded_in_files,+                          get_unrecorded_in_files_unsorted, withGutsOf,+                    sync_repo, read_repo,+                    slurp_recorded,+                    tentativelyAddPatch, finalizeRepositoryChanges,+                  )+import Darcs.Patch ( RepoPatch, Patch, Prim, namepatch, summary, anonymous,+                     adddeps, fromPrims )+import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+),+                             unsafeUnFL, unsafeCompare,+                             reverseRL, mapFL, mapFL_FL, nullFL )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.SlurpDirectory ( slurp_hasfile, slurp_hasdir )+import Darcs.Patch.Choices ( patch_choices_tps, tp_patch,+                             force_first, get_choices, tag )+import Darcs.SelectChanges ( with_selected_changes_to_files',+                             with_selected_changes_reversed )+import Darcs.RepoPath ( FilePathLike, SubPath, sp2fn, toFilePath )+import Darcs.SlurpDirectory ( Slurpy, empty_slurpy )+import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_stub )+import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,+                                    EditLongComment, RmLogFile, LogFile, Pipe,+                                    PatchName, AskDeps, All ),+                         get_author, working_repo_dir, lookforadds,+                         fixSubPaths, defineChanges, testByDefault,+                         ask_long_comment, askdeps, patch_select_flag,+                         all_pipe_interactive, leave_test_dir, notest,+                         author, patchname_option, umask_option, ignoretimes,+                         nocompress, rmlogfile, logfile, list_registered_files,+                         set_scripts_executable )+import Darcs.Utils ( askUser, promptYorn, edit_file, clarify_errors )+import Progress ( debugMessage)+import Darcs.ProgressPatches( progressFL)+import IsoDate ( getIsoDateTime, cleanLocalDate )+import Printer ( hPutDocLn, text, wrap_text, ($$), renderString )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++record_description :: String+record_description =+ "Save changes in the working copy to the repository as a patch."+\end{code}++If you provide one or more files or directories as additional arguments+to record, you will only be prompted to changes in those files or+directories.+\begin{code}+record_help :: String+record_help = renderString $ wrap_text 80 $+ "Record is used to name a set of changes and record the patch to the "+++ "repository."++record :: DarcsCommand+record = DarcsCommand {command_name = "record",+                       command_help = record_help,+                       command_description = record_description,+                       command_extra_args = -1,+                       command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                       command_command = record_cmd,+                       command_prereq = amInRepository,+                       command_get_arg_possibilities = list_registered_files,+                       command_argdefaults = nodefaults,+                       command_advanced_options = [logfile, rmlogfile,+                                                   nocompress, ignoretimes,+                                                   umask_option,+                                                   set_scripts_executable],+                       command_basic_options = [patchname_option, author,+                                               notest,+                                               leave_test_dir,+                                               all_pipe_interactive,+                                               askdeps,+                                               ask_long_comment,+                                               lookforadds,+                                               working_repo_dir]}++commit_description :: String+commit_description =+ "Does not actually do anything, but offers advice on saving changes"++commit_help :: String+commit_help =+ "This command does not do anything.\n"+++ "If you want to save changes locally, use the `darcs record' command.\n"+++ "If you want to save a recorded patch to another repository, use the\n"+++ "`darcs push' or `darcs send' commands instead.\n"++commit :: DarcsCommand+commit = command_stub "commit" commit_help commit_description record++file_exists :: Slurpy -> SubPath -> IO Bool+file_exists s rp = do file <- doesFileExist fp+                      dir <- doesDirectoryExist fp+                      return (file || dir ||+                              slurp_hasfile (sp2fn rp) s ||+                              slurp_hasdir (sp2fn rp) s)+                   where fp = toFilePath rp++record_cmd :: [DarcsFlag] -> [String] -> IO ()+record_cmd opts args = do+    check_name_is_not_option opts+    let (logMessage,_, _) = loggers opts+    withRepoLock (testByDefault opts) $- \repository -> do+    rec <- if null args then return empty_slurpy+           else slurp_recorded repository+    files <- sort `fmap` fixSubPaths opts args+    let non_repo_files = if null files && (not $ null args) then args else []+    existing_files <- filterM (file_exists rec) files+    non_existent_files <- filterM (fmap not . file_exists rec) files+    when (not $ null existing_files) $+         logMessage $ "Recording changes in "++unwords (map show existing_files)++":\n"+    when (not $ null non_existent_files) $+         logMessage $ "Non existent files or directories: "++unwords (map show non_existent_files)++"\n"+    when (((not $ null non_existent_files) || (not $ null non_repo_files)) && null existing_files) $+         fail "None of the files you specified exist!"+    debugMessage "About to get the unrecorded changes."+    let existing_fns = map sp2fn existing_files+    changes <- if All `elem` opts then get_unrecorded_in_files_unsorted repository existing_fns+                                  else get_unrecorded_in_files repository existing_fns+    debugMessage "I've gotten unrecorded."+    case allow_empty_with_askdeps changes of+      Nothing -> do when (Pipe `elem` opts) $ do get_date opts+                                                 return ()+                    if ((not $ null existing_files) || (not $ null non_existent_files))+                       then logMessage "No changes in selected files or directories!"+                       else logMessage "No changes!"+      Just ch -> do_record repository opts existing_files ch+    where allow_empty_with_askdeps NilFL+              | AskDeps `elem` opts = Just NilFL+              | otherwise = Nothing+          allow_empty_with_askdeps p = Just p++ -- check that what we treat as the patch name is not accidentally a command+ -- line flag+check_name_is_not_option :: [DarcsFlag] -> IO ()+check_name_is_not_option opts = do+    let (logMessage, _, _) = loggers opts+        patchNames = [n | PatchName n <- opts]+    when (length patchNames == 1) $ do+        let n = head patchNames+            oneLetterName = length n == 1 || (length n == 2 && head n == '-')+        if (oneLetterName && not (elem All opts))+            then do+                let keepAsking = do+                    yorn <- promptYorn ("You specified " ++ show n ++ " as the patch name. Is that really what you want?")+                    case yorn of +                        'y' -> return ()+                        'n' -> do+                                   logMessage "Okay, aborting the record."+                                   exitFailure+                        _   -> keepAsking+                keepAsking+            else return ()+++do_record :: RepoPatch p => Repository p -> [DarcsFlag] -> [SubPath] -> FL Prim -> IO ()+do_record repository opts files ps = do+    let make_log = world_readable_temp "darcs-record"+    date <- get_date opts+    my_author <- get_author opts+    debugMessage "I'm slurping the repository."+    debugMessage "About to select changes..."+    with_selected_changes_to_files' "record" opts+      (map toFilePath files) ps $ \ (chs:>_) ->+      do when (is_empty_but_not_askdeps chs) $+              do putStrLn "Ok, if you don't want to record anything, that's fine!"+                 exitWith ExitSuccess+         handleJust only_successful_exits (\_ -> return ()) $+             do deps <- if AskDeps `elem` opts+                        then ask_about_depends repository chs opts+                        else return []+                when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies."+                if nullFL chs && null deps+                  then putStrLn "Ok, if you don't want to record anything, that's fine!"+                  else do defineChanges chs+                          (name, my_log, logf) <- get_log opts Nothing make_log chs+                          do_actual_record repository opts name date+                                 my_author my_log logf deps chs+    where is_empty_but_not_askdeps l+              | AskDeps `elem` opts = False+                                      -- a "partial tag" patch; see below.+              | otherwise = nullFL l++do_actual_record :: RepoPatch p => Repository p -> [DarcsFlag] -> String -> String -> String+                 -> [String] -> Maybe String+                 -> [PatchInfo] -> FL Prim -> IO ()+do_actual_record repository opts name date my_author my_log logf deps chs =+              do debugMessage "Writing the patch file..."+                 mypatch <- namepatch date name my_author my_log $+                            fromPrims $ progressFL "Writing changes:" chs+                 tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps+                 invalidateIndex repository+                 debugMessage "Applying to pristine..."+                 withGutsOf repository (finalizeRepositoryChanges repository)+                                    `clarify_errors` failuremessage+                 debugMessage "Syncing timestamps..."+                 sync_repo repository+                 when (isJust logf) $ removeFile (fromJust logf)+                 logMessage $ "Finished recording patch '"++name++"'"+    where (logMessage,_,_) = loggers opts+          failuremessage = "Failed to record patch '"++name++"'" +++                           case logf of Just lf -> "\nLogfile left in "++lf++"."+                                        Nothing -> ""+\end{code}+Each patch is given a name, which typically would consist of a brief+description of the changes.  This name is later used to describe the patch.+The name must fit on one line (i.e.\ cannot have any embedded newlines).  If+you have more to say, stick it in the log.+\begin{code}+\end{code}++The patch is also flagged with the author of the change, taken by default+from the \verb!DARCS_EMAIL! environment variable, and if that doesn't+exist, from the \verb!EMAIL! environment variable.  The date on which the+patch was recorded is also included.  Currently there is no provision for+keeping track of when a patch enters a given repository.+\begin{code}+get_date :: [DarcsFlag] -> IO String+get_date opts+ | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? "+get_date _ = getIsoDateTime+\end{code}+\label{DARCS_EDITOR}+Finally, each changeset should have a full log (which may be empty).  This+log is for detailed notes which are too lengthy to fit in the name.  If you+answer that you do want to create a comment file, darcs will open an editor+so that you can enter the comment in.  The choice of editor proceeds as+follows.  If one of the \verb!$DARCS_EDITOR!, \verb!$VISUAL! or+\verb!$EDITOR! environment variables is defined, its value is used (with+precedence proceeding in the order listed).  If not, ``vi'', ``emacs'',+``emacs~-nw'' and ``nano'' are tried in that order.++\begin{options}+--logfile+\end{options}++If you wish, you may specify the patch name and log using the+\verb!--logfile! flag.  If you do so, the first line of the specified file+will be taken to be the patch name, and the remainder will be the ``long+comment''.  This feature can be especially handy if you have a test that+fails several times on the record (thus aborting the record), so you don't+have to type in the long comment multiple times. The file's contents will+override the \verb!--patch-name! option.++\begin{code}+data PName = FlagPatchName String | PriorPatchName String | NoPatchName++get_log :: [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL Prim ->+           IO (String, [String], Maybe String)+get_log opts m_old make_log chs = gl opts+    where patchname_specified = patchname_helper opts+          patchname_helper (PatchName n:_) | take 4 n == "TAG " = FlagPatchName $ '.':n+                                           | otherwise          = FlagPatchName n+          patchname_helper (_:fs) = patchname_helper fs+          patchname_helper [] = case m_old of Just (p,_) -> PriorPatchName p+                                              Nothing    -> NoPatchName+          default_log = case m_old of+                          Nothing    -> []+                          Just (_,l) -> l+          gl (Pipe:_) = do p <- case patchname_specified of+                                  FlagPatchName p  -> return p+                                  PriorPatchName p -> return p+                                  NoPatchName      -> prompt_patchname False+                           putStrLn "What is the log?"+                           thelog <- lines `fmap` hGetContents stdin -- ratify hGetContents: stdin not deleted+                           return (p, thelog, Nothing)+          gl (LogFile f:fs) =+              do -- round 1 (patchname)+                 mlp <- lines `fmap` readBinFile f `catch` (\_ -> return [])+                 firstname <- case (patchname_specified, mlp) of+                                (FlagPatchName  p, []) -> return p+                                (_, p:_)               -> return p -- logfile trumps prior!+                                (PriorPatchName p, []) -> return p+                                (NoPatchName, [])      -> prompt_patchname True+                 -- round 2+                 append_info f firstname+                 when (EditLongComment `elem` fs) $ do edit_file f+                                                       return ()+                 (name, thelog, _) <- read_long_comment f firstname+                 when (RmLogFile `elem` opts) $ removeFileMayNotExist f+                 return (name, thelog, Nothing)+          gl (EditLongComment:_) =+                  case patchname_specified of+                    FlagPatchName  p -> actually_get_log p+                    PriorPatchName p -> actually_get_log p+                    NoPatchName      -> prompt_patchname True >>= actually_get_log+          gl (NoEditLongComment:_) =+                  case patchname_specified of+                    FlagPatchName  p+                        | Just ("",_) <- m_old ->+                                       return (p, default_log, Nothing) -- rollback -m+                    FlagPatchName  p -> return (p, default_log, Nothing) -- record (or amend) -m+                    PriorPatchName p -> return (p, default_log, Nothing) -- amend+                    NoPatchName      -> do p <- prompt_patchname True -- record+                                           return (p, [], Nothing)+          gl (PromptLongComment:fs) =+                  case patchname_specified of+                    FlagPatchName p -> prompt_long_comment p -- record (or amend) -m+                    _               -> gl fs+          gl (_:fs) = gl fs+          gl [] = case patchname_specified of+                    FlagPatchName  p -> return (p, default_log, Nothing)  -- record (or amend) -m+                    PriorPatchName "" -> prompt_patchname True >>= prompt_long_comment+                    PriorPatchName p -> return (p, default_log, Nothing)+                    NoPatchName -> prompt_patchname True >>= prompt_long_comment+          prompt_patchname retry =+            do n <- askUser "What is the patch name? "+               if n == "" || take 4 n == "TAG "+                  then if retry then prompt_patchname retry+                                else fail "Bad patch name!"+                  else return n+          prompt_long_comment oldname =+            do yorn <- promptYorn "Do you want to add a long comment?"+               if yorn == 'y' then actually_get_log oldname+                              else return (oldname, [], Nothing)+          actually_get_log p = do logf <- make_log+                                  writeBinFile logf $ unlines $ p : default_log+                                  append_info logf p+                                  edit_file logf+                                  read_long_comment logf p+          read_long_comment :: FilePathLike p => p -> String -> IO (String, [String], Maybe p)+          read_long_comment f oldname =+              do t <- (lines.filter (/='\r')) `fmap` readBinFile f+                 case t of [] -> return (oldname, [], Just f)+                           (n:ls) -> return (n, takeWhile+                                             (not.(eod `isPrefixOf`)) ls,+                                             Just f)+          append_info f oldname =+              do fc <- readBinFile f+                 appendToFile f $ \h ->+                     do case fc of+                          _ | null (lines fc) -> hPutStrLn h oldname+                            | last fc /= '\n' -> hPutStrLn h ""+                            | otherwise       -> return ()+                        hPutDocLn h $ text eod+                            $$ text ""+                            $$ wrap_text 75+                               ("Place the long patch description above the "+++                                eod+++                                " marker.  The first line of this file "+++                                "will be the patch name.")+                            $$ text ""+                            $$ text "This patch contains the following changes:"+                            $$ text ""+                            $$ summary (fromPrims chs :: Patch)++eod :: String+eod = "***END OF DESCRIPTION***"+\end{code}++\begin{options}+--ask-deps+\end{options}++Each patch may depend on any number of previous patches.  If you choose to+make your patch depend on a previous patch, that patch is required to be+applied before your patch can be applied to a repository.  This can be used, for+example, if a piece of code requires a function to be defined, which was+defined in an earlier patch.++If you want to manually define any dependencies for your patch, you can use+the \verb!--ask-deps! flag, and darcs will ask you for the patch's+dependencies.++It is possible to record a patch which has no actual changes but which+has specific dependencies.  This type of patch can be thought of as a+``partial tag''.  The \verb!darcs tag! command will record a patch+with no actual changes but which depends on the entire current+inventory of the repository.  The \verb!darcs record --ask-deps! with+no selected changes will record a patch that depends on only those+patches selected via the \verb!--ask-deps! operation, resulting in a+patch which describes a set of patches; the presence of this primary+patch in a repository implies the presence of (at least) the+depended-upon patches.++\begin{code}+ask_about_depends :: RepoPatch p => Repository p -> FL Prim -> [DarcsFlag] -> IO [PatchInfo]+ask_about_depends repository pa' opts = do+  pps <- read_repo repository+  pa <- n2pia `fmap` anonymous (fromPrims pa')+  let ps = (reverseRL $ headRL pps)+>+(pa:>:NilFL)+      (pc, tps) = patch_choices_tps ps+      ta = case filter ((pa `unsafeCompare`) . tp_patch) $ unsafeUnFL tps of+                [tp] -> tag tp+                [] -> error "ask_about_depends: []"+                _ -> error "ask_about_depends: many"+      ps' = mapFL_FL tp_patch $ middle_choice $ force_first ta pc+  with_selected_changes_reversed "depend on" (filter askdep_allowed opts) ps'+             $ \(deps:>_) -> return $ mapFL info deps+ where headRL (x:<:_) = x+       headRL NilRL = impossible+       askdep_allowed = not . patch_select_flag+       middle_choice p = mc where (_ :> mc :> _) = get_choices p+++only_successful_exits :: Exception -> Maybe ()+only_successful_exits (ExitException ExitSuccess) = Just ()+only_successful_exits _ = Nothing+\end{code}++\begin{options}+--no-test,  --test+\end{options}++If you configure darcs to run a test suite, darcs will run this test on the+recorded repository to make sure it is valid.  Darcs first creates a pristine+copy of the source tree (in a temporary directory), then it runs the test,+using its return value to decide if the record is valid.  If it is not valid,+the record will be aborted.  This is a handy way to avoid making stupid+mistakes like forgetting to `darcs add' a new file.  It also can be+tediously slow, so there is an option (\verb!--no-test!) to skip the test.++\begin{options}+--set-scripts-executable+\end{options}++If you pass \verb!--set-scripts-executable! to \verb!darcs record!, darcs will set scripts+executable in the test directory before running the test.++\begin{options}+--pipe+\end{options}++If you run record with the \verb!--pipe! option, you will be prompted for+the patch date, author, and the long comment. The long comment will extend+until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z+on systems running a Microsoft OS).++This interface is intended for scripting darcs, in particular for writing+repository conversion scripts.  The prompts are intended mostly as a useful+guide (since scripts won't need them), to help you understand the format in+which to provide the input. Here's an example of what the \verb!--pipe!+prompts look like:++\begin{verbatim}+ What is the date? Mon Nov 15 13:38:01 EST 2004+ Who is the author? David Roundy+ What is the log? One or more comment lines+\end{verbatim}+++\begin{options}+--interactive+\end{options}++By default, \verb!record! works interactively. Probably the only thing you need+to know about using this is that you can press \verb!?! at the prompt to be+shown a list of the rest of the options and what they do. The rest should be+clear from there. Here's a+``screenshot'' to demonstrate:++\begin{verbatim}+hunk ./hello.pl +2++#!/usr/bin/perl++print "Hello World!\n";+Shall I record this patch? (2/2) [ynWsfqadjk], or ? for help: ?+How to use record...+y: record this patch+n: don't record it+w: wait and decide later, defaulting to no++s: don't record the rest of the changes to this file+f: record the rest of the changes to this file++d: record selected patches+a: record all the remaining patches+q: cancel record++j: skip to next patch+k: back up to previous patch+h or ?: show this help++<Space>: accept the current default (which is capitalized)++\end{verbatim}+What you can't see in that ``screenshot'' is that \verb!darcs! will also try to use+color in your terminal to make the output even easier to read.
+ src/Darcs/Commands/Remove.lhs view
@@ -0,0 +1,131 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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{remove}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Remove ( remove, rm, unadd ) where++import Control.Monad ( when )+import Darcs.Commands ( DarcsCommand(..), nodefaults,+                        command_alias, command_stub,+                      )+import Darcs.Arguments ( DarcsFlag, fixSubPaths,+                        list_registered_files,+                        working_repo_dir, umask_option+                      )+import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )+import Darcs.Repository ( Repository, withRepoLock, ($-), amInRepository,+                          slurp_pending, slurp_recorded,+                          get_unrecorded_in_files, add_to_pending )+import Darcs.Patch ( RepoPatch, Prim, apply_to_slurpy, adddir, rmdir, addfile, rmfile )+import Darcs.Ordered ( FL(..), (+>+) )+import Darcs.SlurpDirectory ( slurp_removedir, slurp_removefile )+import Darcs.Repository.Prefs ( filetype_function )+import Darcs.Diff ( unsafeDiff )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++remove_description :: String+remove_description = "Remove files from version control."++remove_help :: String+remove_help =+ "The `darcs remove' command exists primarily for symmetry with `darcs\n" +++ "add', as the normal way to remove a file from version control is\n" +++ "simply to delete it from the working tree.  This command is only\n" +++ "useful in the unusual case where one wants to record a removal patch\n" +++ "WITHOUT deleting the copy in the working tree (which can be re-added).\n" +++ "\n" +++ "Note that applying a removal patch to a repository (e.g. by pulling\n" +++ "the patch) will ALWAYS affect the working tree of that repository.\n"++remove :: DarcsCommand+remove = DarcsCommand {command_name = "remove",+                       command_help = remove_help,+                       command_description = remove_description,+                       command_extra_args = -1,+                       command_extra_arg_help = ["<FILE or DIRECTORY> ..."],+                       command_command = remove_cmd,+                       command_prereq = amInRepository,+                       command_get_arg_possibilities = list_registered_files,+                       command_argdefaults = nodefaults,+                       command_advanced_options = [umask_option],+                       command_basic_options =+                           [working_repo_dir]}++remove_cmd :: [DarcsFlag] -> [String] -> IO ()+remove_cmd opts relargs =+    withRepoLock opts $- \repository -> do+    args <- fixSubPaths opts relargs+    when (null args) $+      putStrLn "Nothing specified, nothing removed."+    p <- make_remove_patch repository args+    invalidateIndex repository+    add_to_pending repository p++make_remove_patch :: RepoPatch p => Repository p -> [SubPath] -> IO (FL Prim)+make_remove_patch repository files =+                          do s <- slurp_pending repository+                             srecorded <- slurp_recorded repository+                             pend <- get_unrecorded_in_files repository (map sp2fn files)+                             let sunrec = fromJust $ apply_to_slurpy pend srecorded+                             wt <- filetype_function+                             mrp wt s sunrec files+    where mrp wt s sunrec (f:fs) =+              case slurp_removedir fn s of+              Just s' ->+                  case slurp_removedir fn sunrec of+                  Just sunrec' -> do rest <- mrp wt s' sunrec' fs+                                     return $ rmdir f_fp :>: rest+                  Nothing -> do rest <- mrp wt s' sunrec fs+                                return $ adddir f_fp :>: rmdir f_fp :>: rest+              Nothing ->+                  case slurp_removefile fn s of+                  Nothing -> fail $ "Can't remove "++f_fp+                  Just s' ->+                      case slurp_removefile fn sunrec of+                      Nothing -> do rest <- mrp wt s' sunrec fs+                                    return $ addfile f_fp :>: rmfile f_fp :>: rest+                      Just sunrec' -> do rest <- mrp wt s' sunrec' fs+                                         let newp = unsafeDiff [] wt sunrec sunrec'+                                         return $ newp +>+ rest+            where fn = sp2fn f+                  f_fp = toFilePath f+          mrp _ _ _ [] = return NilFL++rm_description :: String+rm_description = "Help newbies find `darcs remove'."++rm_help :: String+rm_help =+ "The `darcs rm' command does nothing.\n" +++ "\n" +++ "The normal way to remove a file from version control is simply to\n" +++ "delete it from the working tree.  To remove a file from version\n" +++ "control WITHOUT affecting the working tree, see `darcs remove'.\n"++rm :: DarcsCommand+rm = command_stub "rm" rm_help rm_description remove++unadd :: DarcsCommand+unadd = command_alias "unadd" remove+\end{code}++
+ src/Darcs/Commands/Repair.lhs view
@@ -0,0 +1,70 @@+%  Copyright (C) 2003,2005 David Roundy+%+%  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{repair}+\begin{code}+module Darcs.Commands.Repair ( repair ) where+import System.IO++import Darcs.Commands+import Darcs.Arguments ( DarcsFlag(),+                        working_repo_dir, umask_option,+                      )+import Darcs.Repository ( withRepoLock, ($-), amInRepository,+                          replacePristineFromSlurpy, writePatchSet )+import Darcs.Repository.Repair( replayRepository,+                                RepositoryConsistency(..) )++repair_description :: String+repair_description = "Repair a corrupted repository."++repair_help :: String+repair_help =+ "The `darcs repair' command attempts to fix corruption in the current\n" +++ "repository.  Currently it can only repair damage to the pristine tree,\n" +++ "which is where most corruption occurs.\n"++repair :: DarcsCommand+repair = DarcsCommand {command_name = "repair",+                       command_help = repair_help,+                       command_description = repair_description,+                       command_extra_args = 0,+                       command_extra_arg_help = [],+                       command_command = repair_cmd,+                       command_prereq = amInRepository,+                       command_get_arg_possibilities = return [],+                       command_argdefaults = nodefaults,+                       command_advanced_options = [umask_option],+                       command_basic_options = [working_repo_dir]}++repair_cmd :: [DarcsFlag] -> [String] -> IO ()+repair_cmd opts _ = withRepoLock opts $- \repository -> do+  replayRepository repository opts $ \state ->+    case state of+      RepositoryConsistent ->+          putStrLn "The repository is already consistent, no changes made."+      BrokenPristine s -> do+               putStrLn "Fixing pristine tree..."+               replacePristineFromSlurpy repository s+      BrokenPatches s newps  -> do+               putStrLn "Writing out repaired patches..."+               writePatchSet newps opts+               putStrLn "Fixing pristine tree..."+               replacePristineFromSlurpy repository s+               return ()++\end{code}
+ src/Darcs/Commands/Replace.lhs view
@@ -0,0 +1,232 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{replace}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Replace ( replace ) where++import Data.Maybe ( isJust )+import Control.Monad ( unless )++import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,+                        command_description, command_extra_args,+                        command_extra_arg_help, command_command, command_prereq,+                        command_get_arg_possibilities, command_argdefaults,+                        command_advanced_options, command_basic_options),+                        nodefaults )+import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), list_registered_files,+                         ignoretimes, umask_option, tokens, force_replace,+                         working_repo_dir, fixSubPaths )+import Darcs.Repository ( withRepoLock, ($-),+                    add_to_pending, slurp_pending,+                    amInRepository, slurp_recorded_and_unrecorded,+                    applyToWorking,+                  )+import Darcs.Patch ( Prim, apply_to_slurpy, tokreplace, force_replace_slurpy )+import Darcs.Ordered ( FL(..), unsafeFL, (+>+), concatFL )+import Darcs.SlurpDirectory ( slurp_hasfile, Slurpy )+import RegChars ( regChars )+import Data.Char ( isSpace )+import Darcs.Diff ( unsafeDiff )+import Darcs.RepoPath ( SubPath, sp2fn, toFilePath )+import Darcs.Repository.Prefs ( FileType(TextFile) )+#include "impossible.h"++replace_description :: String+replace_description = "Substitute one word for another."++replace_help :: String+replace_help =+ "In addition to line-based patches, Darcs supports a limited form of\n" +++ "lexical substitution.  Files are treated as sequences of words, and\n" +++ "each occurrence of the old word is replaced by the new word.\n" +++ "This is intended to provide a clean way to rename a function or\n" +++ "variable.  Such renamings typically affect lines all through the\n" +++ "source code, so a traditional line-based patch would be very likely to\n" +++ "conflict with other branches, requiring manual merging.\n" +++ "\n" +++ "Files are tokenized according to one simple rule: words are strings of\n" +++ "valid token characters, and everything between them (punctuation and\n" +++ "whitespace) is discarded.\n" +++ "\n" +++ "The tokenizer treats files as byte strings, so it is not possible for\n" +++ "--token-chars to include multi-byte characters, such as the non-ASCII\n" +++ "parts of UTF-8.  Similarly, trying to replace a `high-bit' character\n" +++ "from a unibyte encoding will also result in replacement of the same\n" +++ "byte in files with different encodings.  For example, an acute a from\n" +++ "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" +++ "\n" +++ -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?+ "By default, valid token characters are letters, numbers and the\n" +++ "underscore (i.e. [A-Za-z0-9_]).  However if the old and/or new token\n" +++ "contains either a hyphen or period, BOTH hyphen and period are treated\n" +++ "as valid by default (i.e. [A-Za-z0-9_.-]).\n" +++ "\n" +++ "The set of valid characters can be customized using the --token-chars\n" +++ "option.  The argument must be surrounded by square brackets.  If a\n" +++ "hyphen occurs between two characters in the set, it is treated as a\n" +++ "set range.  For example, in most locales [A-Z] denotes all uppercase\n" +++ "letters.  If the first character is a caret, valid tokens are taken to\n" +++ "be the complement of the remaining characters.  For example, [^ \\n\\t]\n" +++ "declares all characters except the space, tab and newline as valid\n" +++ "within a word.  Unlike the tr(1) and grep(1) utilities, character\n" +++ "classes (such as [[:alnum:]]) are NOT supported.\n" +++ "\n" +++ "If you choose to use --token-chars, you are STRONGLY encouraged to do\n" +++ "so consistently.  The consequences of using multiple replace patches\n" +++ "with different --token-chars arguments on the same file are not well\n" +++ "tested nor well understood.\n" +++ "\n" +++ "By default Darcs will refuse to perform a replacement if the new token\n" +++ "is already in use, because the replacements would be not be\n" +++ "distinguishable from the existing tokens.  This behaviour can be\n" +++ "overridden by supplying the --force option, but an attempt to `darcs\n" +++ "rollback' the resulting patch will affect these existing tokens.\n"++-- FIXME: can  we just  delete the remaining  text?  It seems  more an+-- instance of "look how clever  I am; I made commutation work" rather+-- than information that is actually useful to users.+\end{code}+There is a potentially confusing difference, however, when a replace is+used to make another replace possible:+\begin{verbatim}+$ darcs replace newtoken aaack ./foo.c+$ darcs replace oldtoken newtoken ./foo.c+$ darcs record+\end{verbatim}+will be valid, even if \verb!newtoken! and \verb!oldtoken! are both present+in the recorded version of foo.c, while the sequence+\begin{verbatim}+$ [manually edit foo.c replacing newtoken with aaack]+$ darcs replace oldtoken newtoken ./foo.c+\end{verbatim}+will fail because ``newtoken'' still exists in the recorded version of+\verb!foo.c!.  The reason for the difference is that when recording, a+``replace'' patch always is recorded \emph{before} any manual changes,+which is usually what you want, since often you will introduce new+occurrences of the ``newtoken'' in your manual changes.  In contrast,+multiple ``replace'' changes are recorded in the order in which+they were made.+\begin{code}++replace :: DarcsCommand+replace = DarcsCommand {command_name = "replace",+                        command_help = replace_help,+                        command_description = replace_description,+                        command_extra_args = -1,+                        command_extra_arg_help = ["<OLD>","<NEW>",+                                                  "<FILE> ..."],+                        command_command = replace_cmd,+                        command_prereq = amInRepository,+                        command_get_arg_possibilities = list_registered_files,+                        command_argdefaults = nodefaults,+                        command_advanced_options = [ignoretimes, umask_option],+                        command_basic_options =+                            [tokens, force_replace, working_repo_dir]}++replace_cmd :: [DarcsFlag] -> [String] -> IO ()+replace_cmd opts (old:new:relfs) = withRepoLock opts $- \repository -> do+  fs <- fixSubPaths opts relfs+  toks <- choose_toks opts old new+  let checkToken tok =+        unless (is_tok toks tok) $ fail $ "'"++tok++"' is not a valid token!"+  checkToken old+  checkToken new+  (_, work) <- slurp_recorded_and_unrecorded repository+  cur <- slurp_pending repository+  pswork <- (concatFL . unsafeFL) `fmap` sequence (map (repl toks cur work) fs)+  add_to_pending repository pswork+  applyToWorking repository opts pswork `catch` \e ->+      fail $ "Can't do replace on working!\n"+          ++ "Perhaps one of the files already contains '"++ new++"'?\n"+          ++ show e+  where ftf _ = TextFile++        repl :: String -> Slurpy -> Slurpy -> SubPath -> IO (FL Prim)+        repl toks cur work f =+          if not $ slurp_hasfile (sp2fn f) work+          then do putStrLn $ "Skipping file '"++f_fp++"' which isn't in the repository."+                  return NilFL+          else if ForceReplace `elem` opts ||+                  isJust (apply_to_slurpy (tokreplace f_fp toks old new) work) ||+                  isJust (apply_to_slurpy (tokreplace f_fp toks old new) cur)+               then return (get_force_replace f toks work)+               else do putStrLn $ "Skipping file '"++f_fp++"'"+                       putStrLn $ "Perhaps the recorded version of this " +++                                  "file already contains '" ++new++"'?"+                       putStrLn $ "Use the --force option to override."+                       return NilFL+          where f_fp = toFilePath f++        get_force_replace :: SubPath -> String -> Slurpy -> FL Prim+        get_force_replace f toks s =+            case force_replace_slurpy (tokreplace f_fp toks new old) s of+            Nothing -> bug "weird forcing bug in replace."+            Just s' -> case unsafeDiff [] ftf s s' of+                       pfix -> pfix +>+ (tokreplace f_fp toks old new :>: NilFL)+            where f_fp = toFilePath f++replace_cmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]"++default_toks :: String+default_toks = "A-Za-z_0-9"+filename_toks :: String+filename_toks = "A-Za-z_0-9\\-\\."++-- | Given a set of characters and a string, returns true iff the+-- string contains only characters from the set.  A set beginning with+-- a caret (@^@) is treated as a complementary set.+is_tok :: String -> String -> Bool+is_tok _ "" = False+is_tok toks s = and $ map (regChars toks) s++-- | This function checks for @--token-chars@ on the command-line.  If+-- found, it validates the argument and returns it, without the+-- surrounding square brackets.  Otherwise, it returns either+-- 'default_toks' or 'filename_toks' as explained in 'replace_help'.+-- +-- Note: Limitations in the current replace patch file format prevents+-- tokens and token-char specifiers from containing any whitespace.+choose_toks :: [DarcsFlag] -> String -> String -> IO String+choose_toks (Toks t:_) a b+    | length t <= 2 =+        bad_token_spec $ "It must contain more than 2 characters, because " +++                         "it should be enclosed in square brackets"+    | head t /= '[' || last t /= ']' =+        bad_token_spec "It should be enclosed in square brackets"+    | '^' == head tok && length tok == 1 =+        bad_token_spec "Must be at least one character in the complementary set"+    | any isSpace t =+        bad_token_spec "Space is not allowed in the spec"+    | any isSpace a = bad_token_spec $ spacey_token a+    | any isSpace b = bad_token_spec $ spacey_token b+    | not (is_tok tok a) = bad_token_spec $ not_a_token a+    | not (is_tok tok b) = bad_token_spec $ not_a_token b+    | otherwise          = return tok+    where tok = init $ tail t :: String+          bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")"+          spacey_token x = x ++ " must not contain any space"+          not_a_token x = x ++ " is not a token, according to your spec"+choose_toks (_:fs) a b = choose_toks fs a b+choose_toks [] a b = if is_tok default_toks a && is_tok default_toks b+                     then return default_toks+                     else return filename_toks+\end{code}+
+ src/Darcs/Commands/Revert.lhs view
@@ -0,0 +1,119 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{revert}+\begin{code}+module Darcs.Commands.Revert ( revert ) where+import System.Exit ( ExitCode(..), exitWith )+import Control.Monad ( when )+import Data.List ( sort )++import English (englishNum, This(..), Noun(..))+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( All, Debug ),+                        ignoretimes, working_repo_dir,+                        all_interactive,+                        fixSubPaths, areFileArgs,+                        list_registered_files, umask_option,+                      )+import Darcs.Utils ( askUser )+import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.Repository ( withRepoLock, ($-), withGutsOf,+                    get_unrecorded_in_files,+                    get_unrecorded_in_files_unsorted,+                    add_to_pending, sync_repo,+                    applyToWorking,+                    amInRepository, slurp_recorded,+                  )+import Darcs.Patch ( invert, apply_to_filepaths, commute )+import Darcs.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) )+import Darcs.SelectChanges ( with_selected_last_changes_to_files' )+import Darcs.Patch.TouchesFiles ( choose_touching )+import Darcs.Commands.Unrevert ( write_unrevert )+import Darcs.Sealed ( unsafeUnseal )+import Darcs.Gorsvet( invalidateIndex )++revert_description :: String+revert_description = "Discard unrecorded changes."++revert_help :: String+revert_help =+ "The `darcs revert' command discards unrecorded changes the working\n" +++ "tree.  As with `darcs record', you will be asked which hunks (changes)\n" +++ "to revert.  The --all switch can be used to avoid such prompting. If\n" +++ "files or directories are specified, other parts of the working tree\n" +++ "are not reverted.\n" +++ "\n" +++ "In you accidentally reverted something you wanted to keep (for\n" +++ "example, typing `darcs rev -a' instead of `darcs rec -a'), you can\n" +++ "immediately run `darcs unrevert' to restore it.  This is only\n" +++ "guaranteed to work if the repository has not changed since `darcs\n" +++ "revert' ran.\n"++revert :: DarcsCommand+revert = DarcsCommand {command_name = "revert",+                       command_help = revert_help,+                       command_description = revert_description,+                       command_extra_args = -1,+                       command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                       command_command = revert_cmd,+                       command_prereq = amInRepository,+                       command_get_arg_possibilities = list_registered_files,+                       command_argdefaults = nodefaults,+                       command_advanced_options = [ignoretimes, umask_option],+                       command_basic_options = [all_interactive,+                                               working_repo_dir]}++revert_cmd :: [DarcsFlag] -> [String] -> IO ()+revert_cmd opts args = withRepoLock opts $- \repository -> do+  files <- sort `fmap` fixSubPaths opts args+  let files_fn = map sp2fn files+  when (areFileArgs files) $+       putStrLn $ "Reverting changes in "++unwords (map show files)++"..\n"+  changes <- if All `elem` opts+                   then get_unrecorded_in_files_unsorted repository files_fn+                   else get_unrecorded_in_files repository files_fn+  let pre_changed_files = apply_to_filepaths (invert changes) (map toFilePath files)+  rec <- slurp_recorded repository+  case unsafeUnseal $ choose_touching pre_changed_files changes of+    NilFL -> putStrLn "There are no changes to revert!"+    _ -> with_selected_last_changes_to_files' "revert" opts+               pre_changed_files changes $ \ (norevert:>p) ->+        if nullFL p+        then putStrLn $ "If you don't want to revert after all," +++                        " that's fine with me!"+        else do+             let theseChanges = englishNum (lengthFL p) . This . Noun $ "change"+             yorn <- if All `elem` opts+                     then return "y"+                     else askUser $ "Do you really want to revert " ++ theseChanges "? "+             case yorn of ('y':_) -> return ()+                          _ -> exitWith $ ExitSuccess+             withGutsOf repository $ do+                 invalidateIndex repository+                 add_to_pending repository $ invert p+                 when (Debug `elem` opts) $ putStrLn "About to write the unrevert file."+                 case commute (norevert:>p) of+                   Just (p':>_) -> write_unrevert repository p' rec NilFL+                   Nothing -> write_unrevert repository (norevert+>+p) rec NilFL+                 when (Debug `elem` opts) $ putStrLn "About to apply to the working directory."+                 applyToWorking repository opts (invert p) `catch` \e ->+                     fail ("Unable to apply inverse patch!" ++ show e)+  sync_repo repository+  putStrLn "Finished reverting."+\end{code}+
+ src/Darcs/Commands/Rollback.lhs view
@@ -0,0 +1,160 @@+%  Copyright (C) 2002-2004,2007 David Roundy+%+%  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{rollback}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Rollback ( rollback ) where++import Control.Monad ( when, filterM )+import System.Exit ( exitWith, ExitCode(..) )+import Data.List ( sort )+import Data.Maybe ( isJust )+import System.Directory ( removeFile )++import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers )+import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, get_author,+                         definePatches,+                         working_repo_dir, nocompress,+                         author, patchname_option, ask_long_comment,+                         leave_test_dir, notest, list_registered_files,+                         match_several_or_last, all_interactive, umask_option+                       )+import Darcs.RepoPath ( toFilePath )+import Darcs.Repository ( amInRepository, withRepoLock, ($-), applyToWorking,+                          read_repo, slurp_recorded,+                          tentativelyMergePatches, withGutsOf,+                          finalizeRepositoryChanges, sync_repo )+import Darcs.Patch ( summary, invert, namepatch, effect, fromPrims,+                     sort_coalesceFL, canonize )+import Darcs.Ordered+import Darcs.Hopefully ( n2pia )+import Darcs.Lock ( world_readable_temp )+import Darcs.SlurpDirectory ( empty_slurpy, wait_a_moment )+import Darcs.Match ( first_match )+import Darcs.SelectChanges ( with_selected_last_changes_to_files_reversed,+                             with_selected_last_changes_to_files' )+import Darcs.Commands.Record ( file_exists, get_log )+import Darcs.Commands.Unrecord ( get_last_patches )+import Darcs.Utils ( clarify_errors )+import Printer ( renderString )+import Progress ( debugMessage )+import Darcs.Sealed ( Sealed(..), FlippedSeal(..) )+import IsoDate ( getIsoDateTime )+import Darcs.Gorsvet( invalidateIndex )+#include "impossible.h"++rollback_description :: String+rollback_description =+ "Record a new patch reversing some recorded changes."+\end{code}++If you decide you didn't want to roll back a patch+after all, you can reverse its effect by obliterating the rolled-back patch.++Rollback can actually allow you to roll back a subset of the changes made+by the selected patch or patches.  Many of the options available in+rollback behave similarly to the options for unrecord~\ref{unrecord} and+record~\ref{record}.++\begin{code}+rollback_help :: String+rollback_help =+ "Rollback is used to undo the effects of one or more patches without actually\n"+++ "deleting them.  Instead, it creates a new patch reversing selected portions.\n"+++ "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"+++ "goal) rollback is perfectly safe, since it leaves in the repository a record\n"+++ "of its changes.\n"++rollback :: DarcsCommand+rollback = DarcsCommand {command_name = "rollback",+                         command_help = rollback_help,+                         command_description = rollback_description,+                         command_extra_args = -1,+                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                         command_command = rollback_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = list_registered_files,+                         command_argdefaults = nodefaults,+                         command_advanced_options = [nocompress,umask_option],+                         command_basic_options = [match_several_or_last,+                                                  all_interactive,+                                                  author, patchname_option, ask_long_comment,+                                                  notest, leave_test_dir,+                                                  working_repo_dir]}++rollback_cmd :: [DarcsFlag] -> [String] -> IO ()+rollback_cmd opts args = withRepoLock opts $- \repository -> do+  let (logMessage,_,_) = loggers opts+  rec <- if null args then return empty_slurpy+         else slurp_recorded repository+  files <- sort `fmap` fixSubPaths opts args+  existing_files <- map toFilePath `fmap` filterM (file_exists rec) files+  non_existent_files <- map toFilePath `fmap` filterM (fmap not . file_exists rec) files+  when (not $ null existing_files) $+       logMessage $ "Recording changes in "++unwords existing_files++":\n"+  when (not $ null non_existent_files) $+       logMessage $ "Non existent files or directories: "++unwords non_existent_files++"\n"+  when ((not $ null non_existent_files) && null existing_files) $+       fail "None of the files you specified exist!"+  allpatches <- read_repo repository+  FlippedSeal patches <- return $ if first_match opts+                                  then get_last_patches opts allpatches+                                  else FlippedSeal $ concatRL allpatches+  with_selected_last_changes_to_files_reversed "rollback" opts existing_files+      (reverseRL patches) $+    \ (_ :> ps) ->+    do when (nullFL ps) $ do logMessage "No patches selected!"+                             exitWith ExitSuccess+       definePatches ps+       with_selected_last_changes_to_files' "rollback" opts+               existing_files (concatFL $ mapFL_FL canonize $+                               sort_coalesceFL $ effect ps) $ \ (_:>ps'') ->+         do when (nullFL ps'') $ do logMessage "No changes selected!"+                                    exitWith ExitSuccess+            let make_log = world_readable_temp "darcs-rollback"+                newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))+            --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)+            (name, my_log, logf) <- get_log opts newlog make_log $ invert ps''+            date <- getIsoDateTime+            my_author <- get_author opts+            rbp <- n2pia `fmap` namepatch date name my_author my_log+                                          (fromPrims $ invert ps'')+            debugMessage "Adding rollback patch to repository."+            Sealed pw <- tentativelyMergePatches repository "rollback" (MarkConflicts : opts)+                         NilFL (rbp :>: NilFL)+            debugMessage "Finalizing rollback changes..."+            invalidateIndex repository+            withGutsOf repository $ do+              finalizeRepositoryChanges repository+              debugMessage "About to apply rolled-back changes to working directory."+              -- so work will be more recent than rec:+              revertable $ do wait_a_moment+                              applyToWorking repository opts pw+            when (isJust logf) $ removeFile (fromJust logf)+            sync_repo repository+            logMessage $ "Finished rolling back."+          where revertable x = x `clarify_errors` unlines+                  ["Error applying patch to the working directory.","",+                   "This may have left your working directory an inconsistent",+                   "but recoverable state. If you had no un-recorded changes",+                   "by using 'darcs revert' you should be able to make your",+                   "working directory consistent again."]+\end{code}+
+ src/Darcs/Commands/Send.lhs view
@@ -0,0 +1,444 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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{send}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Send ( send ) where+import Data.Char ( isAlpha, isDigit, isSpace, toLower )+import System.Exit ( exitWith, ExitCode( ExitSuccess ) )+import System.IO.Error ( ioeGetErrorString )+import System.IO ( hClose )+import Control.Monad ( when, unless, forM_ )+import Data.Maybe ( isJust, isNothing )++import Darcs.Commands ( DarcsCommand(..) )+import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile,+                                    Target, OutputAutoName, Output, Context,+                                    DryRun, Verbose, Quiet, Unified+                                  ),+                         fixUrl, definePatches,+                         get_cc, get_author, working_repo_dir,+                         edit_description, logfile, rmlogfile,+                         sign, get_subject, deps_sel, get_in_reply_to,+                         match_several, set_default, output_auto_name,+                         output, cc, subject, target, author, sendmail_cmd,+                         in_reply_to, remote_repo, network_options,+                         all_interactive, get_sendmail_cmd,+                         print_dry_run_message_and_exit,+                         summary, allow_unrelated_repos,+                         from_opt, dry_run, send_to_context,+                       )+import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import Darcs.Repository ( PatchSet, Repository,+                          amInRepository, identifyRepositoryFor, withRepoReadLock, ($-),+                          read_repo, slurp_recorded, prefsUrl, checkUnrelatedRepos )+import Darcs.Patch ( RepoPatch, description, apply_to_slurpy, invert )+import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), unsafeUnRL,+                       mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL )+import Darcs.Patch.Bundle ( make_bundle, scan_context )+import Darcs.Patch.Info ( just_name )+import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist )+import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail )+import ByteStringUtils ( mmapFilePS )+import qualified Data.ByteString.Char8 as BC (unpack)+import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, world_readable_temp, removeFileMayNotExist )+import Darcs.SelectChanges ( with_selected_changes )+import Darcs.Patch.Depends ( get_common_and_uncommon )+import Darcs.Utils ( askUser, catchall, edit_file, formatPath )+import Progress ( debugMessage )+import Darcs.Email ( make_email )+import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc )+import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd,+                        getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd )+import HTTP ( postUrl )+#include "impossible.h"++send_description :: String+send_description =+ "Send by email a bundle of one or more patches."++send_help :: String+send_help =+ "Send is used to prepare a bundle of patches that can be applied to a target\n"+++ "repository.  Send accepts the URL of the repository as an argument.  When\n"+++ "called without an argument, send will use the most recent repository that\n"+++ "was either pushed to, pulled from or sent to.  By default, the patch bundle\n"+++ "is sent by email, although you may save it to a file.\n"+\end{code}++Do not confuse the \verb!--author! options with the return address+that \verb!darcs send! will set for your patch bundle.++For example, if you have two email addresses A and B:+\begin{description}+\item  If you use+\verb!--author A! but your machine is configured to send mail from+address B by default, then the return address on your message will be B.++\item If you use \verb!--from A! and your mail client supports setting the+From: address arbitrarily (some non-Unix-like mail clients, especially,+may not support this), then the return address will be A; if it does+not support this, then the return address will be B.++\item If you supply neither \verb!--from! nor \verb!--author!, then the return+address will be B.+\end{description}++In addition, unless you specify the sendmail command with+\verb!--sendmail-command!, darcs sends email using the default email+command on your computer. This default command is determined by the+\verb!configure! script. Thus, on some non-Unix-like OSes,+\verb!--from! is likely to not work at all.++\begin{code}+send :: DarcsCommand+send = DarcsCommand {command_name = "send",+                     command_help = send_help,+                     command_description = send_description,+                     command_extra_args = 1,+                     command_extra_arg_help = ["[REPOSITORY]"],+                     command_command = send_cmd,+                     command_prereq = amInRepository,+                     command_get_arg_possibilities = get_preflist "repos",+                     command_argdefaults = defaultrepo,+                     command_advanced_options = [logfile, rmlogfile,+                                                 remote_repo,+                                                 send_to_context] +++                                                network_options,+                     command_basic_options = [match_several, deps_sel,+                                              all_interactive,+                                              from_opt, author,+                                              target,cc,subject, in_reply_to,+                                              output,output_auto_name,sign]+                                              ++dry_run++[summary,+                                              edit_description,+                                              set_default, working_repo_dir,+                                              sendmail_cmd,+                                              allow_unrelated_repos]}++send_cmd :: [DarcsFlag] -> [String] -> IO ()+send_cmd input_opts [""] = send_cmd input_opts []+send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do+  context_ps <- the_context input_opts+  case context_ps of+    Just them -> send_to_them repository input_opts [] "CONTEXT" them+    Nothing -> do+        repodir <- fixUrl input_opts unfixedrepodir+        -- Test to make sure we aren't trying to push to the current repo+        here <- getCurrentDirectory+        when (repodir == toFilePath here) $+           fail ("Can't send to current repository! Did you mean send -"++"-context?")+        repo <- identifyRepositoryFor repository repodir+        them <- read_repo repo+        old_default <- get_preflist "defaultrepo"+        set_defaultrepo repodir input_opts+        when (old_default == [repodir] && not (Quiet `elem` input_opts)) $+             putStrLn $ "Creating patch to "++formatPath repodir++"..."+        wtds <- decide_on_behavior input_opts repo+        send_to_them repository input_opts wtds repodir them+    where the_context [] = return Nothing+          the_context (Context foo:_)+              = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo)+          the_context (_:fs) = the_context fs+send_cmd _ _ = impossible++send_to_them :: RepoPatch p => Repository p -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p -> IO ()+send_to_them repo opts wtds their_name them = do+  let am_verbose = Verbose `elem` opts+      am_quiet = Quiet `elem` opts+      putVerbose s = when am_verbose $ putDocLn s+      putInfo s = when (not am_quiet) $ putStrLn s+      patch_desc p = just_name $ info p+      make_fname tbs = patch_filename $ patch_desc $ headFL tbs+      headFL (x:>:_) = x+      headFL _ = impossible+  us <- read_repo repo+  case get_common_and_uncommon (us, them) of+    (common, us' :\/: _) -> do+     checkUnrelatedRepos opts common us them+     case us' of+         NilRL:<:NilRL -> do putInfo "No recorded local changes to send!"+                             exitWith ExitSuccess+         _ -> putVerbose $ text "We have the following patches to send:"+                        $$ (vcat $ mapRL description $ head $ unsafeUnRL us')+     s <- slurp_recorded repo+     let our_ps = reverseRL $ head $ unsafeUnRL us'+     with_selected_changes "send" opts our_ps $+      \ (to_be_sent :> _) -> do+      print_dry_run_message_and_exit "send" opts to_be_sent+      when (nullFL to_be_sent) $ do+          putInfo "You don't want to send any patches, and that's fine with me!"+          exitWith ExitSuccess+      definePatches to_be_sent+      bundle <- signString opts $ make_bundle (Unified:opts)+                (fromJust $ apply_to_slurpy+                 (invert $+                  mapRL_RL hopefully $ head $ unsafeUnRL us') s)+                common (mapFL_FL hopefully to_be_sent)+      let outname = get_output opts (make_fname to_be_sent)+      case outname of+        Just fname -> do (d,f) <- get_description opts to_be_sent+                         let putabs a = do writeDocBinFile a (d $$ bundle)+                                           putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."+                             putstd = putDoc (d $$ bundle)+                         useAbsoluteOrStd putabs putstd fname+                         cleanup f+        Nothing ->+         let+           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patch_desc p) 57+           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patch_desc p) 43 +++                            " (and " ++ show (lengthFL ps) ++ " more)"+           auto_subject _ = error "Tried to get a name from empty patch list."+           trim st n = if length st <= n then st+                       else take (n-3) st ++ "..."+           in do+           thetargets <- get_targets wtds+           from <- get_author opts+           let thesubject = case get_subject opts of+                            Nothing -> auto_subject to_be_sent+                            Just subj -> subj+           (mailcontents, mailfile) <- get_description opts to_be_sent+           let body = make_email their_name+                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . get_in_reply_to $ opts)+                        (Just mailcontents)+                        bundle+                        (Just $ make_fname to_be_sent)+               contentAndBundle = Just (mailcontents, bundle)+               +               sendmail = do+                 sm_cmd <- get_sendmail_cmd opts+                 (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (get_cc opts)+                               sm_cmd contentAndBundle body >>+                  putInfo ("Successfully sent patch bundle to: "+                            ++ lt [ t | SendMail t <- thetargets ]+                            ++ ccs (get_cc opts) ++"."))+                 `catch` \e -> let msg = "Email body left in " in+                               do case mailfile of+                                    Just mf -> putStrLn $ msg++mf++"."+                                    Nothing -> return ()+                                  fail $ ioeGetErrorString e+               ccs [] = []+               ccs cs  = " and cc'ed " ++ cs++           when (null [ p | Post p <- thetargets]) sendmail+           nbody <- withOpenTemp $ \ (fh,fn) -> do+               generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (get_cc opts) body+               hClose fh+               mmapFilePS fn+           forM_ [ p | Post p <- thetargets]+             (\url -> do+                putInfo $ "Posting patch to " ++ url+                postUrl url (BC.unpack nbody) "message/rfc822")+             `catch` const sendmail+           cleanup mailfile++      where cleanup (Just mailfile) = when (isNothing (get_fileopt opts) || (RmLogFile `elem` opts)) $+                                      removeFileMayNotExist mailfile+            cleanup Nothing = return ()+            lt [t] = t+            lt [t,""] = t+            lt (t:ts) = t++" , "++lt ts+            lt [] = ""++safeFileChar :: Char -> Char+safeFileChar c | isAlpha c = toLower c+               | isDigit c = c+               | isSpace c = '-'+safeFileChar _ = '_'++patch_filename :: String -> String+patch_filename the_summary = name ++ ".dpatch"+    where name = map safeFileChar the_summary+\end{code}++\begin{options}+--output, --to, --cc+\end{options}++The \verb!--output!, \verb!--output-auto-name!, and \verb!--to! flags determine+what darcs does with the patch bundle after creating it.  If you provide an+\verb!--output!  argument, the patch bundle is saved to that file.  If you+specify \verb!--output-auto-name!, the patch bundle is saved to a file with an+automatically generated name.  If you give one or more \verb!--to! arguments,+the bundle of patches is sent to those locations. The locations may either be email+addresses or urls that the patch should be submitted to via HTTP.++If you don't provide any of these options, darcs will look at the contents of+the \verb!_darcs/prefs/email! file in the target repository (if it exists), and+send the patch by email to that address.  In this case, you may use the+\verb!--cc! option to specify additional recipients without overriding the+default repository email address.++If \texttt{\_darcs/prefs/post} exists in the target repository, darcs will+upload to the URL contained in that file, which may either be a+\texttt{mailto:} URL, or an \texttt{http://} URL.  In the latter case, the+patch is posted to that URL.++If there is no email address associated with the repository, darcs will+prompt you for an email address.++\begin{options}+--subject+\end{options}++Use the \verb!--subject! flag to set the subject of the e-mail to be sent.+If you don't provide a subject on the command line, darcs will make one up+based on names of the patches in the patch bundle.++\begin{options}+--in-reply-to+\end{options}++Use the \verb!--in-reply-to! flag to set the In-Reply-To and References headers+of the e-mail to be sent. By default no additional headers are included so e-mail+will not be treated as reply by mail readers.++\begin{code}++data WhatToDo+    = Post String        -- ^ POST the patch via HTTP+    | SendMail String    -- ^ send patch via email+++decide_on_behavior :: RepoPatch p => [DarcsFlag] -> Repository p -> IO [WhatToDo]+decide_on_behavior opts the_remote_repo =+    case the_targets of+    [] ->+          if isJust $ get_output opts ""+          then return []+          else+          do wtds <- check_post+             unless (null wtds) $ announce_recipients wtds+             return wtds+    ts -> do announce_recipients ts+             return ts+    where the_targets = collect_targets opts+#ifdef HAVE_HTTP+          -- the ifdef above is to so that darcs only checks the remote+          -- _darcs/post if we have an implementation of postUrl.  See+          -- our HTTP module for more details+          check_post = do p <- ((readPost . BC.unpack) `fmap`+                                fetchFilePS (prefsUrl the_remote_repo++"/post")+                                (MaxAge 600)) `catchall` return []+                          emails <- who_to_email+                          return (p++emails)+          readPost p = map pp (lines p) where+            pp ('m':'a':'i':'l':'t':'o':':':s) = SendMail s+            pp s = Post s+#else+          check_post = who_to_email+#endif+          who_to_email =+              do email <- (BC.unpack `fmap`+                           fetchFilePS (prefsUrl the_remote_repo++"/email")+                                       (MaxAge 600))+                          `catchall` return ""+                 if '@' `elem` email then return . map SendMail $ lines email+                                     else return []+          putInfoLn s = unless (Quiet `elem` opts) $ putStrLn s+          announce_recipients emails =+            let pn (SendMail s) = s+                pn (Post p) = p+            in if DryRun `elem` opts+            then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails)+            else when (null the_targets) $+                 putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails)++get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd+get_output (Output a:_) _ = return a+get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f+get_output (_:flags) f = get_output flags f+get_output [] _ = Nothing++get_targets :: [WhatToDo] -> IO [WhatToDo]+get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? "+get_targets wtds = return wtds++collect_targets :: [DarcsFlag] -> [WhatToDo]+collect_targets flags = [ f t | Target t <- flags ] where+    f url@('h':'t':'t':'p':':':_) = Post url+    f em = SendMail em+++\end{code}++\begin{options}+--matches, --patches, --tags, --no-deps+\end{options}++The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!+options can be used to select which patches to send, as described in+subsection~\ref{selecting}.++\begin{options}+--edit-description+\end{options}++If you want to include a description or explanation along with the bundle+of patches, you need to specify the \verb!--edit-description! flag, which+will cause darcs to open up an editor with which you can compose a message+to go along with your patches.++\begin{options}+--sendmail-command+\end{options}++If you want to use a command different from the default one for sending email,+you need to specify a command line with the \verb!--sendmail-command! option. The+command line can contain some format specifiers which are replaced by the actual+values. Accepted format specifiers are \verb!%s! for subject, \verb!%t! for to,+\verb!%c! for cc, \verb!%b! for the body of the mail, \verb!%f! for from, \verb!%a!+for the patch bundle and the same specifiers in uppercase for the URL-encoded values.+Additionally you can add \verb!%<! to the end of the command line if the command+expects the complete email message on standard input. E.g.\ the command lines for evolution+and msmtp look like this:++\begin{verbatim}+evolution "mailto:%T?subject=%S&attach=%A&cc=%C&body=%B"+msmtp -t %<+\end{verbatim}++\begin{code}+get_description :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) -> IO (Doc, Maybe String)+get_description opts patches =+    case get_filename of+        Just f -> do file <- f+                     when (EditDescription `elem` opts) $ do+                       when (isNothing $ get_fileopt opts) $+                            writeDocBinFile file patchdesc+                       debugMessage $ "About to edit file " ++ file+                       edit_file file+                       return ()+                     doc <- readDocBinFile file+                     return (doc, Just file)+        Nothing -> return (patchdesc, Nothing)+    where patchdesc = vsep $ mapFL description patches+          get_filename = case get_fileopt opts of+                                Just f -> Just $ return $ toFilePath f+                                Nothing -> if EditDescription `elem` opts+                                              then Just tempfile+                                              else Nothing+          tempfile = world_readable_temp "darcs-temp-mail"++get_fileopt :: [DarcsFlag] -> Maybe AbsolutePath+get_fileopt (LogFile f:_) = Just f+get_fileopt (_:flags) = get_fileopt flags+get_fileopt [] = Nothing+\end{code}
+ src/Darcs/Commands/SetPref.lhs view
@@ -0,0 +1,108 @@+%  Copyright (C) 2003 David Roundy+%+%  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{setpref}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.SetPref ( setpref ) where++import System.Exit ( exitWith, ExitCode(..) )+import Control.Monad (when)++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, working_repo_dir, umask_option )+import Darcs.Repository ( amInRepository, add_to_pending, withRepoLock, ($-) )+import Darcs.Patch ( changepref )+import Darcs.Ordered ( FL(..) )+import Darcs.Repository.Prefs ( get_prefval, change_prefval, )+import English ( orClauses )+#include "impossible.h"++-- | A list of all valid preferences for @_darcs/prefs/prefs@.+valid_pref_data :: [(String, String)] -- ^ (name, one line description)+valid_pref_data =+    [("test", "a shell command that runs regression tests"),+     ("predist", "a shell command to run before `darcs dist'"),+     ("boringfile", "the path to a version-controlled boring file"),+     ("binariesfile", "the path to a version-controlled binaries file")]++valid_prefs :: [String]+valid_prefs = map fst valid_pref_data++setpref_description :: String+setpref_description =+    "Set a preference (" ++ orClauses valid_prefs ++ ")."++setpref_help :: String+setpref_help =+ "When working on project with multiple repositories and contributors,\n" +++ "it is sometimes desirable for a preference to be set consistently\n" +++ "project-wide.  This is achieved by treating a preference set with\n" +++ "`darcs setpref' as an unrecorded change, which can then be recorded\n" +++ "and then treated like any other patch.\n" +++ "\n" +++ "Valid preferences are:\n" +++ "\n" +++ unlines ["  "++x++" -- "++y | (x,y) <- valid_pref_data] +++ "\n" +++ "For example, a project using GNU autotools, with a `make test' target\n" +++ "to perform regression tests, might enable Darcs' integrated regression\n" +++ "testing with the following command:\n" +++ "\n" +++ "  darcs setpref test 'autoconf && ./configure && make && make test'\n" +++ "\n" +++ "Note that merging is not currently implemented for preferences: if two\n" +++ "patches attempt to set the same preference, the last patch applied to\n" +++ "the repository will always take precedence.  This is considered a\n" +++ "low-priority bug, because preferences are seldom set.\n"++setpref :: DarcsCommand+setpref = DarcsCommand {command_name = "setpref",+                        command_help = setpref_help,+                        command_description = setpref_description,+                        command_extra_args = 2,+                        command_extra_arg_help = ["<PREF>",+                                                  "<VALUE>"],+                        command_command = setpref_cmd,+                        command_prereq = amInRepository,+                        command_get_arg_possibilities = return valid_prefs,+                        command_argdefaults = nodefaults,+                        command_advanced_options = [umask_option],+                        command_basic_options =+                            [working_repo_dir]}++setpref_cmd :: [DarcsFlag] -> [String] -> IO ()+setpref_cmd opts [pref,val] = withRepoLock opts $- \repository -> do+  when (' ' `elem` pref) $ do+    putStrLn $ "'"++pref+++               "' is not a valid preference name:  no spaces allowed!"+    exitWith $ ExitFailure 1+  when (not $ pref `elem` valid_prefs) $ do+    putStrLn $ "'"++pref++"' is not a valid preference name!"+    putStrLn $ "Try one of: " ++ unwords valid_prefs+    exitWith $ ExitFailure 1+  oval <- get_prefval pref+  old <- case oval of Just v -> return v+                      Nothing -> return ""+  change_prefval pref old val+  putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"+  add_to_pending repository (changepref pref old val :>: NilFL)+setpref_cmd _ _ = impossible+\end{code}+
+ src/Darcs/Commands/Show.lhs view
@@ -0,0 +1,77 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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.++\begin{code}+module Darcs.Commands.Show ( show_command, list, query ) where++import Darcs.Commands ( DarcsCommand(..),+                        CommandControl(Command_data, Hidden_command),+                        command_alias,+                      )+import Darcs.Commands.ShowAuthors ( show_authors )+import Darcs.Commands.ShowBug ( show_bug )+import Darcs.Commands.ShowContents ( show_contents )+import Darcs.Commands.ShowFiles ( show_files, show_manifest )+import Darcs.Commands.ShowTags ( show_tags )+import Darcs.Commands.ShowRepo ( show_repo )+import Darcs.Commands.ShowIndex ( show_index, show_pristine )+import Darcs.Repository ( amInRepository )++show_description :: String+show_description = "Show information which is stored by darcs."++show_help :: String+show_help =+ "Use the --help option with the subcommands to obtain help for\n"+++ "subcommands (for example, \"darcs show files --help\").\n" +++ "\n" +++ "In previous releases, this command was called `darcs query'.\n" +++ "Currently this is a deprecated alias.\n"++show_command :: DarcsCommand+show_command = SuperCommand {command_name = "show",+                      command_help = show_help,+                      command_description = show_description,+                      command_prereq = amInRepository,+                      command_sub_commands = [Hidden_command show_bug,+                                              Command_data show_contents,+                                              Command_data show_files, Hidden_command show_manifest,+                                              Command_data show_index,+                                              Command_data show_pristine,+                                              Command_data show_repo,+                                              Command_data show_authors,+                                              Command_data show_tags]+                     }++query :: DarcsCommand+query = command_alias "query" show_command++list :: DarcsCommand+list = command_alias "list" show_command+\end{code}++\subsection{darcs show}++The show command provides access to several subcommands which can be+used to investigate the state of a repository.++\input{Darcs/Commands/ShowAuthors.lhs}+\input{Darcs/Commands/ShowContents.lhs}+\input{Darcs/Commands/ShowFiles.lhs}+\input{Darcs/Commands/ShowTags.lhs}+\input{Darcs/Commands/ShowRepo.lhs}+
+ src/Darcs/Commands/ShowAuthors.lhs view
@@ -0,0 +1,160 @@+%  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael+%+%  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{show authors}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+module Darcs.Commands.ShowAuthors ( show_authors ) where++import Control.Arrow ((&&&), (***))+import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf )+import Data.Ord (comparing)+import Data.Char ( toLower, isSpace )+import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )++import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.External ( viewDoc )+import Darcs.Hopefully ( info )+import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) )+import Darcs.Patch.Info ( pi_author )+import Darcs.Ordered ( mapRL, concatRL )+import Printer ( text )+import Data.Function (on)++show_authors_description :: String+show_authors_description = "List authors by patch count."++show_authors_help :: String+show_authors_help =+ "The `darcs show authors' command lists the authors of the current\n" +++ "repository, sorted by the number of patches contributed.  With the\n" +++ "--verbose option, this command simply lists the author of each patch\n" +++ "(without aggregation or sorting).\n" +++ "\n" +++ "An author's name or email address may change over time.  To tell Darcs\n" +++ "when multiple author strings refer to the same individual, create an\n" +++ "`.authorspellings' file in the root of the working tree.  Each line in\n" +++ "this file begins with an author's canonical name and address, and may\n" +++ "be followed by a comma and zero or more extended regular expressions,\n" +++ "separated by commas.  Blank lines and lines beginning with two\n" +++ "hyphens, are ignored.\n" +++ "\n" +++ "Any patch with an author string that matches the canonical address or\n" +++ "any of the associated regexps is considered to be the work of that\n" +++ "author.  All matching is case-insensitive and partial (it can match a\n" +++ "substring).\n" +++ "\n" +++ "Currently this canonicalization step is done only in `darcs show\n" +++ "authors'.  Other commands, such as `darcs changes' use author strings\n" +++ "verbatim.\n" +++ "\n" +++ "An example .authorspelling file is:\n" +++ "\n" +++ "    -- This is a comment.\n" +++ "    Fred Nurk <fred@example.com>\n" +++ "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n"++show_authors :: DarcsCommand+show_authors = DarcsCommand {+  command_name = "authors",+  command_help = show_authors_help,+  command_description = show_authors_description,+  command_extra_args = 0,+  command_extra_arg_help = [],+  command_command = authors_cmd,+  command_prereq = amInRepository,+  command_get_arg_possibilities = return [],+  command_argdefaults = nodefaults,+  command_advanced_options = [],+  command_basic_options = [working_repo_dir] }++authors_cmd :: [DarcsFlag] -> [String] -> IO ()+authors_cmd opts _ = withRepository opts $- \repository -> do+  patches <- read_repo repository+  spellings <- compiled_author_spellings+  let authors = mapRL (pi_author . info) $ concatRL patches+  viewDoc $ text $ unlines $+   if Verbose `elem` opts+    then authors+    else -- A list of the form ["<count> <canonical name>"]...++      -- Turn the final result into a list of strings.+      map (\ (count, name) -> show count ++ "\t" ++ name) $+      -- Sort by descending patch count.+      reverse $ sortBy (comparing fst) $+      -- Combine duplicates from a list [(count, canonized name)]+      -- with duplicates canonized names (see next comment).+      map ((sum *** head) . unzip) $+      groupBy ((==) `on` snd) $+      sortBy  (comparing snd) $+      -- Because it would take a long time to canonize "foo" into+      -- "foo <foo@bar.baz>" once per patch, the code below+      -- generates a list [(count, canonized name)].+      map (length &&& (canonize_author spellings . head)) $+      group $ sort authors++canonize_author :: [(String,[Regex])] -> String -> String+canonize_author [] a = a+canonize_author spellings a = safehead a $ canonicalsfor a+    where+      safehead x xs = if null xs then x else head xs+      canonicalsfor s = map fst $ filter (ismatch s) spellings+      ismatch s (canonical,regexps) =+          (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps)+          where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical++contains :: String -> String -> Bool+a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower++contains_regex :: String -> Regex -> Bool+a `contains_regex` r = case matchRegex r a of+                         Just _ -> True+                         _ -> False++compiled_author_spellings :: IO [(String,[Regex])]+compiled_author_spellings = do+  ss <- author_spellings_from_file+  return $ map compile $ ss+    where+      compile [] = error "each author spelling should contain at least the canonical form"+      compile (canonical:pats) = (canonical, map mkregex pats)+      mkregex pat = mkRegexWithOpts pat True False++authorspellingsfile :: FilePath+authorspellingsfile = ".authorspellings"++author_spellings_from_file :: IO [[String]]+author_spellings_from_file = do+  s <- readFile -- ratify readFile: never unlinked from within darcs+         authorspellingsfile `catch` (\_ -> return "")+  let noncomments = filter (not . ("--" `isPrefixOf`)) $+                    filter (not . null) $ map strip $ lines s+  return $ map (map strip . split_on ',') noncomments++split_on :: Eq a => a -> [a] -> [[a]]+split_on e l =+    case dropWhile (e==) l of+      [] -> []+      l' -> first : split_on e rest+        where+          (first,rest) = break (e==) l'++strip :: String -> String+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse++\end{code}
+ src/Darcs/Commands/ShowBug.lhs view
@@ -0,0 +1,53 @@+%  Copyright (C) 2007 Eric Kow+%+%  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{show bug}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.ShowBug ( show_bug ) where++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, working_repo_dir )+import Darcs.Repository ( findRepository )+#include "impossible.h"++show_bug_description :: String+show_bug_description = "Simulate a run-time failure."++show_bug_help :: String+show_bug_help =+  "Show bug can be used to see what darcs would show you if you encountered.\n"+  ++"a bug in darcs.\n"++show_bug :: DarcsCommand+show_bug = DarcsCommand {command_name = "bug",+                         command_help = show_bug_help,+                         command_description = show_bug_description,+                         command_extra_args = 0,+                         command_extra_arg_help = [],+                         command_command = show_bug_cmd,+                         command_prereq = findRepository,+                         command_get_arg_possibilities = return [],+                         command_argdefaults = nodefaults,+                         command_advanced_options = [],+                         command_basic_options = [working_repo_dir]}++show_bug_cmd :: [DarcsFlag] -> [String] -> IO ()+show_bug_cmd _ _ = bug "This is actually a fake bug in darcs."+\end{code}
+ src/Darcs/Commands/ShowContents.lhs view
@@ -0,0 +1,72 @@+%  Copyright (C) 2007 Eric Kow+%+%  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{show contents}+\begin{code}+module Darcs.Commands.ShowContents ( show_contents ) where++import Control.Monad ( filterM )+import System.IO ( stdout )+import System.FilePath.Posix ( takeFileName )++import qualified Data.ByteString as B+import Workaround ( getCurrentDirectory )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, match_one,+                         working_repo_dir, fixSubPaths )+import Darcs.RepoPath ( toFilePath, sp2fn )+import Darcs.IO ( mReadFilePS, mDoesFileExist )+import Darcs.Match ( get_partial_nonrange_match, have_nonrange_match )+import Darcs.Repository ( withRepository, ($-), findRepository,+                          createPartialsPristineDirectoryTree )+import Darcs.Lock ( withTempDir )++show_contents_description :: String+show_contents_description = "Outputs a specific version of a file."++show_contents_help :: String+show_contents_help =+  "Show contents can be used to display an earlier version of some file(s).\n"+++  "If you give show contents no version arguments, it displays the recorded\n"+++  "version of the file(s).\n"++show_contents :: DarcsCommand+show_contents = DarcsCommand {command_name = "contents",+                              command_help = show_contents_help,+                              command_description = show_contents_description,+                              command_extra_args = -1,+                              command_extra_arg_help+                                    = ["[FILE]..."],+                              command_command = show_contents_cmd,+                              command_prereq = findRepository,+                              command_get_arg_possibilities = return [],+                              command_argdefaults = nodefaults,+                              command_advanced_options = [],+                              command_basic_options = [match_one, working_repo_dir]}++show_contents_cmd :: [DarcsFlag] -> [String] -> IO ()+show_contents_cmd opts args = withRepository opts $- \repository -> do+  formerdir <- getCurrentDirectory+  path_list <- map sp2fn `fmap` fixSubPaths opts args+  thename <- return $ takeFileName formerdir+  withTempDir thename $ \dir -> do+     if have_nonrange_match opts+        then get_partial_nonrange_match repository opts path_list+        else createPartialsPristineDirectoryTree repository path_list (toFilePath dir)+     filterM mDoesFileExist path_list >>= mapM_ (\f -> mReadFilePS f >>= B.hPut stdout)+\end{code}
+ src/Darcs/Commands/ShowFiles.lhs view
@@ -0,0 +1,99 @@+%  Copyright (C) 2005 Florian Weimer+%+%  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{show files}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+#include "gadts.h"+module Darcs.Commands.ShowFiles ( show_files, show_manifest ) where+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,+                        files, directories, pending, nullFlag )+import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Repository ( Repository, amInRepository, slurp_pending, slurp_recorded,+                          withRepository )+import Darcs.Patch ( RepoPatch )+import Darcs.SlurpDirectory ( Slurpy, list_slurpy, list_slurpy_files, list_slurpy_dirs )++show_files_description :: String+show_files_description = "Show version-controlled files in the working copy."++show_files_help :: String+show_files_help =+ "The `darcs show files' command lists those files and directories in\n" +++ "the working tree that are under version control.  This command is\n" +++ "primarily for scripting purposes; end users will probably want `darcs\n" +++ "whatsnew --summary'.\n" +++ "\n" +++ "A file is `pending' if it has been added but not recorded.  By\n" +++ "default, pending files (and directories) are listed; the --no-pending\n" +++ "option prevents this.\n" +++ "\n" +++ "By default `darcs show files' lists both files and directories, but\n" +++ "the alias `darcs show manifest' only lists files.  The --files,\n" +++ "--directories, --no-files and --no-directories modify this behaviour.\n" +++ "\n" +++ "By default entries are one-per-line (i.e. newline separated).  This\n" +++ "can cause problems if the files themselves contain newlines or other\n" +++ "control characters.  To get aroudn this, the --null option uses the\n" +++ "null character instead.  The script interpreting output from this\n" +++ "command needs to understand this idiom; `xargs -0' is such a command.\n" +++ "\n" +++ "For example, to list version-controlled files by size:\n" +++ "\n" +++ "    darcs show files -0 | xargs -0 ls -ldS\n"++show_files :: DarcsCommand+show_files = DarcsCommand {+  command_name = "files",+  command_help = show_files_help,+  command_description = show_files_description,+  command_extra_args = 0,+  command_extra_arg_help = [],+  command_command = manifest_cmd to_list_files,+  command_prereq = amInRepository,+  command_get_arg_possibilities = return [],+  command_argdefaults = nodefaults,+  command_advanced_options = [],+  command_basic_options = [files, directories, pending, nullFlag,+                          working_repo_dir] }++show_manifest :: DarcsCommand+show_manifest = command_alias "manifest" show_files {+  command_command = manifest_cmd to_list_manifest+}++to_list_files, to_list_manifest :: [DarcsFlag] -> Slurpy -> [FilePath]+to_list_files    opts = files_dirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts)+to_list_manifest opts = files_dirs (NoFiles `notElem` opts) (Directories `elem` opts)++files_dirs :: Bool -> Bool -> Slurpy -> [FilePath]+files_dirs False False = \_ -> []+files_dirs False True  = list_slurpy_dirs+files_dirs True  False = list_slurpy_files+files_dirs True  True  = list_slurpy++manifest_cmd :: ([DarcsFlag] -> Slurpy -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()+manifest_cmd to_list opts _ = do+    list <- (to_list opts) `fmap` withRepository opts slurp+    mapM_ output list+    where slurp :: RepoPatch p => Repository p C(r u r) -> IO Slurpy+          slurp = if NoPending `notElem` opts+                  then slurp_pending else slurp_recorded+          output_null name = do { putStr name ; putChar '\0' }+          output = if NullFlag `elem` opts then output_null else putStrLn+\end{code}
+ src/Darcs/Commands/ShowIndex.lhs view
@@ -0,0 +1,94 @@+% Copyright (C) 2009 Petr Rockai+%+% Permission is hereby granted, free of charge, to any person+% obtaining a copy of this software and associated documentation+% files (the "Software"), to deal in the Software without+% restriction, including without limitation the rights to use, copy,+% modify, merge, publish, distribute, sublicense, and/or sell copies+% of the Software, and to permit persons to whom the Software is+% furnished to do so, subject to the following conditions:+%+% The above copyright notice and this permission notice shall be+% included in all copies or substantial portions of the Software.+%+% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+% EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+% MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+% NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+% BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+% ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+% CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+% SOFTWARE.++\darcsCommand{show index}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+#include "gadts.h"+module Darcs.Commands.ShowIndex ( show_index, show_pristine ) where+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir,+                        files, directories, nullFlag )+import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias )+import Darcs.Repository ( amInRepository, withRepository, ($-) )++import Darcs.Gorsvet( checkIndex, readIndex )+import Storage.Hashed( readDarcsPristine, floatPath )+import Storage.Hashed.Darcs( darcsFormatHash )+import Storage.Hashed.Tree( list, expand, itemHash, TreeItem( SubTree ) )+import Storage.Hashed.AnchoredPath( anchorPath )++import qualified Data.ByteString.Char8 as BS++show_index :: DarcsCommand+show_index = DarcsCommand {+  command_name = "index",+  command_description = "Dump contents of working tree index.",+  command_help =+      "The `darcs show index' command lists all version-controlled files and " +++      "directories along with their hashes as stored in _darcs/index. " +++      "For files, the fields correspond to file size, sha256 of the current " +++      "file content and the filename.",+  command_extra_args = 0,+  command_extra_arg_help = [],+  command_command = show_index_cmd,+  command_prereq = amInRepository,+  command_get_arg_possibilities = return [],+  command_argdefaults = nodefaults,+  command_advanced_options = [],+  command_basic_options = [files, directories, nullFlag, working_repo_dir] }++show_pristine :: DarcsCommand+show_pristine = command_alias "pristine" show_index {+  command_command = show_pristine_cmd,+  command_description = "Dump contents of pristine cache.",+  command_help =+      "The `darcs show pristine' command lists all version-controlled files " +++      "and directories along with the hashes of their pristine copies. " +++      "For files, the fields correspond to file size, sha256 of the pristine " +++      "file content and the filename." }++dump opts tree = do+  let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0'+           | otherwise = putStrLn+      output (p, i) = do+        let hash = case itemHash i of+                     Just h -> BS.unpack $ darcsFormatHash h+                     Nothing -> "(no hash available)"+            path = anchorPath "" p+            isdir = case i of+                      SubTree _ -> "/"+                      _ -> ""+        line $ hash ++ " " ++ path ++ isdir+  x <- expand tree+  mapM_ output $ (floatPath ".", SubTree x) : list x++show_index_cmd :: [DarcsFlag] -> [String] -> IO ()+show_index_cmd opts _ = withRepository opts $- \repo -> do+  checkIndex repo+  readIndex >>= dump opts++show_pristine_cmd :: [DarcsFlag] -> [String] -> IO ()+show_pristine_cmd opts _ = withRepository opts $- \repo -> do+  readDarcsPristine "." >>= dump opts++\end{code}
+ src/Darcs/Commands/ShowRepo.lhs view
@@ -0,0 +1,178 @@+%  Copyright (C) 2007 Kevin Quick+%+%  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{show repo}++The \verb!show repo! displays information about+the current repository: the location, the type, etc.++This is provided as informational output for two purposes: curious+users and scripts invoking darcs.  For the latter, this information+can be parsed to facilitate the script; for example,+\verb!darcs show repo | grep Root: | awk {print $2}!+can be used to locate the+top-level \verb!_darcs! directory from anyplace within a darcs repository+working directory.++\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+#include "gadts.h"+module Darcs.Commands.ShowRepo ( show_repo ) where++import Data.Char ( toLower, isSpace )+import Data.List ( intersperse )+import Control.Monad ( when, unless )+import Text.Html ( tag, stringToHtml )+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, files, xmloutput )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Repository ( withRepository, ($-), amInRepository, read_repo )+import Darcs.Repository.Internal ( Repository(..), RepoType(..) )+import Darcs.Repository.Format ( RepoFormat(..) )+import Darcs.Repository.Prefs ( get_preflist )+import Darcs.Repository.Motd ( get_motd )+import Darcs.Patch ( RepoPatch )+import Darcs.Ordered ( lengthRL, concatRL )+import qualified Data.ByteString.Char8 as BC  (unpack)++show_repo_help :: String+show_repo_help =+ "The repo command displays information about the current repository\n" +++ "(location, type, etc.).  Some of this information is already available\n" +++ "by inspecting files within the _darcs directory and some is internal\n" +++ "information that is informational only (i.e. for developers).  This\n" +++ "command collects all of the repository information into a readily\n" +++ "available source.\n"++show_repo_description :: String+show_repo_description = "Show repository summary information"++show_repo :: DarcsCommand+show_repo = DarcsCommand { command_name = "repo",+                           command_help = show_repo_help,+                           command_description = show_repo_description,+                           command_extra_args = 0,+                           command_extra_arg_help = [],+                           command_command = repo_cmd,+                           command_prereq = amInRepository,+                           command_get_arg_possibilities = return [],+                           command_argdefaults = nodefaults,+                           command_advanced_options = [],+                           command_basic_options = [working_repo_dir, files, xmloutput] }+\end{code}++\begin{options}+--files, --no-files+\end{options}++If the \verb!--files! option is specified (the default), then the+\verb!show repo! operation will read patch information from the+repository and display the number of patches in the repository.  The+\verb!--no-files! option can be used to suppress this operation (and+improve performance).++\begin{code}+repo_cmd :: [DarcsFlag] -> [String] -> IO ()+repo_cmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr+                  in withRepository opts $- \repository -> showRepo (putInfo put_mode) repository+\end{code}++\begin{options}+--human-readable, --xml-output+\end{options}++By default, the \verb!show repo! displays output in human readable+form, but the \verb!--xml-output! option can be used to obtain+XML-formatted to facilitate regular parsing by external tools.++\begin{code}+-- Some convenience functions to output a labelled text string or an+-- XML tag + value (same API).  If no value, output is suppressed+-- entirely.  Borrow some help from Text.Html to perform XML output.++type ShowInfo = String -> String -> String++showInfoXML :: ShowInfo+showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i++safeTag :: String -> String+safeTag [] = []+safeTag (' ':cs) = safeTag cs+safeTag ('#':cs) = "num_" ++ (safeTag cs)+safeTag (c:cs) = toLower c : safeTag cs++-- labelled strings: labels are right-aligned at 14 characters;+-- subsequent lines in multi-line output are indented accordingly.+showInfoUsr :: ShowInfo+showInfoUsr t i = (replicate (14 - length(t)) ' ') ++ t ++ ": " +++                  (concat $ intersperse ('\n' : (replicate 16 ' ')) $ lines i) ++ "\n"++type PutInfo = String -> String -> IO ()+putInfo :: ShowInfo -> PutInfo+putInfo m t i = unless (null i) (putStr $ m t i)++-- Primary show-repo operation.  Determines ordering of output for+-- sub-displays.  The `out' argument is one of the above operations to+-- output a labelled text string or an XML tag and contained value.++showRepo :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()+showRepo out r@(Repo loc opts rf rt) = do+         when (XMLOutput `elem` opts) (putStr "<repository>\n")+         showRepoType out rt+         when (Verbose `elem` opts) (out "Show" $ show r)+         showRepoFormat out rf+         out "Root" loc+         showRepoAux out rt+         showRepoPrefs out+         unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show ))+         showRepoMOTD out r+         when (XMLOutput `elem` opts) (putStr "</repository>\n")++-- Most of the actual elements being displayed are part of the Show+-- class; that's fine for a Haskeller, but not for the common user, so+-- the routines below work to provide more human-readable information+-- regarding the repository elements.++showRepoType :: PutInfo -> RepoType p -> IO ()+showRepoType out (DarcsRepository _ _) = out "Type" "darcs"++showRepoFormat :: PutInfo -> RepoFormat -> IO ()+showRepoFormat out (RF rf) = out "Format" $+    concat $ intersperse ", " (map (concat . intersperse "|" . map BC.unpack) rf)++showRepoAux :: PutInfo -> RepoType p -> IO ()+showRepoAux out (DarcsRepository pris cs) =+    do out "Pristine" $ show pris+       out "Cache" $ concat $ intersperse ", " $ lines $ show cs+++showRepoPrefs :: PutInfo -> IO ()+showRepoPrefs out = do+    get_preflist "prefs" >>= mapM_ prefOut+    get_preflist "author" >>= out "Author" . unlines+    get_preflist "defaultrepo" >>= out "Default Remote" . unlines+  where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace++showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()+showRepoMOTD out (Repo loc _ _ _) = get_motd loc >>= out "MOTD" . BC.unpack++-- Support routines to provide information used by the PutInfo operations above.++numPatches :: RepoPatch p => Repository p C(r u r) -> IO Int+numPatches r = read_repo r >>= (return . lengthRL . concatRL)++\end{code}
+ src/Darcs/Commands/ShowTags.lhs view
@@ -0,0 +1,80 @@+%  Copyright (C) 2007 Florian Weimer+%+%  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{show tags}+\begin{code}+module Darcs.Commands.ShowTags ( show_tags ) where+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Hopefully ( info )+import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) )+import Darcs.Patch.Info ( pi_tag )+import Darcs.Ordered ( mapRL, concatRL )+import System.IO ( stderr, hPutStrLn )+-- import Printer ( renderPS )++show_tags_description :: String+show_tags_description = "Show all tags in the repository."++show_tags_help :: String+show_tags_help =+ "The tags command writes a list of all tags in the repository to standard\n"+++ "output.\n" +++ "\n" +++ "Tab characters (ASCII character 9) in tag names are changed to spaces\n" +++ "for better interoperability with shell tools.  A warning is printed if\n" +++ "this happens."++show_tags :: DarcsCommand+show_tags = DarcsCommand {+  command_name = "tags",+  command_help = show_tags_help,+  command_description = show_tags_description,+  command_extra_args = 0,+  command_extra_arg_help = [],+  command_command = tags_cmd,+  command_prereq = amInRepository,+  command_get_arg_possibilities = return [],+  command_argdefaults = nodefaults,+  command_advanced_options = [],+  command_basic_options = [working_repo_dir] }++tags_cmd :: [DarcsFlag] -> [String] -> IO ()+tags_cmd opts _ = withRepository opts $- \repository -> do+  patches <- read_repo repository+  sequence_ $ mapRL process $ concatRL patches+  where process hp =+            case pi_tag $ info hp of+              Just t -> do+                 t' <- normalize t t False+                 putStrLn t'+              Nothing -> return ()+        normalize :: String -> String -> Bool -> IO String+        normalize _ [] _ = return []+        normalize t (x : xs) flag =+            if x == '\t' then do+                  if flag+                    then return ()+                    else hPutStrLn stderr+                             ("warning: tag with TAB character: " ++ t)+                  rest <- (normalize t xs True)+                  return $ ' ' : rest+            else do+                  rest <- (normalize t xs flag)+                  return $ x : rest++\end{code}
+ src/Darcs/Commands/Tag.lhs view
@@ -0,0 +1,127 @@+%  Copyright (C) 2003-2004 David Roundy+%+%  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{tag}+\begin{code}+module Darcs.Commands.Tag ( tag ) where+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(DarcsCommand, command_name, command_help,+                        command_description, command_extra_args,+                        command_extra_arg_help, command_command, command_prereq,+                        command_get_arg_possibilities, command_argdefaults,+                        command_advanced_options, command_basic_options),+                        nodefaults )+import Darcs.Arguments ( nocompress, umask_option, patchname_option, author,+                         checkpoint, pipe_interactive, ask_long_comment,+                         working_repo_dir, get_author )+import Darcs.Hopefully ( n2pia )+import Darcs.Repository ( amInRepository, withRepoLock, ($-), read_repo,+                    tentativelyAddPatch, finalizeRepositoryChanges, +                  )+import Darcs.Repository.Checkpoint ( write_recorded_checkpoint )+import Darcs.Patch ( infopatch, identity, adddeps )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.Depends ( get_tags_right )+import Darcs.Commands.Record ( get_date, get_log )+import Darcs.Ordered ( FL(..) )+import Darcs.Lock ( world_readable_temp )+import Darcs.Flags ( DarcsFlag(..) )+import System.IO ( hPutStr, stderr )++tag_description :: String+tag_description = "Name the current repository state for future reference."++tag_help :: String+tag_help =+ "The `darcs tag' command names the current repository state, so that it\n" +++ "can easily be referred to later.  Every `important' state should be\n" +++ "tagged; in particular it is good practice to tag each stable release\n" +++ "with a number or codename.  Advice on release numbering can be found\n" +++ "at http://producingoss.com/en/development-cycle.html.\n" +++ "\n" +++ "To reproduce the state of a repository `R' as at tag `t', use the\n" +++ "command `darcs get --tag t R'.  The command `darcs show tags' lists\n" +++ "all tags in the current repository.\n" +++ "\n" +++ "Tagging also provides significant performance benefits: when Darcs\n" +++ "reaches a shared tag that depends on all antecedent patches, it can\n" +++ "simply stop processing.\n" +++ "\n" +++ "Like normal patches, a tag has a name, an author, a timestamp and an\n" +++ "optional long description, but it does not change the working tree.\n" +++ "A tag can have any name, but it is generally best to pick a naming\n" +++ "scheme and stick to it.\n" +++ "\n" +++ "The `darcs tag' command accepts the --pipe and --checkpoint options,\n" +++ "which behave as described in `darcs record' and `darcs optimize'\n" +++ "respectively.\n"++tag :: DarcsCommand+tag = DarcsCommand {command_name = "tag",+                    command_help = tag_help,+                    command_description = tag_description,+                    command_extra_args = -1,+                    command_extra_arg_help = ["[TAGNAME]"],+                    command_command = tag_cmd,+                    command_prereq = amInRepository,+                    command_get_arg_possibilities = return [],+                    command_argdefaults = nodefaults,+                    command_advanced_options = [nocompress,umask_option],+                    command_basic_options = [patchname_option, author,+                                            checkpoint,+                                            pipe_interactive,+                                            ask_long_comment,+                                            working_repo_dir]}++tag_cmd :: [DarcsFlag] -> [String] -> IO ()+tag_cmd opts args = withRepoLock opts $- \repository -> do+    date <- get_date opts+    the_author <- get_author opts+    deps <- get_tags_right `fmap` read_repo repository+    (name, long_comment)  <- get_name_log opts args+    myinfo <- patchinfo date name the_author long_comment+    let mypatch = infopatch myinfo identity+    tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps+    finalizeRepositoryChanges repository+    when (CheckPoint `elem` opts) $ write_recorded_checkpoint repository myinfo+    putStrLn $ "Finished tagging patch '"++name++"'"+  where  get_name_log :: [DarcsFlag] -> [String] -> IO (String, [String])+         get_name_log o a = do let o2 = if null a then o else (add_patch_name o (unwords a))+                               (name, comment, _) <- get_log o2 Nothing (world_readable_temp "darcs-tag") NilFL+                               when (length name < 2) $ hPutStr stderr $+                                 "Do you really want to tag '"+                                 ++name++"'? If not type: darcs obliterate --last=1\n"+                               return ("TAG " ++ name, comment)+         add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]+         add_patch_name o a| has_patch_name o = o+                           | otherwise = [PatchName a] ++ o+         has_patch_name (PatchName _:_) = True+         has_patch_name (_:fs) = has_patch_name fs+         has_patch_name [] = False++-- This may be useful for developers, but users don't care about+-- internals:+--+-- A tagged version automatically depends on all patches in the+-- repository.  This allows you to later reproduce precisely that+-- version.  The tag does this by depending on all patches in the+-- repository, except for those which are depended upon by other tags+-- already in the repository.  In the common case of a sequential+-- series of tags, this means that the tag depends on all patches+-- since the last tag, plus that tag itself.+\end{code}
+ src/Darcs/Commands/TrackDown.lhs view
@@ -0,0 +1,149 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{trackdown}+\begin{code}+module Darcs.Commands.TrackDown ( trackdown ) where+import Prelude hiding ( init )+import System.Exit ( ExitCode(..) )+import System.Cmd ( system )+import System.IO ( hFlush, stdout )+import Control.Monad( when )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable), working_repo_dir,+                         set_scripts_executable )+import Darcs.Hopefully ( hopefully )+import Darcs.Repository ( amInRepository, read_repo, withRepoReadLock, ($-), withRecorded,+                          setScriptsExecutable )+import Darcs.Ordered ( unsafeUnRL, concatRL )+import Darcs.Patch ( RepoPatch, Named, description, apply, invert )+import Printer ( putDocLn )+import Darcs.Test ( get_test )+import Darcs.Lock ( withTempDir )++trackdown_description :: String+trackdown_description = "Locate the most recent version lacking an error."++trackdown_help :: String+trackdown_help =+ "Trackdown tries to find the most recent version in the repository which\n"+++ "passes a test.  Given no arguments, it uses the default repository test.\n"+++ "Given one argument, it treats it as a test command.  Given two arguments,\n"+++ "the first is an initialization command with is run only once, and the\n"+++ "second is the test command.\n"++trackdown :: DarcsCommand+trackdown = DarcsCommand {command_name = "trackdown",+                          command_help = trackdown_help,+                          command_description = trackdown_description,+                          command_extra_args = -1,+                          command_extra_arg_help = ["[[INITIALIZATION]",+                                                    "COMMAND]"],+                          command_command = trackdown_cmd,+                          command_prereq = amInRepository,+                          command_get_arg_possibilities = return [],+                          command_argdefaults = nodefaults,+                          command_advanced_options = [set_scripts_executable],+                          command_basic_options = [working_repo_dir]}++trackdown_cmd :: [DarcsFlag] -> [String] -> IO ()+trackdown_cmd opts args = withRepoReadLock opts $- \repository -> do+  patches <- read_repo repository+  (init,test) <- case args of+          [] ->+              do t <- get_test opts+                 return (return ExitSuccess, t)+          [cmd] ->+              do putStrLn $ "Tracking down command:\n"++cmd+                 return $ (return ExitSuccess, system cmd)+          [init,cmd] ->+              do putStrLn $ "Initializing with command:\n"++init+                 putStrLn $ "Tracking down command:\n"++cmd+                 return $ (system init, system cmd)+          _ -> fail "Trackdown expects zero to two arguments."+  withRecorded repository (withTempDir "trackingdown") $ \_ -> do+    when (SetScriptsExecutable `elem` opts) setScriptsExecutable+    init+    track_next opts test $ map (invert . hopefully) $ unsafeUnRL $ concatRL patches++track_next :: RepoPatch p => [DarcsFlag] -> (IO ExitCode) -> [Named p] -> IO ()+track_next opts test (p:ps) = do+    test_result <- test+    if test_result == ExitSuccess+       then putStrLn "Success!"+       else do apply opts p `catch` \e -> fail ("Bad patch:\n" ++ show e)+               putStrLn "Trying without the patch:"+               putDocLn $ description $ invert p+               hFlush stdout+               track_next opts test ps+track_next _ _ [] = putStrLn "Noone passed the test!"+\end{code}++Trackdown is helpful for locating when something was broken.  It creates+a temporary directory with the latest repository content in it and cd to it.+First, and only once, it runs the initialization command if any,+for example+\begin{verbatim}+'autoconf; ./configure >/dev/null'+\end{verbatim}+Then it runs the test command, for example+\begin{verbatim}+'make && cd tests && sh /tmp/test.sh'+\end{verbatim}+While the test command exits with an error return code, darcs+``unapplies'' one patch from the version controlled files to retrieve+an earlier version, and repeats the test command.  If the test command+finally succeeds, the name of the hunted down patch is found in the+output before the last test run.++FIXME: It is+still rather primitive.  Currently it just goes back over the history in+reverse order trying each version.  I'd like for it to explore different+patch combinations, to try to find the minimum number of patches that you+would need to obliterate in order to make the test succeed.++FIXME: I also would like to add an interface by which you can tell it which+patches it should consider not including.  Without such a feature, the+following command:+\begin{verbatim}+% darcs trackdown 'make && false'+\end{verbatim}+would result in compiling every version in the repository--which is a+rather tedious prospect.++\subsubsection{Example usage}+If you want to find the last version of darcs that had a FIXME note in the+file Record.lhs, you could run+\begin{verbatim}+% darcs trackdown 'grep FIXME Record.lhs'+\end{verbatim}++To find the latest version that compiles, you can run+\begin{verbatim}+% darcs trackdown 'autoconf' './configure && make'+\end{verbatim}++Trackdown can also be used to see how other features of the code changed+with time.  For example+\begin{verbatim}+% darcs trackdown 'autoconf; ./configure' \+   "make darcs > /dev/null && cd ~/darcs && time darcs check && false"+\end{verbatim}+would let you see how long `darcs check' takes to run on each previous+version of darcs that will actually compile.  The ``\verb!&& false!''+ensures that trackdown keeps going.
+ src/Darcs/Commands/TransferMode.lhs view
@@ -0,0 +1,88 @@+%  Copyright (C) 2008 David Roundy+%+%  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{transfer-mode}+\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, PatternGuards #-}++-- The pragma above is only for pattern guards.+module Darcs.Commands.TransferMode ( transfer_mode ) where++import Prelude hiding ( catch )+import Control.Exception ( catch )+import System.IO ( stdout, hFlush )++import Darcs.Utils ( withCurrentDirectory, prettyException )+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, working_repo_dir )+import Darcs.Repository ( amInRepository )+import Progress ( setProgressMode )+import Darcs.Global ( darcsdir )++import qualified Data.ByteString as B (hPut, readFile, length, ByteString)++transfer_mode_description :: String+transfer_mode_description = "Internal command for efficient ssh transfers."++transfer_mode_help :: String+transfer_mode_help =+ "When pulling from or pushing to a remote repository over ssh, if both\n" +++ "the local and remote ends have Darcs 2, the `transfer-mode' command\n" +++ "will be invoked on the remote end.  This allows Darcs to intelligently\n" +++ "transfer information over a single ssh connection.\n" +++ "\n" +++ "If either end runs Darcs 1, a separate ssh connection will be created\n" +++ "for each transfer.  As well as being less efficient, this means users\n" +++ "who do not run ssh-agent will be prompted for the ssh password tens or\n" +++ "hundreds of times!\n"++transfer_mode :: DarcsCommand+transfer_mode = DarcsCommand {command_name = "transfer-mode",+                              command_help = transfer_mode_help,+                              command_description = transfer_mode_description,+                              command_extra_args = 0,+                              command_extra_arg_help = [],+                              command_get_arg_possibilities = return [],+                              command_command = transfer_mode_cmd,+                              command_prereq = amInRepository,+                              command_argdefaults = nodefaults,+                              command_advanced_options = [],+                              command_basic_options = [working_repo_dir]}++transfer_mode_cmd :: [DarcsFlag] -> [String] -> IO ()+transfer_mode_cmd _ _ = do setProgressMode False+                           putStrLn "Hello user, I am darcs transfer mode"+                           hFlush stdout+                           withCurrentDirectory darcsdir $ transfer++transfer :: IO ()+transfer = do 'g':'e':'t':' ':fn <- getLine+              x <- readfile fn+              case x of+                Right c -> do putStrLn $ "got " ++ fn+                              putStrLn $ show $ B.length c+                              B.hPut stdout c+                              hFlush stdout+                Left e -> do putStrLn $ "error " ++ fn+                             putStrLn $ show e+                             hFlush stdout+              transfer++readfile :: String -> IO (Either String B.ByteString)+readfile fn = (Right `fmap` B.readFile fn) `catch` (\e -> return $ Left (prettyException e))+\end{code}
+ src/Darcs/Commands/Unrecord.lhs view
@@ -0,0 +1,326 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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{unrecord}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, get_last_patches ) where+import Control.Monad ( when )+import System.Exit ( exitWith, ExitCode( ExitSuccess ) )++import Darcs.SlurpDirectory ( wait_a_moment )+import Darcs.Hopefully ( hopefully )+import Darcs.Commands ( DarcsCommand(..), nodefaults, loggers, command_alias )+import Darcs.Arguments ( DarcsFlag( Verbose ),+                         working_repo_dir, nocompress, definePatches,+                        match_several_or_last, deps_sel,+                        ignoretimes,+                        all_interactive, umask_option, summary+                      )+import Darcs.Match ( first_match, match_first_patchset, match_a_patchread )+import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf,+                          withRepoLock, ($-),+                    tentativelyRemovePatches, finalizeRepositoryChanges,+                    tentativelyAddToPending,+                    applyToWorking,+                    get_unrecorded, read_repo, amInRepository,+                    sync_repo,+                  )+import Darcs.Patch ( Patchy, RepoPatch, invert, commutex, effect )+import Darcs.Ordered ( RL(..), (:<)(..), (:>)(..), (:\/:)(..), (+<+),+                             mapFL_FL, nullFL,+                             concatRL, reverseRL, mapRL )+import Darcs.Patch.Depends ( get_common_and_uncommon )+import Darcs.SelectChanges ( with_selected_last_changes_reversed )+import Progress ( debugMessage )+import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped )+import Darcs.Gorsvet( invalidateIndex )+#include "gadts.h"++unrecord_description :: String+unrecord_description =+ "Remove recorded patches without changing the working copy."+\end{code}++Unrecord can be thought of as undo-record.+If a record is followed by an unrecord, everything looks like before+the record; all the previously unrecorded changes are back, and can be+recorded again in a new patch. The unrecorded patch however is actually+removed from your repository, so there is no way to record it again to get+it back.\footnote{The patch file itself is not actually deleted, but its+context is lost, so it cannot be reliably read---your only choice would be+to go in by hand and read its contents.}.++If you want to remove+the changes from the working copy too (where they otherwise will show+up as unrecorded changes again), you'll also need to \verb!darcs revert!.+To do unrecord and revert in one go, you can use \verb!darcs obliterate!.++If you don't revert after unrecording, then the changes made by the+unrecorded patches are left in your working tree.  If these patches are+actually from another repository, interaction (either pushes or pulls) with+that repository may be massively slowed down, as darcs tries to cope with+the fact that you appear to have made a large number of changes that+conflict with those present in the other repository.  So if you really want+to undo the result of a \emph{pull} operation, use obliterate! Unrecord is+primarily intended for when you record a patch, realize it needs just one+more change, but would rather not have a separate patch for just that one+change.++\newcommand{\pullwarning}[1]{+\textbf{WARNING:} #1 should not be run when there is a possibility+that another user may be pulling from the same repository.  Attempting to do so+may cause repository corruption.}++\pullwarning{Unrecord}++\begin{options}+--from-match, --from-patch, --from-tag, --last+\end{options}++Usually you only want to unrecord the latest changes,+and almost never would you want to unrecord changes before a tag---you+would have to have unrecorded the tag as well to do that.+Therefore, and for efficiency, darcs only prompts you for the latest patches,+after some optimal tag.++If you do want to unrecord more patches in one go,+there are the \verb!--from! and \verb!--last! options+to set the earliest patch selectable to unrecord.++\begin{options}+--matches, --patches, --tags, --no-deps+\end{options}++The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!+options can be used to select which patches to unrecord, as described in+subsection~\ref{selecting}.++With these options you can specify+what patch or patches to be prompted for by unrecord.+This is especially useful when you want to unrecord patches with dependencies,+since all the dependent patches (but no others) will be included in the choices.+Or if you use \verb!--no-deps! you won't be asked about patches that can't be+unrecorded due to depending patches.++Selecting patches can be slow, so darcs cuts the search at the last+optimized tag. Use the \verb!--from! or \verb!--last! options to search+more or fewer patches.++\begin{code}+unrecord_help :: String+unrecord_help =+ "Unrecord does the opposite of record in that it makes the changes from\n"+++ "patches active changes again which you may record or revert later.  The\n"+++ "working copy itself will not change.\n"+++ "Beware that you should not use this command if you are going to\n"+++ "re-record the changes in any way and there is a possibility that\n"+++ "another user may have already pulled the patch.\n"++unrecord :: DarcsCommand+unrecord = DarcsCommand {command_name = "unrecord",+                         command_help = unrecord_help,+                         command_description = unrecord_description,+                         command_extra_args = 0,+                         command_extra_arg_help = [],+                         command_command = unrecord_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = return [],+                         command_argdefaults = nodefaults,+                         command_advanced_options = [nocompress,umask_option],+                         command_basic_options = [match_several_or_last,+                                                 deps_sel,+                                                 all_interactive,+                                                 working_repo_dir]}++unrecord_cmd :: [DarcsFlag] -> [String] -> IO ()+unrecord_cmd opts _ = withRepoLock opts $- \repository -> do+  let (logMessage,_,_) = loggers opts+  allpatches <- read_repo repository+  FlippedSeal patches <- return $ if first_match opts+                                  then get_last_patches opts allpatches+                                  else matchingHead opts allpatches+  with_selected_last_changes_reversed "unrecord" opts+      (reverseRL patches) $+    \ (_ :> to_unrecord) -> do+       when (nullFL to_unrecord) $ do logMessage "No patches selected!"+                                      exitWith ExitSuccess+       when (Verbose `elem` opts) $+            logMessage "About to write out (potentially) modified patches..."+       definePatches to_unrecord+       invalidateIndex repository+       withGutsOf repository $ do tentativelyRemovePatches repository opts $+                                                           mapFL_FL hopefully to_unrecord+                                  finalizeRepositoryChanges repository+       sync_repo repository+       logMessage "Finished unrecording."++get_last_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(r)+                 -> FlippedSeal (RL (PatchInfoAnd p)) C(r)+get_last_patches opts ps =+  case match_first_patchset opts ps of+  Sealed p1s -> case get_common_and_uncommon (ps,p1s) of+                (_,us :\/: _) -> FlippedSeal $ concatRL us++unpull_description :: String+unpull_description =+ "Opposite of pull; unsafe if patch is not in remote repository."++unpull_help :: String+unpull_help =+ "Unpull completely removes recorded patches from your local repository.\n"+++ "The changes will be undone in your working copy and the patches will not be\n"+++ "shown in your changes list anymore.\n"+++ "Beware that if the patches are not still present in another repository you\n"+++ "will lose precious code by unpulling!\n"++unpull :: DarcsCommand+unpull = (command_alias "unpull" obliterate)+                      {command_help = unpull_help,+                       command_description = unpull_description,+                       command_command = unpull_cmd}++unpull_cmd :: [DarcsFlag] -> [String] -> IO ()+unpull_cmd = generic_obliterate_cmd "unpull"++\end{code}+\darcsCommand{obliterate}+\begin{code}++obliterate_description :: String+obliterate_description =+ "Delete selected patches from the repository. (UNSAFE!)"++obliterate_help :: String+obliterate_help =+ "Obliterate completely removes recorded patches from your local repository.\n"+++ "The changes will be undone in your working copy and the patches will not be\n"+++ "shown in your changes list anymore.\n"+++ "Beware that you can lose precious code by obliterating!\n"++\end{code}+Obliterate deletes a patch from the repository \emph{and} removes those+changes from the working directory.  It is therefore a \emph{very+dangerous} command.  When there are no local changes, obliterate is+equivalent to an unrecord followed by a revert, except that revert can be+unreverted.  In the case of tags, obliterate removes the tag itself, not+any other patches.++Note that unpull was the old name for obliterate. Unpull is still an+hidden alias for obliterate.++\pullwarning{Obliterate}++\begin{options}+--from-match, --from-patch, --from-tag, --last+\end{options}++Usually you only want to obliterate the latest changes, and almost never would+you want to obliterate changes before a tag---you would have to have obliterated+the tag as well to do that. Therefore, and for efficiency, darcs only+prompts you for the latest patches, after some optimal tag.++If you do want to obliterate more patches in one go, there are the+\verb!--from! and \verb!--last! options to set the earliest patch+selectable to obliterate.++\begin{options}+--matches, --patches, --tags, --no-deps+\end{options}++The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!+options can be used to select which patches to obliterate, as described in+subsection~\ref{selecting}.++With these options you can specify what patch or patches to be prompted for+by obliterate. This is especially useful when you want to obliterate patches with+dependencies, since all the dependent patches (but no others) will be+included in the choices. Or if you use \verb!--no-deps! you won't be asked+about patches that can't be obliterated due to depending patches.++Selecting patches can be slow, so darcs cuts the search at the last+optimized tag. Use the \verb!--from! or \verb!--last! options to search+more or fewer patches.++\begin{code}+obliterate :: DarcsCommand+obliterate = DarcsCommand {command_name = "obliterate",+                           command_help = obliterate_help,+                           command_description = obliterate_description,+                           command_extra_args = 0,+                           command_extra_arg_help = [],+                           command_command = obliterate_cmd,+                           command_prereq = amInRepository,+                           command_get_arg_possibilities = return [],+                           command_argdefaults = nodefaults,+                           command_advanced_options = [nocompress,ignoretimes,umask_option],+                           command_basic_options = [match_several_or_last,+                                                   deps_sel,+                                                   all_interactive,+                                                   working_repo_dir,+                                                   summary]}+obliterate_cmd :: [DarcsFlag] -> [String] -> IO ()+obliterate_cmd = generic_obliterate_cmd "obliterate"++-- | generic_obliterate_cmd is the function that executes the "obliterate" and+--   "unpull" commands.+generic_obliterate_cmd :: String      -- ^ The name under which the command is invoked (@unpull@ or @obliterate@)+                       -> [DarcsFlag] -- ^ The flags given on the command line+                       -> [String]    -- ^ Files given on the command line (unused)+                       -> IO ()+generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do+  let (logMessage,_,_) = loggers opts+  pend <- get_unrecorded repository+  allpatches <- read_repo repository+  FlippedSeal patches <- return $ if first_match opts+                                  then get_last_patches opts allpatches+                                  else matchingHead opts allpatches+  with_selected_last_changes_reversed cmdname opts+      (reverseRL patches) $+    \ (_ :> ps) ->+    case commutex (pend :< effect ps) of+    Nothing -> fail $ "Can't "++ cmdname +++               " patch without reverting some unrecorded change."+    Just (p_after_pending:<_) -> do+        when (nullFL ps) $ do logMessage "No patches selected!"+                              exitWith ExitSuccess+        definePatches ps+        invalidateIndex repository+        withGutsOf repository $+                             do tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)+                                tentativelyAddToPending repository opts $ invert $ effect ps+                                finalizeRepositoryChanges repository+                                debugMessage "Waiting a bit for timestamps to differ..."+                                wait_a_moment+                                debugMessage "Applying patches to working directory..."+                                applyToWorking repository opts (invert p_after_pending) `catch` \e ->+                                    fail ("Couldn't undo patch in working dir.\n" ++ show e)+        sync_repo repository+        logMessage $ "Finished " ++ present_participle cmdname ++ "."++matchingHead :: Patchy p => [DarcsFlag] -> PatchSet p C(r) -> FlippedSeal (RL (PatchInfoAnd p)) C(r)+matchingHead opts (x:<:_) | or (mapRL (match_a_patchread opts) x) = FlippedSeal x+matchingHead opts (x:<:xs) = (x +<+) `mapFlipped` matchingHead opts xs+matchingHead _ NilRL = FlippedSeal NilRL++present_participle :: String -> String+present_participle v | last v == 'e' = init v ++ "ing"+                     | otherwise = v ++ "ing"+\end{code}+
+ src/Darcs/Commands/Unrevert.lhs view
@@ -0,0 +1,136 @@+%  Copyright (C) 2003-2005 David Roundy+%+%  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{unrevert}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Commands.Unrevert ( unrevert, write_unrevert ) where+import System.Exit ( ExitCode(..), exitWith )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Unified, MarkConflicts ),+                         ignoretimes, working_repo_dir,+                        all_interactive, umask_option,+                      )+import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, ($-),+                          unrevertUrl, considerMergeToWorking,+                          tentativelyAddToPending, finalizeRepositoryChanges,+                          sync_repo, get_unrecorded,+                          read_repo, amInRepository,+                          slurp_recorded,+                          applyToWorking )+import Darcs.Patch ( RepoPatch, Prim, commutex, namepatch, fromPrims )+import Darcs.Ordered ( RL(..), FL(..), (:<)(..), (:>)(..), (:\/:)(..), reverseRL,+                       (+>+) )+import Darcs.SelectChanges ( with_selected_changes_to_files' )+import Darcs.SlurpDirectory ( Slurpy )+import qualified Data.ByteString as B+import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist )+import Darcs.Patch.Depends ( get_common_and_uncommon )+import Darcs.Utils ( askUser, catchall )+import Darcs.Patch.Bundle ( scan_bundle, make_bundle )+import IsoDate ( getIsoDateTime )+import Darcs.SignalHandler ( withSignalsBlocked )+import Progress ( debugMessage )+import Darcs.Sealed ( Sealed(Sealed) )+#include "impossible.h"++unrevert_description :: String+unrevert_description =+ "Undo the last revert (may fail if changes after the revert)."++unrevert_help :: String+unrevert_help =+ "Unrevert is a rescue command in case you accidentally reverted\n" +++ "something you wanted to keep (for example, typing `darcs rev -a'\n" +++ "instead of `darcs rec -a').\n" +++ "\n" +++ "This command may fail if the repository has changed since the revert\n" +++ "took place.  Darcs will ask for confirmation before executing an\n" +++ "interactive command that will DEFINITELY prevent unreversion.\n"++unrevert :: DarcsCommand+unrevert = DarcsCommand {command_name = "unrevert",+                         command_help = unrevert_help,+                         command_description = unrevert_description,+                         command_extra_args = 0,+                         command_extra_arg_help = [],+                         command_command = unrevert_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = return [],+                         command_argdefaults = nodefaults,+                         command_advanced_options = [umask_option],+                         command_basic_options = [ignoretimes,+                                                  all_interactive,+                                                  working_repo_dir]}++unrevert_cmd :: [DarcsFlag] -> [String] -> IO ()+unrevert_cmd opts [] = withRepoLock opts $- \repository -> do+  us <- read_repo repository+  Sealed them <- unrevert_patch_bundle repository+  rec <- slurp_recorded repository+  unrec <- get_unrecorded repository+  case get_common_and_uncommon (us, them) of+    (_, (h_us:<:NilRL) :\/: (h_them:<:NilRL)) -> do+      Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts)+                   (reverseRL h_us) (reverseRL h_them)+      with_selected_changes_to_files' "unrevert" opts [] pw $+                            \ (p :> skipped) -> do+        tentativelyAddToPending repository opts p+        withSignalsBlocked $+          do finalizeRepositoryChanges repository+             applyToWorking repository opts p `catch` \e ->+                 fail ("Error applying unrevert to working directory...\n"+                       ++ show e)+             debugMessage "I'm about to write_unrevert."+             write_unrevert repository skipped rec (unrec+>+p)+        sync_repo repository+        debugMessage "Finished unreverting."+    _ -> impossible+unrevert_cmd _ _ = impossible++write_unrevert :: RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> Slurpy -> FL Prim C(r x) -> IO ()+write_unrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository+write_unrevert repository ps rec pend = do+  case commutex (ps :< pend) of+    Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "+                  case really of ('y':_) -> return ()+                                 _ -> exitWith $ ExitSuccess+                  write_unrevert repository NilFL rec pend+    Just (_ :< p') -> do+        rep <- read_repo repository+        case get_common_and_uncommon (rep,rep) of+            (common,_ :\/: _) -> do+                date <- getIsoDateTime+                np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')+                writeDocBinFile (unrevertUrl repository) $+                             make_bundle [Unified] rec common (np :>: NilFL)+                where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y)+                      fromRepoPrims _ xs = fromPrims xs++unrevert_patch_bundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p)+unrevert_patch_bundle repository = do+  pf <- B.readFile (unrevertUrl repository)+        `catchall` fail "There's nothing to unrevert!"+  case scan_bundle pf of+      Right ps -> return ps+      Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+\end{code}
+ src/Darcs/Commands/WhatsNew.lhs view
@@ -0,0 +1,160 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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{whatsnew}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Commands.WhatsNew ( whatsnew ) where+import System.Exit ( ExitCode(..), exitWith )+import Data.List ( sort )+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag(..), working_repo_dir, lookforadds,+                        ignoretimes, noskip_boring,+                        unified, summary, no_cache,+                         areFileArgs, fixSubPaths,+                        list_registered_files,+                      )+import Darcs.RepoPath ( SubPath, sp2fn )++import Darcs.Repository ( Repository, withRepository, ($-), slurp_recorded,+                          get_unrecorded_no_look_for_adds,+                          get_unrecorded_in_files, amInRepository )+import Darcs.Repository.Prefs ( filetype_function )+import Darcs.Diff ( unsafeDiff )+import Darcs.Patch ( RepoPatch, Prim, summarize, apply_to_slurpy, is_hunk )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.Real ( RealPatch, prim2real )+import Darcs.Patch.FileName ( fn2fp )+import Darcs.PrintPatch ( printPatch, contextualPrintPatch )+import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL )++import Darcs.Gorsvet( unrecordedChanges, restrictBoring, readRecordedAndPending )+import Storage.Hashed.Monad( virtualTreeIO, exists )+import Storage.Hashed( readPlainTree )+import Storage.Hashed( floatPath )++import Printer ( putDocLn, renderString, vcat, text )+#include "impossible.h"++whatsnew_description :: String+whatsnew_description = "List unrecorded changes in the working tree."++whatsnew_help :: String+whatsnew_help =+ "The `darcs whatsnew' command lists unrecorded changes to the working\n" +++ "tree.  If you specify a set of files and directories, only unrecorded\n" +++ "changes to those files and directories are listed.\n" +++ "\n" +++ "With the --summary option, the changes are condensed to one line per\n" +++ "file, with mnemonics to indicate the nature and extent of the change.\n" +++ "The --look-for-adds option causes candidates for `darcs add' to be\n" +++ "included in the summary output.\n" +++ "\n" +++ "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" +++ "To see some context (unchanged lines) around each change, use the\n" +++ "--unified option.  To view changes in conventional `diff' format, use\n" +++ "the `darcs diff' comand; but note that `darcs whatsnew' is faster.\n" +++ "\n" +++ "This command exits unsuccessfully (returns a non-zero exit status) if\n" +++ "there are no unrecorded changes.\n"++whatsnew :: DarcsCommand+whatsnew = DarcsCommand {command_name = "whatsnew",+                         command_help = whatsnew_help,+                         command_description = whatsnew_description,+                         command_extra_args = -1,+                         command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                         command_command = whatsnew_cmd,+                         command_prereq = amInRepository,+                         command_get_arg_possibilities = list_registered_files,+                         command_argdefaults = nodefaults,+                         command_advanced_options = [ignoretimes, noskip_boring, no_cache],+                         command_basic_options = [summary, unified,+                                                 lookforadds,+                                                 working_repo_dir]}++announce_files :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO ()+announce_files repo files =+    when (areFileArgs files) $ do+      nonboring <- restrictBoring+      working <- nonboring `fmap` readPlainTree "."+      pristine <- readRecordedAndPending repo+      let paths = map (fn2fp . sp2fn) files+          check = virtualTreeIO (mapM exists $ map floatPath paths)+      (in_working, _) <- check working+      (in_pending, _) <- check pristine+      mapM_ maybe_warn $ zip3 paths in_working in_pending+      putStrLn $ "What's new in "++unwords (map show files)++":\n"+    where maybe_warn (file, False, False) =+              putStrLn $ "WARNING: File '"++file++"' does not exist!"+          maybe_warn (file, True, False) =+              putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!"+          maybe_warn _ = return ()++whatsnew_cmd :: [DarcsFlag] -> [String] -> IO ()+whatsnew_cmd opts' args +  | LookForAdds `elem` opts' && NoSummary `notElem` opts' =+    -- add Summary to the opts since 'darcs whatsnew --look-for-adds'+    -- implies summary+    withRepository (Summary:opts') $- \repository -> do+    files <- fixSubPaths opts' args+    announce_files repository files+    all_changes <- get_unrecorded_in_files repository (map sp2fn files)+    chold <- get_unrecorded_no_look_for_adds repository (map sp2fn files)+    s <- slurp_recorded repository+    ftf <- filetype_function+    cho_adds :> _ <- return $ partitionRL is_hunk $ reverseFL chold+    cha :> _ <- return $ partitionRL is_hunk $ reverseFL all_changes+    let chn    = unsafeDiff [LookForAdds,Summary] ftf+                            (fromJust $ apply_to_slurpy (reverseRL cho_adds) s)+                            (fromJust $ apply_to_slurpy (reverseRL cha) s)+    exitOnNoChanges (chn, chold)+    putDocLn $ summarize chold+    printSummary chn+    where lower_as x = vcat $ map (text . l_as) $ lines x+          l_as ('A':x) = 'a':x+          l_as x = x+          exitOnNoChanges :: (FL Prim C(x y), FL p C(u v)) -> IO ()+          exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"+                                              exitWith $ ExitFailure 1+          exitOnNoChanges _ = return ()+          printSummary :: FL Prim C(x y) -> IO ()+          printSummary NilFL = return ()+          printSummary new = putDocLn $ lower_as $ renderString $ summarize new++whatsnew_cmd opts args+  | otherwise =+    withRepository opts $- \repository -> do+    files <- sort `fmap` fixSubPaths opts args+    announce_files repository files+    changes <- unrecordedChanges opts repository files+    when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1)+    printSummary repository $ mapFL_FL prim2real changes+       where printSummary :: RepoPatch p => Repository p C(r u t) -> FL RealPatch C(r y) -> IO ()+             printSummary _ NilFL = do putStrLn "No changes!"+                                       exitWith $ ExitFailure 1+             printSummary r ch | Summary `elem` opts = putDocLn $ summarize ch+                               | Unified `elem` opts = do s <- slurp_recorded r+                                                          contextualPrintPatch s ch+                               | otherwise           = printPatch ch+\end{code}
+ src/Darcs/CommandsAux.hs view
@@ -0,0 +1,112 @@+-- Copyright (C) 2006 Tommy Pettersson <ptp@lysator.liu.se>+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.CommandsAux ( check_paths, malicious_patches, has_malicious_path,+                        ) where+import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) )+import Darcs.Patch ( Patchy, list_touched_files )+import Darcs.Ordered ( FL, mapFL )+import Darcs.Sealed ( Sealed2(..), unseal2 )+import Darcs.Global ( darcsdir )+import Data.List ( intersect )+import System.FilePath ( splitDirectories )++-- * File paths+{-+  Darcs will operate on files and directories with the invoking user's+  privileges. The paths for these files and directories are stored in+  patches, which darcs receives in various ways. Even though darcs will not+  create patches with "unexpected" file paths, there are no such guarantees+  for received patches. A spoofed patch could inflict changes on any file+  or directory which the invoking user is privileged to modify.++  There is no one single "apply" function that can check paths, so each+  command is responsible for not applying patches without first checking+  them with one of these function when appropriate.+-}++{- |+  A convenience function to call from all darcs command functions before+  applying any patches. It checks for malicious paths in patches, and+  prints an error message and fails if it finds one.+-}+check_paths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO ()+check_paths opts patches+  = if check_is_on  && or (mapFL has_malicious_path patches)+      then fail $ unlines $ ["Malicious path in patch:"] +++                            (map (\s -> "    " ++ s) $ concat $ mapFL malicious_paths patches) +++                            ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."]+           -- TODO: print patch(es)+           -- NOTE: should use safe Doc printer, this can be evil chars+      else return ()+ where+    check_is_on = DontRestrictPaths `notElem` opts  ||+                  RestrictPaths        `elem` opts++-- | Filter out patches that contains some malicious file path+malicious_patches :: Patchy p => [Sealed2 p] -> [Sealed2 p]+malicious_patches to_check = filter (unseal2 has_malicious_path) to_check++has_malicious_path :: Patchy p => p C(x y) -> Bool+has_malicious_path patch =+    case malicious_paths patch of+      [] -> False+      _ -> True++malicious_paths :: Patchy p => p C(x y) -> [String]+malicious_paths patch =+  let paths = list_touched_files patch in+    filter is_malicious_path paths++{-|+  What is a malicious path?++  A spoofed path is a malicious path.++  1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),+     so any not explicitly relative path is surely spoofed.++  2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with+     @\"\/..\/\"@ are surely spoofed.++  A path to a darcs repository's meta data can modify \"trusted\" patches or+  change safety defaults in that repository, so we check for paths+  containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.++  To do?++  * How about get repositories?++  * Would it be worth adding a --semi-safe-paths option for allowing+    changes to certain preference files (_darcs\/prefs\/) in sub+    repositories'?+-}+is_malicious_path :: String -> Bool+is_malicious_path fp =+    not (is_explicitly_relative fp) ||+    splitDirectories fp `contains_any` [ "..", darcsdir ]+ where+    contains_any a b = not . null $ intersect a b++is_explicitly_relative :: String -> Bool+is_explicitly_relative ('.':'/':_) = True  -- begins with "./"+is_explicitly_relative _ = False
+ src/Darcs/Compat.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Compat (stdout_is_a_pipe, mk_stdout_temp, canonFilename,+               maybeRelink, atomic_create, sloppy_atomic_create) where++import Prelude hiding ( catch )++import Darcs.Utils ( withCurrentDirectory )+#ifdef WIN32+import Darcs.Utils ( showHexLen )+import Data.Bits ( (.&.) )+import System.Random ( randomIO )+#else+import Foreign.C.String ( peekCString )+#endif++import Control.Monad ( unless )+import Foreign.C.Types ( CInt )+import Foreign.C.String ( CString, withCString )+import Foreign.C.Error ( throwErrno, eEXIST, getErrno )+import System.Directory ( getCurrentDirectory )+import System.IO ( hFlush, stdout, stderr, hSetBuffering,+                   BufferMode(NoBuffering) )+import System.IO.Error ( mkIOError, alreadyExistsErrorType )+import System.Posix.Files ( stdFileMode )+import System.Posix.IO ( openFd, closeFd, stdOutput, stdError, +                         dupTo, defaultFileFlags, exclusive,+                         OpenMode(WriteOnly) )+import System.Posix.Types ( Fd(..) )++import Darcs.SignalHandler ( stdout_is_a_pipe )++canonFilename :: FilePath -> IO FilePath+canonFilename f@(_:':':_) = return f -- absolute windows paths+canonFilename f@('/':_) = return f+canonFilename ('.':'/':f) = do cd <- getCurrentDirectory+                               return $ cd ++ "/" ++ f+canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of+                  "" -> fmap (++('/':f)) getCurrentDirectory+                  rd -> withCurrentDirectory rd $+                          do fd <- getCurrentDirectory+                             return $ fd ++ "/" ++ simplefilename+    where+    simplefilename = reverse $ takeWhile (/='/') $ reverse f++#ifdef WIN32+mkstemp_core :: FilePath -> IO (Fd, String)+mkstemp_core fp+ = do r <- randomIO+      let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))+      fd <- openFd fp' WriteOnly (Just stdFileMode) flags+      return (fd, fp')+  where flags = defaultFileFlags { exclusive = True }+#else+mkstemp_core :: String -> IO (Fd, String)+mkstemp_core str = withCString (str++"XXXXXX") $+    \cstr -> do fd <- c_mkstemp cstr+                if fd < 0+                  then throwErrno $ "Failed to create temporary file "++str+                  else do str' <- peekCString cstr+                          fname <- canonFilename str'+                          return (Fd fd, fname)++foreign import ccall unsafe "static stdlib.h mkstemp"+    c_mkstemp :: CString -> IO CInt+#endif++mk_stdout_temp :: String -> IO String+mk_stdout_temp str = do (fd, fn) <- mkstemp_core str+                        hFlush stdout+                        hFlush stderr+                        dupTo fd stdOutput+                        dupTo fd stdError+                        hFlush stdout+                        hFlush stderr+                        hSetBuffering stdout NoBuffering+                        hSetBuffering stderr NoBuffering+                        return fn++++foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink+    :: CString -> CString -> CInt -> IO CInt++-- Checks whether src and dst are identical.  If so, makes dst into a+-- link to src.  Returns True if dst is a link to src (either because+-- we linked it or it already was).  Safe against changes to src if+-- they are not in place, but not to dst.+maybeRelink :: String -> String -> IO Bool+maybeRelink src dst =+    withCString src $ \csrc ->+    withCString dst $ \cdst ->+    do rc <- maybe_relink csrc cdst 1+       (case rc of+        0 -> return True+        1 -> return True+        -1 -> throwErrno ("Relinking " ++ dst)+        -2 -> return False+        -3 -> do putStrLn ("Relinking: race condition avoided on file " +++                            dst)+                 return False+        _ -> fail ("Unexpected situation when relinking " ++ dst))++sloppy_atomic_create :: FilePath -> IO ()+sloppy_atomic_create fp+    = do fd <- openFd fp WriteOnly (Just stdFileMode) flags+         closeFd fd+  where flags = defaultFileFlags { exclusive = True }++atomic_create :: FilePath -> IO ()+atomic_create fp = withCString fp $ \cstr -> do+    rc <- c_atomic_create cstr+    unless (rc >= 0) $+           do errno <- getErrno+              pwd <- getCurrentDirectory+              if errno == eEXIST+                 then ioError $ mkIOError alreadyExistsErrorType+                                          ("atomic_create in "++pwd)+                                          Nothing (Just fp)+                 else throwErrno $ "atomic_create "++fp++" in "++pwd++foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create+    :: CString -> IO CInt
+ src/Darcs/Diff.hs view
@@ -0,0 +1,375 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff, sync, cmp+#ifndef GADT_WITNESSES+                  , diff_files+#endif+                  ) where++import System.Posix+     ( setFileTimes )+import System.IO ( IOMode(ReadMode), hFileSize, hClose )+import System.Directory ( doesDirectoryExist, doesFileExist,+                   getDirectoryContents,+                 )+import Control.Monad ( when )+import Data.List ( sort+#ifndef GADT_WITNESSES+                 , intersperse, isPrefixOf+#endif+                 )+#ifndef GADT_WITNESSES+import Data.Maybe ( catMaybes )+#endif++#ifndef GADT_WITNESSES+import ByteStringUtils ( is_funky, linesPS)+import qualified Data.ByteString.Char8 as BC (last)+import qualified Data.ByteString as B       (null, empty, take, ByteString)+#endif+import qualified Data.ByteString as B       (hGet, length)++import Darcs.SlurpDirectory ( Slurpy, slurp_name, is_dir, is_file,+#ifndef GADT_WITNESSES+                        get_slurp,+#endif+                        get_dircontents, get_filecontents,+                        get_mtime, get_length,+                        undefined_time+#ifndef GADT_WITNESSES+                        , FileContents, undefined_size+#endif+                      )+#ifndef GADT_WITNESSES+import System.FilePath.Posix ( (</>) )+#endif+import Darcs.Patch ( Prim+#ifndef GADT_WITNESSES+                   , hunk, canonize, rmfile, rmdir+                   , addfile, adddir+                   , binary, invert+#endif+                   )+#ifndef GADT_WITNESSES+import Darcs.Patch.FileName( fp2fn, breakup )+#endif+import System.IO ( openBinaryFile )+import Darcs.Repository.Prefs ( FileType(..) )+import Darcs.Flags ( DarcsFlag(..) )+import Darcs.Utils ( catchall )+import Darcs.Ordered ( FL(..)+#ifndef GADT_WITNESSES+                           , (+>+)+#endif+                           )+#ifndef GADT_WITNESSES+#include "impossible.h"+#endif++-- | The unsafeDiffAtPaths function calls diff_at_path for a set of files and+--   and directories, and returns all changes to those files. It recurses into+--   given directories when searching for changes.+--+--   Comparing paths and not slurpies is useful when the user+--   requests a diff for a file that is created or removed in the working copy:+--   then there is no slurpy for the file in the /current/ or /working/ slurpy+--   respectively.+--+--   The given paths must always be fixed repository paths starting with a+--   ".". It is safe to pass overlapping paths.+--+--   The booleans in the first argument tell whether to ignore mtimes, whether+--   we must look for additions and if we're diffing for a summary only.+--+--   It returns an FL of patches, that contains all the changes that have been+--   made at all those paths.+unsafeDiffAtPaths :: (Bool, Bool, Bool) -> (FilePath -> FileType) ->+               Slurpy -> Slurpy -> [FilePath] -> FL Prim C(x y)+#ifdef GADT_WITNESSES+unsafeDiffAtPaths = undefined+#else+unsafeDiffAtPaths flags filetypeFunction s1 s2 paths =+    foldr (+>+) NilFL (catMaybes diffsPerPath)+  where diffsPerPath = map differ safePaths+        differ       = diff_at_path flags filetypeFunction s1 s2+        safePaths    = make_nonoverlapping_path_set paths++diff_at_path :: (Bool, Bool, Bool) -> (FilePath -> FileType)+                -> Slurpy -> Slurpy -> FilePath -> Maybe (FL Prim)+diff_at_path (ignoreTimes, lookForAdds, summary) filetypeFunction s1 s2 path =+    case (pathIn1, pathIn2) of+        (Nothing, Nothing) -> Nothing+        (Nothing, Just s2PathSlurpy) -> do+            Just $ diff_added summary filetypeFunction initialFps s2PathSlurpy NilFL+        (Just s1PathSlurpy, Nothing) -> do+            Just $ diff_removed filetypeFunction initialFps s1PathSlurpy NilFL+        (Just s1PathSlurpy, Just s2PathSlurpy) ->+            Just $ gendiff (ignoreTimes, lookForAdds, summary) filetypeFunction+                           initialFps s1PathSlurpy s2PathSlurpy NilFL+  where pathIn1 = get_slurp (fp2fn path) s1+        pathIn2 = get_slurp (fp2fn path) s2+        initialFps = tail $ reverse (breakup path)++make_nonoverlapping_path_set :: [FilePath] -> [FilePath]+make_nonoverlapping_path_set = map unbreakup . delete_overlapping . map breakup . sort+  where+    delete_overlapping :: [[FilePath]] -> [[FilePath]]+    delete_overlapping (p1:p2:ps) = if p1 `isPrefixOf` p2+                                      then delete_overlapping (p1:ps)+                                      else p1 : delete_overlapping (p2:ps)+    delete_overlapping ps         = ps+    unbreakup = concat . intersperse "/"+#endif++-- The diff function takes a recursive diff of two slurped-up directory trees.+-- The code involved is actually pretty trivial.  \verb!paranoid_diff! runs a+-- diff in which we don't make the assumption that files with the same+-- modification time are identical.++unsafeDiff :: [DarcsFlag]+           -> (FilePath -> FileType) -> Slurpy -> Slurpy -> FL Prim C(x y)+#ifdef GADT_WITNESSES+unsafeDiff = undefined+#else+unsafeDiff opts wt s1 s2+    = case diff_at_path (ignoreTimes, lookForAdds, summary)  wt s1 s2 "" of+          Just d -> d+          _      -> impossible -- because "" always exists in a slurpy +  where -- NoSummary/Summary both present gives False+        -- Just Summary gives True+        -- Just NoSummary gives False+        -- Neither gives False+        summary = Summary `elem` opts && NoSummary `notElem` opts+        lookForAdds = LookForAdds `elem` opts+        ignoreTimes = IgnoreTimes `elem` opts++mk_filepath :: [FilePath] -> FilePath+mk_filepath fps = concat $ intersperse "/" $ reverse fps++gendiff :: (Bool,Bool,Bool)+        -> (FilePath -> FileType) -> [FilePath] -> Slurpy -> Slurpy+        -> (FL Prim -> FL Prim)+gendiff opts@(isparanoid,_,_) wt fps s1 s2+    | is_file s1 && is_file s2 = diff_regular_files isparanoid wt f s1 s2+    | is_dir s1 && is_dir s2 =+          let fps' = case n2 of+                         "." -> fps+                         _ -> n2:fps+          in fps' `seq` recur_diff opts (wt . (n2</>)) fps' dc1 dc2+    | otherwise = id+    where n2 = slurp_name s2+          f = mk_filepath (n2:fps)+          dc1 = get_dircontents s1+          dc2 = get_dircontents s2++-- recur_diff or recursive diff+-- First parameter is (IgnoreTimes?, LookforAdds?, Summary?)+recur_diff :: (Bool,Bool,Bool)+           -> (FilePath -> FileType) -> [FilePath] -> [Slurpy] -> [Slurpy]+           -> (FL Prim -> FL Prim)+recur_diff _ _ _ [] [] = id+recur_diff opts@(_,doadd,summary) wt fps (s:ss) (s':ss')+    -- this is the case if a file has been removed in the working directory+    | s < s' = diff_removed wt fps s . recur_diff opts wt fps ss (s':ss')+    -- this next case is when there is a file in the directory that is not+    -- in the repository (ie, not managed by darcs)+    | s > s' = let rest = recur_diff opts wt fps (s:ss) ss'+               in if not doadd then                        rest+                               else diff_added summary wt fps s' . rest+    -- actually compare the files because the names match+    | s == s' = gendiff opts wt fps s s' . recur_diff opts wt fps ss ss'+recur_diff opts wt fps (s:ss) [] =+    diff_removed wt fps s . recur_diff opts wt fps ss []+recur_diff opts@(_,True,summary) wt fps [] (s':ss') =+    diff_added summary wt fps s' . recur_diff opts wt fps [] ss'+recur_diff (_,False,_) _ _ [] _ = id+recur_diff _ _ _ _ _ = impossible++-- diff, taking into account paranoidness and file type, two regular files+diff_regular_files :: Bool -> (FilePath -> FileType) -> FilePath -> Slurpy -> Slurpy -> (FL Prim -> FL Prim)+diff_regular_files ignoreTimes filetypeFunction f s1 s2 = +    if maybe_differ   +        then case filetypeFunction (slurp_name s2) of                                     +               TextFile -> diff_files f b1 b2                    +               BinaryFile -> if b1 /= b2 then (binary f b1 b2:>:)+                                         else id                 +        else id+  where maybe_differ = ignoreTimes+                     || get_mtime s1 == undefined_time+                     || get_mtime s1 /= get_mtime s2+                     || get_length s1 == undefined_size+                     || get_length s1 /= get_length s2+        b1 = get_filecontents s1+        b2 = get_filecontents s2++-- creates a diff for a file or directory which needs to be added to the+-- repository+diff_added :: Bool -> (FilePath -> FileType) -> [FilePath] -> Slurpy+           -> (FL Prim -> FL Prim)+diff_added summary wt fps s+    | is_file s = case wt n of+                  TextFile -> (addfile f:>:) .+                              (if summary+                               then id+                               else diff_from_empty id f (get_filecontents s))+                  BinaryFile -> (addfile f:>:) .+                                (if summary then id else+                                (bin_patch f B.empty (get_filecontents s)))+    | otherwise {- is_dir s -} =+        (adddir f:>:)+      . foldr (.) id (map (diff_added summary wt (n:fps)) (get_dircontents s))+    where n = slurp_name s+          f = mk_filepath (n:fps)++get_text :: FileContents -> [B.ByteString]+get_text = linesPS++empt :: FileContents+empt = B.empty++diff_files :: FilePath -> FileContents -> FileContents+           -> (FL Prim -> FL Prim)+diff_files f o n | get_text o == [B.empty] && get_text n == [B.empty] = id+                 | get_text o == [B.empty] = diff_from_empty id f n+                 | get_text n == [B.empty] = diff_from_empty invert f o+diff_files f o n = if o == n+                   then id+                   else if has_bin o || has_bin n+                        then (binary f o n:>:)+                        else (canonize (hunk f 1 (linesPS o) (linesPS n)) +>+)++diff_from_empty :: (Prim -> Prim) -> FilePath -> FileContents+                -> (FL Prim -> FL Prim)+diff_from_empty inv f b =+    if b == B.empty+    then id+    else let p = if has_bin b+                 then binary f B.empty b+                 else if BC.last b == '\n'+                      then hunk f 1 [] $ init $ linesPS b+                      else hunk f 1 [B.empty] $ linesPS b+         in (inv p:>:)++{- | We take a B.ByteString which represents a file's contents, and we check to see+whether it is a 'binary' file or a 'textual' file. We define a textual file as any file+which does not contain two magic characters, '\0' (the NULL character on Unix) and '^Z'+(Control-Z, a DOS convention).++Note that to improve performance, we won't examine *all* of the string, because that+falls down on large files, but just the first 4096 characters. -}+has_bin :: FileContents -> Bool+has_bin = is_funky . B.take 4096+#endif++#ifndef GADT_WITNESSES+bin_patch :: FilePath -> B.ByteString -> B.ByteString+          -> FL Prim -> FL Prim+bin_patch f o n | B.null o && B.null n = id+                | otherwise = (binary f o n:>:)+#endif++#ifndef GADT_WITNESSES+diff_removed :: (FilePath -> FileType) -> [FilePath] -> Slurpy+             -> (FL Prim -> FL Prim)+diff_removed wt fps s+    | is_file s = case wt n of+                  TextFile -> diff_files f (get_filecontents s) empt+                            . (rmfile f:>:)+                  BinaryFile -> (bin_patch f+                                 (get_filecontents s) B.empty)+                              . (rmfile f:>:)+    | otherwise {- is_dir s -}+        = foldr (.) (rmdir f:>:)+        $ map (diff_removed wt (n:fps)) (get_dircontents s)+    where n = slurp_name s+          f = mk_filepath (n:fps)+#endif++sync :: String -> Slurpy -> Slurpy -> IO ()+sync path s1 s2+    | is_file s1 && is_file s2 &&+      (get_mtime s1 == undefined_time || get_mtime s1 /= get_mtime s2) &&+      get_length s1 == get_length s2 &&+      get_filecontents s1 == get_filecontents s2 =+        set_mtime n (get_mtime s2)+    | is_dir s1 && is_dir s2+        = n2 `seq` recur_sync n (get_dircontents s1) (get_dircontents s2)+    | otherwise = return ()+    where n2 = slurp_name s2+          n = path++"/"++n2+          set_mtime fname ctime = setFileTimes fname ctime ctime+                       `catchall` return ()+          recur_sync _ [] _ = return ()+          recur_sync _ _ [] = return ()+          recur_sync p (s:ss) (s':ss')+              | s < s' = recur_sync p ss (s':ss')+              | s > s' = recur_sync p (s:ss) ss'+              | otherwise = do sync p s s'+                               recur_sync p ss ss'+++cmp :: FilePath -> FilePath -> IO Bool+cmp p1 p2 = do+  dir1 <- doesDirectoryExist p1+  dir2 <- doesDirectoryExist p2+  file1 <- doesFileExist p1+  file2 <- doesFileExist p2+  if dir1 && dir2+     then cmpdir p1 p2+     else if file1 && file2+          then cmpfile p1 p2+          else return False+cmpdir :: FilePath -> FilePath -> IO Bool+cmpdir d1 d2 = do+  fn1 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d1+  fn2 <- fmap (filter (\f->f/="." && f /="..")) $ getDirectoryContents d2+  if sort fn1 /= sort fn2+     then return False+     else andIO $ map (\fn-> cmp (d1++"/"++fn) (d2++"/"++fn)) fn1+andIO :: [IO Bool] -> IO Bool+andIO (iob:iobs) = do b <- iob+                      if b then andIO iobs else return False+andIO [] = return True+cmpfile :: FilePath -> FilePath -> IO Bool+cmpfile f1 f2 = do+  h1 <- openBinaryFile f1 ReadMode+  h2 <- openBinaryFile f2 ReadMode+  l1 <- hFileSize h1+  l2 <- hFileSize h2+  if l1 /= l2+     then do hClose h1+             hClose h2+             putStrLn $ "different file lengths for "++f1++" and "++f2+             return False+     else do b <- hcmp h1 h2+             when (not b) $ putStrLn $ "files "++f1++" and "++f2++" differ"+             hClose h1+             hClose h2+             return b+    where hcmp h1 h2 = do c1 <- B.hGet h1 1024+                          c2 <- B.hGet h2 1024+                          if c1 /= c2+                             then return False+                             else if B.length c1 == 1024+                                  then hcmp h1 h2+                                  else return True
+ src/Darcs/Email.hs view
@@ -0,0 +1,234 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+module Darcs.Email ( make_email, read_email, formatHeader ) where++import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )+import Data.List ( isInfixOf )+import qualified UTF8 ( encode )+import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)++import ByteStringUtils (dropSpace, linesPS, betweenLinesPS )+import qualified Data.ByteString          as B  (ByteString, length, null, tail+                                                ,drop, head, concat, singleton+                                                ,pack, append, empty+                                                )+import qualified Data.ByteString.Char8    as BC (index, head, pack)+import Data.ByteString.Internal as B (c2w, createAndTrim)+import System.IO.Unsafe ( unsafePerformIO )+import Foreign.Ptr ( Ptr, plusPtr )+import Foreign.Storable ( poke )+import Data.Word ( Word8 )++-- line_max is maximum number of characters in an e-mail line excluding the CRLF+-- at the end. qline_max is the number of characters in a q-encoded or+-- quoted-printable-encoded line.+line_max, qline_max :: Int+line_max  = 78+qline_max = 75++-- | Formats an e-mail header by encoding any non-ascii characters using UTF-8+--   and Q-encoding, and folding lines at appropriate points. It doesn't do+--   more than that, so the header name and header value should be+--   well-formatted give or take line length and encoding. So no non-ASCII+--   characters within quoted-string, quoted-pair, or atom; no semantically+--   meaningful signs in names; no non-ASCII characters in the header name;+--   etcetera.+formatHeader :: String -> String -> B.ByteString+formatHeader headerName headerValue =+    B.append nameColon encodedValue+  where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding+        encodedValue = fold_and_encode (' ':headerValue)+                                       (B.length nameColon) False False++-- run through a string and encode non-ascii words and fold where appropriate.+-- the integer argument is the current position in the current line.+-- the string in the first argument must begin with whitespace, or be empty.+fold_and_encode :: String -> Int -> Bool -> Bool -> B.ByteString+fold_and_encode [] _ _               _         = B.empty+fold_and_encode s  p lastWordEncoded inMidWord = +  let newline  = B.singleton 10+      space    = B.singleton 32+      s2bs     = B.pack . map B.c2w+      -- the twelve there is the max number of ASCII chars to encode a single+      -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte+      safeEncChunkLength = (qline_max - B.length encoded_word_start+                                      - B.length encoded_word_end) `div` 12+      (curSpace, afterCurSpace) = break (not . (== ' ')) s+      (curWord,  afterCurWord)  = break (== ' ') afterCurSpace+      qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)+               | otherwise       = qEncode curWord+      mustEncode = inMidWord+                   || any (\c -> not (isPrint c) || (ord c) > 127) curWord+                   || length curWord > line_max - 1+                   || isInfixOf "=?" curWord+      mustFold+        | mustEncode && lastWordEncoded+            = p + 1 + B.length qEncWord > line_max+        | mustEncode+            = p + length curSpace + B.length qEncWord > line_max+        | otherwise+            = p + length curSpace + length curWord > line_max+      mustSplit = (B.length qEncWord > qline_max && mustEncode)+                  || length curWord > line_max - 1+      spaceToInsert | mustEncode && lastWordEncoded = space+                    | otherwise                     = s2bs curSpace+      wordToInsert+        | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)+        | mustEncode = qEncWord+        | otherwise  = s2bs curWord+      doneChunk | mustFold  = B.concat [newline, spaceToInsert, wordToInsert]+                | otherwise = B.concat [spaceToInsert, wordToInsert]+      (rest, nextP)+        | mustSplit+            = (drop safeEncChunkLength curWord ++ afterCurWord, qline_max + 1)+        | mustEncode && mustFold +            = (afterCurWord, B.length spaceToInsert + B.length wordToInsert)+        | otherwise+            = (afterCurWord, p + B.length doneChunk)+  in B.append doneChunk (fold_and_encode rest nextP mustEncode mustSplit)++-- | Turns a piece of string into a q-encoded block+--   Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.+--   It just takes a string and builds an encoded-word from it, it does not check+--   length or necessity.+qEncode :: String -> B.ByteString+qEncode s = B.concat [encoded_word_start,+                      encodedString,+                      encoded_word_end]+  where encodedString =  B.concat (map q_encode_char s)++encoded_word_start, encoded_word_end :: B.ByteString+encoded_word_start = B.pack (map B.c2w "=?UTF-8?Q?")+encoded_word_end   = B.pack (map B.c2w "?=")++-- turns a character into its q-encoded bytestring value. For most printable+-- ASCII characters, that's just the singleton bytestring with that char.+q_encode_char :: Char -> B.ByteString+q_encode_char c+    | c == ' '                          = c2bs '_'+    | isPrint c+      && not (c `elem` ['?', '=', '_'])+      && ord c < 128                    = c2bs c+    | otherwise                         = B.concat (map qbyte (UTF8.encode [c]))+  where c2bs = B.singleton . B.c2w+        -- qbyte turns a byte into its q-encoded "=hh" representation+        qbyte b = B.pack (map B.c2w ['='+                                    ,word8ToUDigit (b `div` 16)+                                    ,word8ToUDigit (b `mod` 16)+                                    ])+        word8ToUDigit :: Word8 -> Char+        word8ToUDigit = toUpper . intToDigit . fromIntegral++-- TODO is this doing mime encoding??+qpencode :: B.ByteString -> B.ByteString+qpencode s = unsafePerformIO+           -- Really only (3 + 2/75) * length or something in the worst case+           $ B.createAndTrim (4 * B.length s) (\buf -> encode s qline_max buf 0)++encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int+encode ps _ _ bufi | B.null ps = return bufi+encode ps n buf bufi = case B.head ps of+  c | c == newline ->+        do poke (buf `plusPtr` bufi) newline+           encode ps' qline_max buf (bufi+1)+    | n == 0 && B.length ps > 1 ->+        do poke (buf `plusPtr` bufi) equals+           poke (buf `plusPtr` (bufi+1)) newline+           encode ps qline_max buf (bufi + 2)+    | (c == tab || c == space) ->+        if B.null ps' || B.head ps' == newline+        then do poke (buf `plusPtr` bufi) c+                poke (buf `plusPtr` (bufi+1)) equals+                poke (buf `plusPtr` (bufi+2)) newline+                encode ps' qline_max buf (bufi + 3)+        else do poke (buf `plusPtr` bufi) c+                encode ps' (n - 1) buf (bufi + 1)+    | (c >= bang && c /= equals && c <= tilde) ->+        do poke (buf `plusPtr` bufi) c+           encode ps' (n - 1) buf (bufi + 1)+    | n < 3 ->+        encode ps 0 buf bufi+    | otherwise ->+        do let (x, y) = c `divMod` 16+               h1 = intToUDigit x+               h2 = intToUDigit y+           poke (buf `plusPtr` bufi) equals+           poke (buf `plusPtr` (bufi+1)) h1+           poke (buf `plusPtr` (bufi+2)) h2+           encode ps' (n - 3) buf (bufi + 3)+    where ps' = B.tail ps+          newline = B.c2w '\n'+          tab     = B.c2w '\t'+          space   = B.c2w ' '+          bang    = B.c2w '!'+          tilde   = B.c2w '~'+          equals  = B.c2w '='+          intToUDigit i+            | i >= 0  && i <= 9  = B.c2w '0' + i+            | i >= 10 && i <= 15 = B.c2w 'A' + i - 10+            | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"++qpdecode :: B.ByteString -> B.ByteString+qpdecode s = unsafePerformIO+             -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"+           $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)++decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int+decode [] _ bufi = return bufi+decode (ps:pss) buf bufi+ | B.null (dropSpace ps)+    = do poke (buf `plusPtr` bufi) newline+         decode pss buf (bufi+1)+ | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2+    = do poke (buf `plusPtr` bufi)+              (toWord8 $ digitToInt c1 * 16 + digitToInt c2)+         decode (B.drop 3 ps:pss) buf (bufi+1)+ | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi+ | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)+                  decode (B.tail ps:pss) buf (bufi+1)+    where is_equals = BC.head ps == '='+          c1 = BC.index ps 1+          c2 = BC.index ps 2+          newline = B.c2w '\n'+          toWord8 :: Int -> Word8+          toWord8 = fromIntegral++make_email :: String -> [(String, String)] -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc+make_email repodir headers mcontents bundle mfilename =+    text "DarcsURL:" <+> text repodir+ $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers+ $$ text "MIME-Version: 1.0"+ $$ text "Content-Type: multipart/mixed; boundary=\"=_\""+ $$ text ""+ $$ text "--=_"+ $$ (case mcontents of+       Just contents ->+            text "Content-Type: text/plain"+         $$ text "Content-Transfer-Encoding: quoted-printable"+         $$ text ""+         $$ packedString (qpencode (renderPS contents))+         $$ text ""+         $$ text "--=_"+       Nothing -> empty)+ $$ text "Content-Type: text/x-darcs-patch" <>+      (case mfilename of+         Just filename -> text "; name=\"" <> text filename <> text "\""+         Nothing -> empty)+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text "Content-Description: A darcs patch for your repository!"+ $$ text ""+ $$ packedString (qpencode (renderPS bundle))+ $$ text "--=_--"+ $$ text ""+ $$ text "."+ $$ text ""+ $$ text ""++read_email :: B.ByteString -> B.ByteString+read_email s =+    case betweenLinesPS+         (BC.pack "Content-Description: A darcs patch for your repository!")+         (BC.pack "--=_--") s of+    Nothing -> s -- if it wasn't an email in the first place, just pass along.+    Just s' -> qpdecode s'+
+ src/Darcs/External.hs view
@@ -0,0 +1,656 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.External (+    backupByRenaming, backupByCopying,+    copyFileOrUrl, speculateFileOrUrl, copyFilesOrUrls, copyLocal, cloneFile,+    cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths,+    fetchFilePS, gzFetchFilePS,+    sendEmail, generateEmail, sendEmailDoc, resendEmail,+    signString, verifyPS,+    execDocPipe, execPipeIgnoreError,+    getTermNColors,+    pipeDoc, pipeDocSSH, execSSH,+    maybeURLCmd,+    Cachable(Cachable, Uncachable, MaxAge),+    viewDoc, viewDocWith,+    sendmail_path, diff_program+  ) where++import Data.Maybe ( isJust, isNothing, maybeToList )+import Control.Monad ( when, zipWithM_, filterM, liftM2 )+import System.Exit ( ExitCode(..) )+import System.Environment ( getEnv )+import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,+                   openBinaryFile, IOMode( ReadMode ),+                   openBinaryTempFile,+                   hIsTerminalDevice, stdout, stderr, Handle )+import System.IO.Error ( isDoesNotExistError )+import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )+import System.Directory ( createDirectory, getDirectoryContents,+                          doesFileExist, doesDirectoryExist,+                          renameFile, renameDirectory, copyFile,+                          findExecutable )+import System.Process ( runProcess, runInteractiveProcess, waitForProcess )+import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )+import Control.Exception ( bracket, try, finally )+import Data.Char ( toUpper )+#if defined (HAVE_MAPI)+import Foreign.C ( CString, withCString )+#endif+#ifdef HAVE_MAPI+import Foreign.Ptr ( nullPtr )+import Darcs.Lock ( canonFilename, writeDocBinFile )+#endif+#ifdef HAVE_TERMINFO+import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )+#endif+import System.Posix.Files ( createLink )+import System.Directory ( createDirectoryIfMissing )+import System.FilePath.Posix ( (</>), takeDirectory, normalise )++import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL, NoLinks,+                                Verify, VerifySSL ) )+import Darcs.RepoPath ( AbsolutePath, toFilePath )+import Darcs.Utils ( withCurrentDirectory, breakCommand, get_viewer, ortryrunning, )+import Progress ( withoutProgress, progressList, debugMessage )++import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)+import qualified Data.ByteString as B (ByteString, empty, null, readFile -- ratify readFile: Just an import from ByteString+            ,hGetContents, writeFile, hPut, length -- ratify hGetContents: importing from ByteString+            ,take, concat, drop, isPrefixOf, singleton, append)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist )+import CommandLine ( parseCmd, addUrlencoded )+import URL ( copyUrl, copyUrlFirst, waitUrl )+import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) )+import URL ( Cachable(..) )+import Exec ( exec, Redirect(..), withoutNonBlock )+import Darcs.URL ( is_file, is_url, is_ssh )+import Darcs.Utils ( catchall )+import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,+                 simplePrinters,+                 text, empty, packedString, vcat, renderString )+import Darcs.Email ( formatHeader )++sendmail_path :: IO String+sendmail_path = do+  l <- filterM doesFileExist $ liftM2 (</>)+                [ "/usr/sbin", "/sbin", "/usr/lib" ]+                [ "sendmail" ]+  ex <- findExecutable "sendmail"+  when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program."+  return $ head $ maybeToList ex ++ l++diff_program :: IO String+diff_program = do+  l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]+  when (null l) $ fail "Cannot find the \"diff\" program."+  return $ head l++backupByRenaming :: FilePath -> IO ()+backupByRenaming = backupBy rename+ where rename x y = do+         isD <- doesDirectoryExist x+         if isD then renameDirectory x y else renameFile x y++backupByCopying :: FilePath -> IO ()+backupByCopying = backupBy copy+ where+  copy x y = do+    isD <- doesDirectoryExist x+    if isD then do createDirectory y+                   cloneTree (normalise x) (normalise y)+           else copyFile x y++backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()+backupBy backup f =+           do hasBF <- doesFileExist f+              hasBD <- doesDirectoryExist f+              when (hasBF || hasBD) $ helper (0::Int)+  where+  helper i = do existsF <- doesFileExist next+                existsD <- doesDirectoryExist next+                if (existsF || existsD)+                   then helper (i + 1)+                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"+                           backup f next+             where next = f ++ suffix+                   suffix = "-darcs-backup" ++ show i++-- | @fetchFile fileOrUrl cache@ returns the content of its argument+-- (either a file or an URL). If it has to download an url, then it+-- will use a cache as required by its second argument.+fetchFilePS :: String -> Cachable -> IO B.ByteString+fetchFilePS fou _ | is_file fou = B.readFile fou+fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl [] fou t cache+                                            B.readFile t++gzFetchFilePS :: String -> Cachable -> IO B.ByteString+gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou+gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl [] fou t cache+                                             gzReadFilePS t+++copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO ()+copyFileOrUrl opts fou out _     | is_file fou = copyLocal opts fou out+copyFileOrUrl _    fou out cache | is_url  fou = copyRemote fou out cache+copyFileOrUrl _    fou out _     | is_ssh  fou = copySSH fou out+copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou++speculateFileOrUrl :: String -> FilePath -> IO ()+speculateFileOrUrl fou out | is_url fou = speculateRemote fou out+                           | otherwise = return ()++copyLocal  :: [DarcsFlag] -> String -> FilePath -> IO ()+copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out+                       | otherwise = createLink fou out `catchall` cloneFile fou out++clonePaths :: FilePath -> FilePath -> [FilePath] -> IO ()+clonePaths source dest = mapM_ (clonePath source dest)++clonePath :: FilePath -> FilePath -> FilePath -> IO ()+clonePath source dest path+ = do let source' = source </> path+          dest' = dest </> path+      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 ("clonePath: Bad file " ++ source')+   `catch` fail ("clonePath: Bad file " ++ source </> path)++clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO ()+clonePartialsTree source dest = mapM_ (clonePartialTree source dest)++clonePartialTree :: FilePath -> FilePath -> FilePath -> IO ()+clonePartialTree source dest "" = cloneTree source dest+clonePartialTree source dest pref+ = do createDirectoryIfMissing True (dest </> takeDirectory pref)+      cloneSubTree (source </> pref) (dest </> pref)++cloneTree :: FilePath -> FilePath -> IO ()+cloneTree = cloneTreeExcept []++cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()+cloneTreeExcept except source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        fps <- getDirectoryContents source+        let fps' = filter (`notElem` (".":"..":except)) fps+            mk_source fp = source </> fp+            mk_dest   fp = dest   </> fp+        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+     else fail ("cloneTreeExcept: Bad source " ++ source)+   `catch` fail ("cloneTreeExcept: Bad source " ++ source)++cloneSubTree :: FilePath -> FilePath -> IO ()+cloneSubTree source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        createDirectory dest+        fps <- getDirectoryContents source+        let fps' = filter (`notElem` [".", ".."]) fps+            mk_source fp = source </> fp+            mk_dest   fp = dest   </> fp+        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+     else if isRegularFile fs then do+        cloneFile source dest+     else fail ("cloneSubTree: Bad source "++ source)+    `catch` (\e -> if isDoesNotExistError e+                   then return ()+                   else ioError e)++cloneFile :: FilePath -> FilePath -> IO ()+cloneFile = copyFile++maybeURLCmd :: String -> String -> IO(Maybe(String))+maybeURLCmd what url =+  do let prot = map toUpper $ takeWhile (/= ':') url+     fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))+             `catch` \_ -> return Nothing++speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable+#if defined(HAVE_CURL) || defined(HAVE_HTTP)+speculateRemote u v =+    do maybeget <- maybeURLCmd "GET" u+       case maybeget of+         Just _ -> return () -- can't pipeline these+         Nothing -> copyUrl u v Cachable+#else+speculateRemote u _ = maybeURLCmd "GET" u >> return ()+#endif++copyRemote :: String -> FilePath -> Cachable -> IO ()+copyRemote u v cache =+    do maybeget <- maybeURLCmd "GET" u+       case maybeget of+         Nothing -> copyRemoteNormal u v cache+         Just get ->+           do let (cmd,args) = breakCommand get+              r <- exec cmd (args++[u]) (Null, File v, AsIs)+              when (r /= ExitSuccess) $+                  fail $ "(" ++ get ++ ") failed to fetch: " ++ u++copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()+copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u++copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO ()+copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out+copyFilesOrUrls _ dou ns out c    | is_url  dou = copyRemotes dou ns out c+copyFilesOrUrls _ dou ns out _    | is_ssh  dou = copySSHs dou ns out+copyFilesOrUrls _ dou _  _   _    = fail $ "unknown transport protocol: "++dou+++copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO ()+copyLocals opts u ns d =+    doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns++copyRemotes :: String -> [String] -> FilePath -> Cachable -> IO()+copyRemotes u ns d cache =+    do maybeget <- maybeURLCmd "GET" u+       maybemget <- maybeURLCmd "MGET" u+       case (maybeget, maybemget) of+         (Nothing, _) -> copyRemotesNormal u ns d cache+         (Just _, Nothing) -> doWithPatches (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns+         (Just _, Just mget) -> mgetRemotes mget u ns d++stringToInt :: String -> Int -> Int+stringToInt num def = case reads num of [(x,"")] -> x+                                        _ -> def++mgetRemotes :: String -> String -> [String] -> FilePath -> IO()+mgetRemotes _ _ [] _ = return ()+mgetRemotes mget u ns d = do+    mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return ""+    let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns+        (cmd, args) = breakCommand mget+        urls = map (\n -> u++"/"++n) nsnow+    withCurrentDirectory d $ do+        r <- exec cmd (args++urls) (Null,Null,AsIs)+        when (r /= ExitSuccess) $+            fail $ unlines $+                ["(" ++ mget ++ ") failed to fetch files.",+                     "source directory: " ++ d,+                     "source files:"] ++ (upto 5 nsnow) +++                     ["still to go:"] ++ (upto 5 nslater)+    mgetRemotes mget u nslater d+    where+    upto :: Integer -> [String] -> [String]+    upto _ [] = []+    upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ]+    upto n (h : t) = h : (upto (n - 1) t)++copyRemotesNormal :: String -> [String] -> FilePath -> Cachable -> IO()+copyRemotesNormal u ns d cache =+    do mapM_ (\n -> copyUrl (u++"/"++n) (d++"/"++n) cache) ns+       doWithPatches (\n -> waitUrl (u++"/"++n)) ns++doWithPatches :: (String -> IO ()) -> [String] -> IO ()+doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches++-- | Run a command on a remote location without passing it any input or+--   reading its output.  Return its ExitCode+execSSH :: String -> String -> IO ExitCode+execSSH remoteAddr command =+    do (ssh, ssh_args) <- getSSH SSH remoteAddr+       debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command])+       withoutProgress $ do hid <- runProcess ssh (ssh_args++[remoteAddr,command])+                                   Nothing Nothing Nothing Nothing Nothing+                            waitForProcess hid++pipeDoc :: String -> [String] -> Doc -> IO ExitCode+pipeDoc c args inp = withoutNonBlock $ withoutProgress $+    do debugMessage $ unwords (c:args)+       (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing+       mvare <- newEmptyMVar+       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+                hPutStr stderr)+               `finally` putMVar mvare ())+       mvaro <- newEmptyMVar+       forkIO ((hGetContents o >>= -- ratify hGetContents: it's immediately consumed+                hPutStr stdout)+               `finally` putMVar mvaro ())+       hPutDoc i inp+       hClose i+       rval <- waitForProcess pid+       takeMVar mvare+       takeMVar mvaro+       when (rval == ExitFailure 127) $+            putStrLn $ "Command not found:\n   "++ show (c:args)+       return rval++pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode+pipeDocSSH remoteAddr args input =+    do (ssh, ssh_args) <- getSSH SSH remoteAddr+       pipeDoc ssh (ssh_args++ (remoteAddr:args)) input++sendEmail :: String -> String -> String -> String -> String -> String -> IO ()+sendEmail f t s cc scmd body =+  sendEmailDoc f t s cc scmd Nothing (text body)+++generateEmail+    :: Handle  -- ^ handle to write email to+    -> String  -- ^ From+    -> String  -- ^ To+    -> String  -- ^ Subject+    -> String  -- ^ CC+    -> Doc     -- ^ body+    -> IO ()+generateEmail h f t s cc body = do+     putHeader "To" t+     putHeader "From" f+     putHeader "Subject" s+     when (not (null cc)) (putHeader "Cc" cc)+     putHeader "X-Mail-Originator" "Darcs Version Control System"+     hPutDocLn h body+  where putHeader field value+            = B.hPut h (B.append (formatHeader field value) newline)+        newline = B.singleton 10++have_sendmail :: IO Bool+have_sendmail = (sendmail_path >> return True) `catch` (\_ -> return False)++-- | Send an email, optionally containing a patch bundle+--   (more precisely, its description and the bundle itself)+sendEmailDoc+  :: String           -- ^ from+  -> String           -- ^ to+  -> String           -- ^ subject+  -> String           -- ^ cc+  -> String           -- ^ send command+  -> Maybe (Doc, Doc) -- ^ (content,bundle)+  -> Doc              -- ^ body+  -> IO ()+sendEmailDoc _ "" _ "" _ _ _ = return ()+sendEmailDoc f "" s cc scmd mbundle body =+  sendEmailDoc f cc s "" scmd mbundle body+sendEmailDoc f t s cc scmd mbundle body = do+  use_sendmail <- have_sendmail+  if use_sendmail || scmd /= "" then do+    withOpenTemp $ \(h,fn) -> do+      generateEmail h f t s cc body+      hClose h+      withOpenTemp $ \(hat,at) -> do+        ftable' <- case mbundle of+                   Just (content,bundle) -> do+                       hPutDocLn hat $ bundle+                       return [ ('b', renderString content) , ('a', at) ]+                   Nothing ->+                       return [ ('b', renderString body) ]+        hClose hat+        let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'+        r <- execSendmail ftable scmd fn+        when (r /= ExitSuccess) $ fail ("failed to send mail to: "+                                       ++ t ++ cc_list cc+                                       ++ "\nPerhaps sendmail is not configured.")+#ifdef HAVE_MAPI+   else do+     r <- withCString t $ \tp ->+           withCString f $ \fp ->+            withCString cc $ \ccp ->+             withCString s $ \sp ->+              withOpenTemp $ \(h,fn) -> do+               hPutDoc h body+               hClose h+               writeDocBinFile "mailed_patch" body+               cfn <- canonFilename fn+               withCString cfn $ \pcfn ->+                c_send_email fp tp ccp sp nullPtr pcfn+     when (r /= 0) $ fail ("failed to send mail to: " ++ t)+#else+   else fail $ "no mail facility (sendmail or mapi) located at configure time!"+#endif+  where addressOnly a =+          case dropWhile (/= '<') a of+          ('<':a2) -> takeWhile (/= '>') a2+          _        -> a++        cc_list [] = []+        cc_list c = " and cc'ed " ++ c++resendEmail :: String -> String -> B.ByteString -> IO ()+resendEmail "" _ _ = return ()+resendEmail t scmd body = do+  use_sendmail <- have_sendmail+  if use_sendmail || scmd /= ""+   then do+    withOpenTemp $ \(h,fn) -> do+     hPutStrLn h $ "To: "++ t+     hPutStrLn h $ find_from (linesPS body)+     hPutStrLn h $ find_subject (linesPS body)+     hPutDocLn h $ fixit $ linesPS body+     hClose h+     let ftable = [('t',t)]+     r <-  execSendmail ftable scmd fn+     when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)+   else+#ifdef HAVE_MAPI+    fail "Don't know how to resend email with MAPI"+#else+    fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"+#endif+  where br            = BC.pack "\r"+        darcsurl      = BC.pack "DarcsURL:"+        content       = BC.pack "Content-"+        from_start    = BC.pack "From:"+        subject_start = BC.pack "Subject:"+        fixit (l:ls)+         | B.null l = packedString B.empty $$ vcat (map packedString ls)+         | l == br = packedString B.empty $$ vcat (map packedString ls)+         | B.take 9 l == darcsurl || B.take 8 l == content+            = packedString l $$ fixit ls+         | otherwise = fixit ls+        fixit [] = empty+        find_from (l:ls) | B.take 5 l == from_start = BC.unpack l+                         | otherwise = find_from ls+        find_from [] = "From: unknown"+        find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l+                            | otherwise = find_subject ls+        find_subject [] = "Subject: (no subject)"++execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode+execSendmail ftable scmd fn =+  if scmd == "" then do+     cmd <- sendmail_path+     exec cmd ["-i", "-t"] (File fn, Null, AsIs)+  else case parseCmd (addUrlencoded ftable) scmd of+         Right (arg0:opts, wantstdin) ->+           do let stdin = if wantstdin then File fn else Null+              exec arg0 opts (stdin, Null, AsIs)+         Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))+         _ -> fail $ ("failed to send mail, invalid sendmail-command")++#ifdef HAVE_MAPI+foreign import ccall "win32/send_email.h send_email" c_send_email+             :: CString -> {- sender -}+                CString -> {- recipient -}+                CString -> {- cc -}+                CString -> {- subject -}+                CString -> {- body -}+                CString -> {- path -}+                IO Int+#endif++execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString+execPSPipe c args ps = fmap renderPS+                     $ execDocPipe c args+                     $ packedString ps++execDocPipe :: String -> [String] -> Doc -> IO Doc+execDocPipe c args instr = withoutProgress $+    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing+       forkIO $ hPutDoc i instr >> hClose i+       mvare <- newEmptyMVar+       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+                hPutStr stderr)+               `finally` putMVar mvare ())+       out <- B.hGetContents o+       rval <- waitForProcess pid+       takeMVar mvare+       case rval of+         ExitFailure ec ->fail $ "External program '"++c+++                          "' failed with exit code "++ show ec+         ExitSuccess -> return $ packedString out++-- The following is needed for diff, which returns non-zero whenever+-- the files differ.+execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc+execPipeIgnoreError c args instr = withoutProgress $+    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing+       forkIO $ hPutDoc i instr >> hClose i+       mvare <- newEmptyMVar+       forkIO ((hGetContents e >>= -- ratify hGetContents: it's immediately consumed+                hPutStr stderr)+               `finally` putMVar mvare ())+       out <- B.hGetContents o+       waitForProcess pid+       takeMVar mvare+       return $ packedString out++signString :: [DarcsFlag] -> Doc -> IO Doc+signString [] d = return d+signString (Sign:_) d = signPGP [] d+signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d+signString (SignSSL idf:_) d = signSSL idf d+signString (_:os) d = signString os d++signPGP :: [String] -> Doc -> IO Doc+signPGP args t = execDocPipe "gpg" ("--clearsign":args) t++signSSL :: String -> Doc -> IO Doc+signSSL idfile t =+    withTemp $ \cert -> do+    opensslPS ["req", "-new", "-key", idfile,+               "-outform", "PEM", "-days", "365"]+                (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")+                >>= opensslPS ["x509", "-req", "-extensions",+                               "v3_ca", "-signkey", idfile,+                               "-outform", "PEM", "-days", "365"]+                >>= opensslPS ["x509", "-outform", "PEM"]+                >>= B.writeFile cert+    opensslDoc ["smime", "-sign", "-signer", cert,+                "-inkey", idfile, "-noattr", "-text"] t+    where opensslDoc = execDocPipe "openssl"+          opensslPS = execPSPipe "openssl"+++verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString)+verifyPS [] ps = return $ Just ps+verifyPS (Verify pks:_) ps = verifyGPG pks ps+verifyPS (VerifySSL auks:_) ps = verifySSL auks ps+verifyPS (_:os) ps = verifyPS os ps++verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifyGPG goodkeys s =+    withOpenTemp $ \(th,tn) -> do+      B.hPut th s+      hClose th+      rval <- exec "gpg"  ["--batch","--no-default-keyring",+                           "--keyring",fix_path $ toFilePath goodkeys, "--verify"]+                           (File tn, Null, Null)+      case rval of+          ExitSuccess -> return $ Just gpg_fixed_s+          _ -> return Nothing+      where gpg_fixed_s = let+                not_begin_signature x =+                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"+                    &&+                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"+                in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s+            fix_line x | B.length x < 3 = x+                       | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x+                       | otherwise = x+#if defined(WIN32)+            fix_sep c | c=='/' = '\\'   | otherwise = c+            fix_path p = map fix_sep p+#else+            fix_path p = p+#endif++verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifySSL goodkeys s = do+    certdata <- opensslPS ["smime", "-pk7out"] s+                >>= opensslPS ["pkcs7", "-print_certs"]+    cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata+    let key_used = B.concat $ tail $+                   takeWhile (/= BC.pack"-----END PUBLIC KEY-----")+                           $ linesPS cruddy_pk+        in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)+              if not $ key_used `elem` allowed_keys+                then return Nothing -- Not an allowed key!+                else withTemp $ \cert ->+                     withTemp $ \on ->+                     withOpenTemp $ \(th,tn) -> do+                     B.hPut th s+                     hClose th+                     B.writeFile cert certdata+                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",+                                             cert, "-certfile", cert]+                                             (File tn, File on, Null)+                     case rval of+                       ExitSuccess -> Just `fmap` B.readFile on+                       _ -> return Nothing+    where opensslPS = execPSPipe "openssl"+++{-+  - This function returns number of colors supported by current terminal+  - or -1 if color output not supported or error occured.+  - Terminal type determined by TERM env. variable.+  -}+getTermNColors :: IO Int+#ifdef HAVE_TERMINFO+getTermNColors = do+  t <- setupTermFromEnv+  return $ case getCapability t $ tiGetNum "colors" of+    Nothing -> (-1)+    Just x -> x+#else+getTermNColors = return (-1)+#endif++viewDoc :: Doc -> IO ()+viewDoc = viewDocWith simplePrinters++viewDocWith :: Printers -> Doc -> IO ()+viewDocWith pr msg = do+  isTerminal <- hIsTerminalDevice stdout+  if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)+     then do viewer <- get_viewer+             pipeDocToPager viewer [] pr msg+               `ortryrunning` pipeDocToPager  "less" [] pr msg+               `ortryrunning` pipeDocToPager  "more" [] pr msg+#ifdef WIN32+               `ortryrunning` pipeDocToPager  "more.com" [] pr msg+#endif+               `ortryrunning` pipeDocToPager "" [] pr msg+     else pipeDocToPager "" [] pr msg+  return ()+              where lengthGreaterThan n _ | n <= 0 = True+                    lengthGreaterThan _ [] = False+                    lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs++pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode++pipeDocToPager "" _ pr inp = do+  putDocLnWith pr inp+  return ExitSuccess++pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do+  tmp <- tempdir_loc+  bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->+    do hPutDocWith pr fh inp+       hClose fh+       bracket (openBinaryFile fn ReadMode) hClose $ \h ->+         do x <- do pid <- runProcess c args Nothing Nothing (Just h) Nothing Nothing+                    waitForProcess pid+            when (x == ExitFailure 127) $+                 putStrLn $ "Command not found:\n   "++ show (c:args)+            return x+  where+    cleanup (f,h) = do try $ hClose h+                       removeFileMayNotExist f
+ src/Darcs/FilePathMonad.hs view
@@ -0,0 +1,83 @@+-- Copyright (C) 2005 David Roundy+--+-- 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.+++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.FilePathMonad ( FilePathMonad, withFilePaths ) where++import Control.Monad ( MonadPlus, mplus, mzero )+import Data.Maybe ( catMaybes )++import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )+import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir,+                              norm_path, movedirfilename )+#include "impossible.h"++data FilePathMonad a = FPM ([FileName] -> ([FileName], a))++withFilePaths :: [FilePath] -> FilePathMonad a -> [FilePath]+withFilePaths fps (FPM x) = map fn2fp $ fst $ x $ map fp2fn fps++instance Functor FilePathMonad where+    fmap f m = m >>= return . f++instance Monad FilePathMonad where+    (FPM x) >>= y = FPM z where z fs = case x fs of+                                       (fs', a) -> case y a of+                                                   FPM yf -> yf fs'+    return x = FPM $ \fs -> (fs, x)++instance MonadPlus FilePathMonad where+    mzero = fail "mzero FilePathMonad" -- yuck!+    a `mplus` _ = a++instance ReadableDirectory FilePathMonad where+    -- We can't check it actually is a directory here+    mDoesDirectoryExist d =+        FPM $ \fs -> (fs, norm_path d `elem` map norm_path fs)+    -- We can't check it actually is a file here+    mDoesFileExist f =+        FPM $ \fs -> (fs, norm_path f `elem` map norm_path fs)+    mInCurrentDirectory d (FPM j) =+        FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs)+        where indir f = do (d',f') <- break_on_dir f+                           if d == d' then Just f'+                                      else Nothing+    mGetDirectoryContents =+        FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs)+    mReadFilePS = bug "can't mReadFilePS in FilePathMonad!"++instance WriteableDirectory FilePathMonad where+    mWithCurrentDirectory d (FPM j) =+        FPM $ \fs ->+        let splitfs = map splitf fs+            others = catMaybes $ map snd splitfs+            (myfs, a) = j $ catMaybes $ map fst splitfs+            splitf f = case break_on_dir f of+                       Just (d', f') | d' == d -> (Just f', Nothing)+                       _ -> (Nothing, Just f)+        in (others ++ myfs, a)+    mSetFileExecutable _ _ = return ()+    mWriteFilePS _ _ = return ()+    mCreateDirectory _ = return ()+    mRemoveFile f = FPM $ \fs -> (filter (/= f) fs, ())+    mRemoveDirectory f = FPM $ \fs -> (filter (/= f) fs, ())+    mRename a b = FPM $ \fs -> (map (movedirfilename a b) fs, ())+    mModifyFilePS _ _ = return ()+    mModifyFilePSs _ _ = return ()
+ src/Darcs/Flags.hs view
@@ -0,0 +1,116 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++module Darcs.Flags ( DarcsFlag( .. ), Compression( .. ), compression, want_external_merge, isInteractive,+                     maxCount,+                   ) where+import Darcs.Patch.MatchData ( PatchMatch )+import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd )++-- | The 'DarcsFlag' type is a list of all flags that can ever be+-- passed to darcs, or to one of its commands.+data DarcsFlag = Help | ListOptions | NoTest | Test+               | OnlyChangesToFiles+               | LeaveTestDir | NoLeaveTestDir+               | Timings | Debug | DebugVerbose | DebugHTTP+               | Verbose | NormalVerbosity | Quiet+               | Target String | Cc String+               | Output AbsolutePathOrStd | OutputAutoName AbsolutePath+               | Subject String | InReplyTo String+               | SendmailCmd String | Author String | PatchName String+               | OnePatch String | SeveralPatch String+               | AfterPatch String | UpToPatch String+               | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int+               | NumberPatches+               | OneTag String | AfterTag String | UpToTag String+               | Context AbsolutePath | Count+               | LogFile AbsolutePath | RmLogFile+               | DistName String | All+               | Recursive | NoRecursive | Reorder+               | RestrictPaths | DontRestrictPaths+               | AskDeps | NoAskDeps | IgnoreTimes | LookForAdds | NoLookForAdds+               | AnyOrder | CreatorHash String+               | Intersection | Union | Complement+               | Sign | SignAs String | NoSign | SignSSL String+               | HappyForwarding+               | Verify AbsolutePath | VerifySSL AbsolutePath+               | SSHControlMaster | NoSSHControlMaster+               | EditDescription | NoEditDescription+               | Toks String+               | EditLongComment | NoEditLongComment | PromptLongComment+               | AllowConflicts | MarkConflicts | NoAllowConflicts+               | Boring | AllowCaseOnly | AllowWindowsReserved+               | DontGrabDeps | DontPromptForDependencies | PromptForDependencies+               | Compress | NoCompress | UnCompress+               | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String+               | NewRepo String+               | Reply String | ApplyAs String+               | MachineReadable | HumanReadable+               | Pipe | Interactive+               | DiffCmd String+               | ExternalMerge String | Summary | NoSummary+               | Unified | Reverse+               | CheckPoint | Partial | Complete | Lazy | Ephemeral+               | FixFilePath AbsolutePath AbsolutePath | DiffFlags String+               | XMLOutput+               | ForceReplace+               | OnePattern PatchMatch | SeveralPattern PatchMatch+               | AfterPattern PatchMatch | UpToPattern PatchMatch+               | NonApply | NonVerify | NonForce+               | DryRun | SetDefault | NoSetDefault+               | FancyMoveAdd | NoFancyMoveAdd+               | Disable | SetScriptsExecutable | DontSetScriptsExecutable+               | UseHashedInventory | UseOldFashionedInventory+               | UseFormat2+               | PristinePlain | PristineNone | NoUpdateWorking+               | Sibling AbsolutePath | Relink | RelinkPristine | NoLinks+               | Files | NoFiles | Directories | NoDirectories+               | Pending | NoPending+               | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook+               | PrehookCmd String  | NoPrehook  | AskPrehook  | RunPrehook+               | UMask String+               | StoreInMemory+               | HTTPPipelining | NoHTTPPipelining+               | NoCache+               | AllowUnrelatedRepos+               | Check | Repair+               | NullFlag+                 deriving ( Eq, Show )++data Compression = NoCompression | GzipCompression+compression :: [DarcsFlag] -> Compression+compression f | NoCompress `elem` f = NoCompression+              | otherwise = GzipCompression++want_external_merge :: [DarcsFlag] -> Maybe String+want_external_merge [] = Nothing+want_external_merge (ExternalMerge c:_) = Just c+want_external_merge (_:fs) = want_external_merge fs++isInteractive :: [DarcsFlag] -> Bool+isInteractive = isInteractive_ True+    where+      isInteractive_ def [] = def+      isInteractive_ _ (Interactive:_) = True+      isInteractive_ _ (All:_) = False+      isInteractive_ _ (DryRun:fs) = isInteractive_ False fs+      isInteractive_ def (_:fs) = isInteractive_ def fs++maxCount :: [DarcsFlag] -> Maybe Int+maxCount (MaxCount n : _) = Just n+maxCount (_:xs) = maxCount xs+maxCount [] = Nothing
+ src/Darcs/Global.hs view
@@ -0,0 +1,158 @@+-- Copyright (C) 2005 Tomasz Zielonka+--+-- 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.++-- | This was originally Tomasz Zielonka's AtExit module, slightly generalised+-- to include global variables.  Here, we attempt to cover broad, global+-- features, such as exit handlers.  These features slightly break the Haskellian+-- purity of darcs, in favour of programming convenience.+module Darcs.Global ( atexit, with_atexit,+                      sshControlMasterDisabled, setSshControlMasterDisabled,+                      verboseMode, setVerboseMode,+                      timingsMode, setTimingsMode,+                      whenDebugMode, withDebugMode, setDebugMode,+                      debugMessage, debugFail, putTiming,+#ifdef HAVE_HASKELL_ZLIB+                      addCRCWarning, getCRCWarnings, resetCRCWarnings,+#endif+                      darcsdir+    ) where++import Control.Monad ( when )+import Control.Concurrent.MVar+import Control.Exception (bracket_, catch, block, unblock)+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )+#ifdef HAVE_HASKELL_ZLIB+import Data.IORef ( modifyIORef )+#endif+import System.IO.Unsafe (unsafePerformIO)+import System.IO (hPutStrLn, hPutStr, stderr)+import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )+import Prelude hiding (catch)++{-# NOINLINE atexit_actions #-}+atexit_actions :: MVar (Maybe [IO ()])+atexit_actions = unsafePerformIO (newMVar (Just []))++-- | Registers an IO action to run just before darcs exits.  Useful+-- for removing temporary files and directories, for example.+atexit :: IO () -> IO ()+atexit action = do+    modifyMVar_ atexit_actions $ \ml -> do+        case ml of+            Just l -> do+                return (Just (action : l))+            Nothing -> do+                hPutStrLn stderr "It's too late to use atexit"+                return Nothing++with_atexit :: IO a -> IO a+with_atexit prog = do+    bracket_+        (return ())+        exit+        prog+  where+    exit = block $ do+        Just actions <- swapMVar atexit_actions Nothing+        -- from now on atexit will not register new actions+        mapM_ runAction actions+    runAction action = do+        catch (unblock action) $ \exn -> do+            hPutStrLn stderr $ "Exception thrown by an atexit registered action:"+            hPutStrLn stderr $ show exn+++-- Write-once-read-many global variables make it easier to implement flags, such+-- as --no-ssh-cm.  Using global variables reduces the number of parameters+-- that we have to pass around, but it is rather unsafe and should be used sparingly.++{-# NOINLINE _debugMode #-}+_debugMode :: IORef Bool+_debugMode = unsafePerformIO $ newIORef False++setDebugMode :: IO ()+setDebugMode = writeIORef _debugMode True++whenDebugMode :: IO () -> IO ()+whenDebugMode j = do b <- readIORef _debugMode+                     when b j++withDebugMode :: (Bool -> IO a) -> IO a+withDebugMode j = readIORef _debugMode >>= j+++debugMessage :: String -> IO ()+debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m++debugFail :: String -> IO a+debugFail m = debugMessage m >> fail m++putTiming :: IO ()+putTiming = when timingsMode $ do t <- getClockTime >>= toCalendarTime+                                  hPutStr stderr (calendarTimeToString t++": ")++{-# NOINLINE _timingsMode #-}+_timingsMode :: IORef Bool+_timingsMode = unsafePerformIO $ newIORef False++setTimingsMode :: IO ()+setTimingsMode = writeIORef _timingsMode True++{-# NOINLINE timingsMode #-}+timingsMode :: Bool+timingsMode = unsafePerformIO $ readIORef _timingsMode++{-# NOINLINE _verboseMode #-}+_verboseMode :: IORef Bool+_verboseMode = unsafePerformIO $ newIORef False++setVerboseMode :: IO ()+setVerboseMode = writeIORef _verboseMode True++{-# NOINLINE verboseMode #-}+verboseMode :: Bool+verboseMode = unsafePerformIO $ readIORef _verboseMode++{-# NOINLINE _sshControlMasterDisabled #-}+_sshControlMasterDisabled :: IORef Bool+_sshControlMasterDisabled = unsafePerformIO $ newIORef False++setSshControlMasterDisabled :: IO ()+setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True++{-# NOINLINE sshControlMasterDisabled #-}+sshControlMasterDisabled :: Bool+sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled++#ifdef HAVE_HASKELL_ZLIB+type CRCWarningList = [FilePath]+{-# NOINLINE _crcWarningList #-}+_crcWarningList :: IORef CRCWarningList+_crcWarningList = unsafePerformIO $ newIORef []++addCRCWarning :: FilePath -> IO ()+addCRCWarning fp = modifyIORef _crcWarningList (fp:)++getCRCWarnings :: IO [FilePath]+getCRCWarnings = readIORef _crcWarningList++resetCRCWarnings :: IO ()+resetCRCWarnings = writeIORef _crcWarningList []+#endif++darcsdir :: String+darcsdir = "_darcs"
+ src/Darcs/Gorsvet.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}++-- Copyright (C) 2009 Petr Rockai+--+-- Permission is hereby granted, free of charge, to any person+-- obtaining a copy of this software and associated documentation+-- files (the "Software"), to deal in the Software without+-- restriction, including without limitation the rights to use, copy,+-- modify, merge, publish, distribute, sublicense, and/or sell copies+-- of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be+-- included in all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+-- SOFTWARE.++#include "gadts.h"++module Darcs.Gorsvet where++import Prelude hiding ( read, filter, writeFile, readFile )++-- darcs stuff+import ByteStringUtils( is_funky )+import Darcs.Repository ( Repository, slurp_pending )+import Darcs.Repository.Internal ( read_pending )+import Darcs.External ( backupByCopying )+import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply+                   , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert)+import Darcs.Ordered ( FL(..), (+>+) )+import Darcs.Repository.Prefs ( filetype_function, FileType(..) )+import Darcs.IO+import Darcs.Sealed ( Sealed(Sealed), seal )+import Darcs.Patch( apply_to_filepaths )+import Darcs.Patch.TouchesFiles ( choose_touching )+import Darcs.Patch.FileName ( fn2fp )++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Control.Monad.State.Strict+import System.Directory( removeFile, doesFileExist )+import Data.Maybe+import Data.List( union )++import Darcs.Arguments ( DarcsFlag( LookForAdds, IgnoreTimes ) )+import Darcs.RepoPath ( SubPath, sp2fn )++import Text.Regex( matchRegex )+import Darcs.Repository.Prefs( boring_regexps )++import Storage.Hashed+import Storage.Hashed.Tree+import qualified Storage.Hashed.Index as I+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Darcs( darcsFormatHash, darcsTreeHash )+import Storage.Hashed.Monad+    ( virtualTreeIO, hashedTreeIO, plainTreeIO+    , unlink, rename, createDirectory, writeFile+    , readFile -- ratify readFile: haskell_policy je natvrdlá+    , cwd, tree, TreeIO )+import Storage.Hashed++floatFn = floatPath . fn2fp++instance ReadableDirectory TreeIO where+    mDoesDirectoryExist d = gets (\x -> isJust $ findTree (tree x) (floatFn d))+    mDoesFileExist f = gets (\x -> isJust $ findFile (tree x) (floatFn f))+    mInCurrentDirectory d action = do -- TODO bracket?+      wd <- gets cwd+      modify (\x -> x { cwd = floatFn d })+      x <- action+      modify (\x -> x { cwd = wd })+      return x+    mGetDirectoryContents = error "get dir contents"+    mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...+                       return $ BS.concat (BL.toChunks x)++instance WriteableDirectory TreeIO where+    mWithCurrentDirectory = mInCurrentDirectory+    mSetFileExecutable _ _ = return ()+    mWriteFilePS p ps = writeFile -- ratify readFile: haskell_policy is stupid.+          (floatFn p) (BL.fromChunks [ps])+    mCreateDirectory p = createDirectory (floatFn p)+    mRename from to = rename (floatFn from) (floatFn to)+    mRemoveDirectory = unlink . floatFn+    mRemoveFile = unlink . floatFn++treeDiff :: (FilePath -> FileType) -> Tree -> Tree -> IO (FL Prim C(x y))+#ifdef GADT_WITNESSES+treeDiff = undefined -- Sigh.+#else+treeDiff ft t1 t2 = do+  (from, to) <- diffTrees t1 t2+  diffs <- sequence $ zipTrees diff from to+  return $ foldr (+>+) NilFL diffs+    where diff :: AnchoredPath -> Maybe TreeItem -> Maybe TreeItem+               -> IO (FL Prim)+          diff _ (Just (SubTree _)) (Just (SubTree _)) = return NilFL+          diff p (Just (SubTree _)) Nothing =+              return $ rmdir (anchorPath "" p) :>: NilFL+          diff p Nothing (Just (SubTree _)) =+              return $ adddir (anchorPath "" p) :>: NilFL+          diff p Nothing b'@(Just (File _)) =+              do diff <- diff p (Just (File emptyBlob)) b'+                 return $ addfile (anchorPath "" p) :>: diff+          diff p a'@(Just (File _)) Nothing =+              do diff <- diff p a' (Just (File emptyBlob))+                 return $ diff +>+ (rmfile (anchorPath "" p) :>: NilFL)+          diff p (Just (File a')) (Just (File b')) =+              do a <- read a'+                 b <- read b'+                 let path = anchorPath "" p+                 case ft path of+                   TextFile | no_bin a && no_bin b ->+                                return $ text_diff path a b+                   _ -> return $ if a /= b+                                    then binary path (strict a) (strict b) :>: NilFL+                                    else NilFL+          diff p _ _ = fail $ "Missing case at path " ++ show p+          text_diff p a b+              | BL.null a && BL.null b = NilFL+              | BL.null a = diff_from_empty p b+              | BL.null b = diff_to_empty p a+              | otherwise = line_diff p (lines a) (lines b)+          line_diff p a b = canonize (hunk p 1 a b)+          diff_to_empty p x | BL.last x == '\n' = line_diff p (init $ lines x) []+                            | otherwise = line_diff p (lines x) [BS.empty]+          diff_from_empty p x = invert (diff_to_empty p x)+          no_bin = not . is_funky . strict . BL.take 4096+          lines = map strict . BL.split '\n'+          strict = BS.concat . BL.toChunks+#endif++readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree+readRecordedAndPending repo = do+  pristine <- readDarcsPristine "."+  Sealed pending <- pendingChanges repo []+  (_, t) <- virtualTreeIO (apply [] pending) pristine+  return t++pendingChanges :: (RepoPatch p) => Repository p C(r u t)+               -> [SubPath] -> IO (Sealed (FL Prim C(r)))+pendingChanges repo paths = do+  slurp_pending repo -- XXX: only here to get us the "pending conflicts" check+                     -- that I don't know yet how to implement properly+  Sealed pending <- read_pending repo+  let files = map (fn2fp . sp2fn) paths+      pre_files = apply_to_filepaths (invert pending) files+      relevant = case paths of+                   [] -> seal pending+                   _ -> choose_touching pre_files pending+  return relevant++readIndex :: IO Tree+readIndex = I.readIndex "_darcs/index" darcsTreeHash++unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)+                  -> [SubPath] -> IO (FL Prim C(r y))+unrecordedChanges opts repo paths = do+  checkIndex repo+  pristine <- readDarcsPristine "."+  Sealed pending <- pendingChanges repo paths+  (_, current') <- virtualTreeIO (apply [] pending) pristine+  relevant <- restrictSubpaths repo paths+  nonboring <- restrictBoring++  let current = relevant current'+  working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of+               (False, False) -> do+                 all <- readIndex+                 expand (relevant all)+               (False, True) -> do+                 guide <- expand current+                 all <- readPlainTree "."+                 return $ relevant $ (restrict guide) all+               (True, _) -> do+                 all <- readPlainTree "."+                 return $ relevant $ nonboring all++  ft <- filetype_function+  diff <- treeDiff ft current working+  return $ sort_coalesceFL (pending +>+ diff)++applyToTentativePristine _ patches =+    do pristine <- readDarcsPristine "."+       (_, tree) <- hashedTreeIO (apply [] patches)+                    pristine "_darcs/pristine.hashed"+       BS.writeFile "_darcs/tentative_pristine" $+         BS.concat [BS.pack "pristine:"+                   , darcsFormatHash (fromJust $ treeHash tree)]++applyToWorking :: (RepoPatch p) => Repository p C(r u t)+               -> Sealed (FL Prim C(u)) -> IO Tree+applyToWorking _ (Sealed patches) =+    do working <- readIndex+       snd `fmap` plainTreeIO (apply [] patches) working "."++filter_paths files =+    \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files++restrict_paths files = if null files+                          then id+                          else filter $ filter_paths files++restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn)++restrictSubpaths repo subpaths = do+  Sealed pending <- read_pending repo+  let paths = map (fn2fp . sp2fn) subpaths+      paths' = paths `union` apply_to_filepaths pending paths+      anchored = map floatPath paths'+  return $ restrict_paths anchored++restrictBoring = do+  boring <- boring_regexps+  let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False+      boring' p _ = not $ any (\rx -> isJust $ matchRegex rx p') boring+          where p' = anchorPath "" p+  return $ filter boring'++checkIndex repo = do+  invalid <- doesFileExist "_darcs/index_invalid"+  exist <- doesFileExist "_darcs/index"+  when (not exist || invalid) $ updateIndex repo+  when invalid $ removeFile "_darcs/index_invalid"++updateIndex repo = do+  pristine <- readRecordedAndPending repo >>= expand+  I.updateIndexFrom "_darcs/index" darcsTreeHash pristine >>= expand+  return ()++invalidateIndex _ = do+  BS.writeFile "_darcs/index_invalid" BS.empty
+ src/Darcs/Hopefully.hs view
@@ -0,0 +1,185 @@+-- Copyright (C) 2006 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Hopefully ( Hopefully, PatchInfoAnd,+                         piap, n2pia, patchInfoAndPatch,+                         conscientiously, hopefully, info,+                         hopefullyM, createHashed, extractHash,+                         actually, unavailable ) where++import System.IO.Unsafe ( unsafeInterleaveIO )++import Darcs.SignalHandler ( catchNonSignal )+import Printer ( Doc, renderString, errorDoc, text, ($$) )+import Darcs.Patch.Info ( PatchInfo, human_friendly, idpatchinfo )+import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )+import Darcs.Patch.Prim ( Effect(..), Conflict(..) )+import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),+                            ShowPatch(..), Commute(..) )+import Darcs.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) )+import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal )+import Darcs.Utils ( prettyException )++-- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a+-- form adapted to darcs patches. The @C@ @(x y)@ represents the type+-- witness for the patch that should be there. The @Hopefully@ type+-- just tells whether we expect the patch to be hashed or not, and+-- 'SimpleHopefully' does the real work of emulating+-- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and+-- @Hashed hash sh@ represents an expected hashed patch with its hash.+data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y))++-- | @SimpleHopefully@ is a variant of @Either String@ adapted for+-- type witnesses. @Actually@ is the equivalent of @Right@, while+-- @Unavailable@ is @Left@.+data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String++-- | @'PatchInfoAnd' p C(a b)@ represents a hope we have to get a+-- patch through its info. We're not sure we have the patch, but we+-- know its info.+data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b))++fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)+fmapH f (Hopefully sh) = Hopefully (ff sh)+    where ff (Actually a) = Actually (f a)+          ff (Unavailable e) = Unavailable e+fmapH f (Hashed h sh) = Hashed h (ff sh)+    where ff (Actually a) = Actually (f a)+          ff (Unavailable e) = Unavailable e++info :: PatchInfoAnd p C(a b) -> PatchInfo+info (PIAP i _) = i++-- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.+piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b)+piap i p = PIAP i (Hopefully $ Actually p)++-- | @n2pia@ creates a PatchInfoAnd represeting a @Named@ patch.+n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y)+n2pia x = patch2patchinfo x `piap` x++patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b)+patchInfoAndPatch =  PIAP++-- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd'+-- value. If it fails, it outputs an error \"failed to read patch:+-- \<description of the patch>\". We get the description of the patch+-- from the info part of 'hp'+hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b)+hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e++-- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'.+-- If it fails, it applies the error handling function @er@ to a description+-- of the patch info component of @hp@.+conscientiously :: (Doc -> Doc)+                -> PatchInfoAnd p C(a b) -> Named p C(a b)+conscientiously er (PIAP pinf hp) =+    case hopefully2either hp of+      Right p -> p+      Left e -> errorDoc $ er (human_friendly pinf $$ text e)++-- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a+-- monad instead of erroring.+hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b))+hopefullyM (PIAP pinf hp) = case hopefully2either hp of+                              Right p -> return p+                              Left e -> fail $ renderString (human_friendly pinf $$ text e)++-- Any recommendations for a nice adverb to name the below?+hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y))+hopefully2either (Hopefully (Actually p)) = Right p+hopefully2either (Hashed _ (Actually p)) = Right p+hopefully2either (Hopefully (Unavailable e)) = Left e+hopefully2either (Hashed _ (Unavailable e)) = Left e++actually :: a C(x y) -> Hopefully a C(x y)+actually = Hopefully . Actually++createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x)))+createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)+  where+  f' = do Sealed x <- f h+          return (Sealed (Actually x))+  handler e = return $ seal $ Unavailable $ prettyException e++extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String+extractHash (PIAP _ (Hashed s _)) = Right s+extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp++unavailable :: String -> Hopefully a C(x y)+unavailable = Hopefully . Unavailable++instance MyEq p => MyEq (PatchInfoAnd p) where+    unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2++--instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where+instance Invert p => Invert (PatchInfoAnd p) where+    identity = PIAP idpatchinfo (actually identity)+    invert (PIAP i p) = PIAP i (invert `fmapH` p)++instance (Conflict p, Effect p, ShowPatch p) => ShowPatch (PatchInfoAnd p) where+    showPatch (PIAP n p) = case hopefully2either p of+                           Right x -> showPatch x+                           Left _ -> human_friendly n+    showContextPatch s (PIAP n p) = case hopefully2either p of+                                    Right x -> showContextPatch s x+                                    Left _ -> human_friendly n+    description (PIAP n _) = human_friendly n+    summary (PIAP n p) = case hopefully2either p of+                         Right x -> summary x+                         Left _ -> human_friendly n+    showNicely (PIAP n p) = case hopefully2either p of+                            Right x -> showNicely x+                            Left _ -> human_friendly n++instance Commute p => Commute (PatchInfoAnd p) where+    commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)+                          return $ (info y `piap` y') :> (info x `piap` x')+    list_touched_files = list_touched_files . hopefully+    merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of+                       y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')++instance Apply p => Apply (PatchInfoAnd p) where+    apply opts p = apply opts $ hopefully p+    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p+                            case mp' of+                              Nothing -> return Nothing+                              Just (e,p') -> return $ Just (e, n2pia p')++instance ReadPatch p => ReadPatch (PatchInfoAnd p) where+    readPatch' wanteof = do x <- readPatch' wanteof+                            case x of+                              Just (Sealed p) -> return $ Just $ Sealed $ n2pia p+                              Nothing -> return Nothing++instance Effect p => Effect (PatchInfoAnd p) where+    effect = effect . hopefully+    effectRL = effectRL . hopefully++instance Conflict p => Conflict (PatchInfoAnd p) where+    list_conflicted_files = list_conflicted_files . hopefully+    resolve_conflicts = resolve_conflicts . hopefully+    commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y)+                                     return (info y `piap` y' :> info x `piap` x')+    conflictedEffect = conflictedEffect . hopefully++instance RepoPatch p => Patchy (PatchInfoAnd p)
+ src/Darcs/IO.hs view
@@ -0,0 +1,249 @@+-- Copyright (C) 2005 David Roundy+--+-- 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.++{-# OPTIONS_GHC -fglasgow-exts #-}+module Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..),+                  TolerantIO, runTolerantly, runSilently,+                ) where++import Prelude hiding ( catch )+import Data.Char ( toLower )+import Data.List ( isSuffixOf )+import System.IO.Error ( isDoesNotExistError, isPermissionError )+import Control.Exception ( catch, catchJust, ioErrors )+import Control.Monad.Error+import System.Directory ( getDirectoryContents, createDirectory,+                          removeDirectory, removeFile,+                          renameFile, renameDirectory,+                          doesDirectoryExist, doesFileExist,+                        )++import ByteStringUtils ( linesPS, unlinesPS)+import qualified Data.ByteString as B (ByteString, empty, null, readFile)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++import Darcs.Utils ( withCurrentDirectory, prettyException )+import Darcs.External ( backupByCopying, backupByRenaming )+import Printer ( Doc, renderPS )+import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )+import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS )+import Workaround ( setExecutable )++class (Functor m, MonadPlus m) => ReadableDirectory m where+    mDoesDirectoryExist :: FileName -> m Bool+    mDoesFileExist :: FileName -> m Bool+    mInCurrentDirectory :: FileName -> m a -> m a+    mGetDirectoryContents :: m [FileName]+    mReadBinFile :: FileName -> m String+    mReadBinFile f = liftM BC.unpack $ mReadFilePS f+    mReadFilePS :: FileName -> m B.ByteString+    mReadFilePSs :: FileName -> m [B.ByteString]+    mReadFilePSs f = linesPS `liftM` mReadFilePS f++class ReadableDirectory m => WriteableDirectory m where+    mWithCurrentDirectory :: FileName -> m a -> m a+    mSetFileExecutable :: FileName -> Bool -> m ()+    mWriteBinFile :: FileName -> String -> m ()+    mWriteBinFile fn s = mWriteFilePS fn $ BC.pack s+    mWriteFilePS :: FileName -> B.ByteString -> m ()+    mWriteFilePSs :: FileName -> [B.ByteString] -> m ()+    mWriteFilePSs f ss = mWriteFilePS f (unlinesPS ss)+    mCreateDirectory :: FileName -> m ()+    mRemoveDirectory :: FileName -> m ()+    mWriteDoc :: FileName -> Doc -> m ()+    mWriteDoc f d = mWriteFilePS f (renderPS d)+    mCreateFile :: FileName -> m ()+    mCreateFile f = mWriteFilePS f B.empty+    mRemoveFile :: FileName -> m ()+    mRename :: FileName -> FileName -> m ()+    mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m ()+    mModifyFilePS f j = do ps <- mReadFilePS f+                           ps' <- j ps+                           mWriteFilePS f ps'+    mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()+    mModifyFilePSs f j = do ps <- mReadFilePSs f+                            ps' <- j ps+                            mWriteFilePSs f ps'++instance ReadableDirectory IO where+    mDoesDirectoryExist = doesDirectoryExist . fn2fp+    mDoesFileExist = doesFileExist . fn2fp+    mInCurrentDirectory = withCurrentDirectory . fn2fp+    mGetDirectoryContents = map fp2fn `liftM` getDirectoryContents "."+    mReadBinFile = readBinFile . fn2fp+    mReadFilePS = B.readFile . fn2fp++instance WriteableDirectory IO where+    mWithCurrentDirectory = mInCurrentDirectory+    mSetFileExecutable = setExecutable . fn2fp+    mWriteBinFile = writeBinFile . fn2fp+    mWriteFilePS = writeAtomicFilePS . fn2fp+    mCreateDirectory = createDirectory . fn2fp+    mCreateFile f = do exf <- mDoesFileExist f+                       if exf then fail $ "File '"++fn2fp f++"' already exists!"+                              else do exd <- mDoesDirectoryExist f+                                      if exd then fail $ "File '"++fn2fp f++"' already exists!"+                                             else mWriteFilePS f B.empty+    mRemoveFile f = do let fp = fn2fp f+                       x <- B.readFile fp+                       when (not $ B.null x) $+                            fail $ "Cannot remove non-empty file "++fp+                       removeFile fp+    mRemoveDirectory = removeDirectory . fn2fp+    mRename a b = catchJust ioErrors+                  (renameDirectory x y `mplus` renameFile x y)+                  -- We need to catch does not exist errors, since older+                  -- versions of darcs allowed users to rename nonexistent+                  -- files.  :(+                  (\e -> if isDoesNotExistError e+                                 then return ()+                                 else ioError e)+      where x = fn2fp a+            y = fn2fp b++class Monad m => TolerantMonad m where+    warning :: IO () -> m ()+    runIO :: m a -> IO a+    runTM :: IO a -> m a++newtype TolerantIO a = TIO { runTolerantly :: IO a }+instance TolerantMonad TolerantIO where+    warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e+    runIO (TIO io) = io+    runTM io = TIO io++newtype SilentIO a = SIO { runSilently :: IO a }+instance TolerantMonad SilentIO where+    warning io = SIO $ io `catch` \_ -> return ()+    runIO (SIO io) = io+    runTM io = SIO io++-- NOTE: The following instance declarations are duplicated merely to avoid+-- enabling -fallow-undecidable-instances.  If we used+-- -fallow-undecidable-instances, we would write instead:++-- instance TolerantMonad m => Monad m where+--      ...++-- etc.+instance Functor TolerantIO where+    fmap f m = m >>= return . f++instance Monad TolerantIO where+    f >>= g = runTM $ runIO f >>= runIO . g+    f >> g = runTM $ runIO f >> runIO g+    fail s = runTM $ fail s+    return x = runTM $ return x++instance Functor SilentIO where+    fmap f m = m >>= return . f++instance Monad SilentIO where+    f >>= g = runTM $ runIO f >>= runIO . g+    f >> g = runTM $ runIO f >> runIO g+    fail s = runTM $ fail s+    return x = runTM $ return x++instance MonadPlus TolerantIO where+    mzero = runTM mzero+    mplus a b = runTM (mplus (runIO a) (runIO b))+instance MonadPlus SilentIO where+    mzero = runTM mzero+    mplus a b = runTM (mplus (runIO a) (runIO b))++instance ReadableDirectory TolerantIO where+    mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d+    mDoesFileExist f = runTM $ mDoesFileExist f+    mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)+    mGetDirectoryContents = runTM mGetDirectoryContents+    mReadBinFile f = runTM $ mReadBinFile f+    mReadFilePS f = runTM $ mReadFilePS f+instance ReadableDirectory SilentIO where+    mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d+    mDoesFileExist f = runTM $ mDoesFileExist f+    mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)+    mGetDirectoryContents = runTM mGetDirectoryContents+    mReadBinFile f = runTM $ mReadBinFile f+    mReadFilePS f = runTM $ mReadFilePS f++instance WriteableDirectory TolerantIO where+     mWithCurrentDirectory = mInCurrentDirectory+     mSetFileExecutable f e = warning $ mSetFileExecutable f e+     mWriteBinFile f s = warning $ mWriteBinFile f s+     mWriteFilePS f s = warning $ mWriteFilePS f s+     mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty+     mCreateDirectory d = warning $ backup d >> mCreateDirectory d+     mRemoveFile f = warning $ mRemoveFile f+     mRemoveDirectory d = warning $ catchJust ioErrors+                                 (mRemoveDirectory d)+                                 (\e ->+                                   if "(Directory not empty)" `isSuffixOf` show e+                                   then ioError $ userError $+                                            "Not deleting " ++ fn2fp d ++ " because it is not empty."+                                   else ioError $ userError $+                                            "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)+     mRename a b = warning $ catchJust ioErrors+                          (let do_backup = if (map toLower x == map toLower y)+                                           then backupByCopying y -- avoid making the original vanish+                                           else backupByRenaming y+                           in do_backup >> mRename a b)+                          (\e -> case () of+                                 _ | isPermissionError e -> ioError $ userError $+                                       couldNotRename ++ "."+                                   | isDoesNotExistError e -> ioError $ userError $+                                       couldNotRename ++ " because " ++ x ++ " does not exist."+                                   | otherwise -> ioError e+                          )+       where+        x = fn2fp a+        y = fn2fp b+        couldNotRename = "Could not rename " ++ x ++ " to " ++ y+instance WriteableDirectory SilentIO where+     mWithCurrentDirectory = mInCurrentDirectory+     mSetFileExecutable f e = warning $ mSetFileExecutable f e+     mWriteBinFile f s = warning $ mWriteBinFile f s+     mWriteFilePS f s = warning $ mWriteFilePS f s+     mCreateFile f = warning $ backup f >> mWriteFilePS f B.empty+     mCreateDirectory d = warning $ backup d >> mCreateDirectory d+     mRemoveFile f = warning $ mRemoveFile f+     mRemoveDirectory d = warning $ catchJust ioErrors+                                 (mRemoveDirectory d)+                                 (\e ->+                                   if "(Directory not empty)" `isSuffixOf` show e+                                   then ioError $ userError $+                                            "Not deleting " ++ fn2fp d ++ " because it is not empty."+                                   else ioError $ userError $+                                            "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)+     mRename a b = warning $ catchJust ioErrors+                          (let do_backup = if (map toLower x == map toLower y)+                                           then backupByCopying y -- avoid making the original vanish+                                           else backupByRenaming y+                           in do_backup >> mRename a b)+                          (\e -> case () of+                                 _ | isPermissionError e -> ioError $ userError $+                                       couldNotRename ++ "."+                                   | isDoesNotExistError e -> ioError $ userError $+                                       couldNotRename ++ " because " ++ x ++ " does not exist."+                                   | otherwise -> ioError e+                          )+       where+        x = fn2fp a+        y = fn2fp b+        couldNotRename = "Could not rename " ++ x ++ " to " ++ y++backup :: FileName -> IO ()+backup f = backupByRenaming $ fn2fp f
+ src/Darcs/Lock.hs view
@@ -0,0 +1,333 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.++{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Lock ( withLock, withLockCanFail,+              withTemp, withOpenTemp, withStdoutTemp,+              withTempDir, withPermDir, withDelayedDir, withNamedTemp,+              writeToFile, appendToFile,+              writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile,+              readBinFile, readDocBinFile,+              writeAtomicFilePS,+              gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,+              rm_recursive, removeFileMayNotExist,+              canonFilename, maybeRelink,+              world_readable_temp, tempdir_loc,+              environmentHelpTmpdir, environmentHelpKeepTmpdir+            ) where++import Prelude hiding ( catch )+import Data.List ( inits )+import Data.Maybe ( isJust, listToMaybe )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( openBinaryFile, openBinaryTempFile,+                   hClose, hPutStr, Handle,+                   IOMode(WriteMode, AppendMode), hFlush, stdout )+import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )+import Control.Exception ( bracket, catchJust, ioErrors, throwIO,+                           Exception(IOException), catch, try )+import System.Directory ( removeFile, removeDirectory,+                   doesFileExist, doesDirectoryExist,+                   getDirectoryContents, createDirectory,+                   getTemporaryDirectory,+                 )+import System.FilePath.Posix ( splitDirectories )+import Workaround ( renameFile )+import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO )+import Control.Monad ( unless, when )++import Darcs.URL ( is_relative )+import Darcs.Utils ( catchall, add_to_error_loc )+import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath,+                        getCurrentDirectory, setCurrentDirectory )++import ByteStringUtils ( gzWriteFilePSs)+import qualified Data.ByteString as B (null, readFile, hPut, ByteString)+import qualified Data.ByteString.Char8 as BC (unpack)++import Darcs.SignalHandler ( withSignalsBlocked )+import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )+import Darcs.Global ( atexit, darcsdir )+import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink,+                atomic_create, sloppy_atomic_create )+import System.Posix.Files ( getSymbolicLinkStatus, isDirectory,+                            fileMode, getFileStatus, setFileMode )+import System.Posix ( sleep )+#include "impossible.h"++withLock :: String -> IO a -> IO a+releaseLock :: String -> IO ()++withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)++-- | Tries to perform some task if it can obtain the lock,+-- Otherwise, just gives up without doing the task+withLockCanFail :: String -> IO a -> IO (Either () a)+withLockCanFail s job =+  bracket (takeLock s)+          (\l -> if l then releaseLock s else return ())+          (\l -> if l then job >>= (return.Right)+                      else return $ Left ())++getlock :: String -> Int -> IO String+getlock l 0 = do putStrLn $ "Couldn't get lock "++l+                 exitWith $ ExitFailure 1+getlock lbad tl = do l <- canonFilename lbad+                     gotit <- takeLock l+                     if gotit then return l+                              else do putStrLn $ "Waiting for lock "++l+                                      hFlush stdout -- for Windows+                                      done <- sleep 2+                                      if done == 0+                                         then getlock l (tl - 1)+                                         else getlock l 0++removeFileMayNotExist :: FilePathLike p => p -> IO ()+removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()++catchNonExistence :: IO a -> a -> IO a+catchNonExistence job nonexistval =+    catchJust ioErrors job $+    \e -> if isDoesNotExistError e then return nonexistval+                                   else ioError e++releaseLock s = removeFileMayNotExist s++takeLock :: FilePathLike p => p -> IO Bool+takeLock fp =+    do atomic_create $ toFilePath fp+       return True+  `catch` \e -> case e of+                    IOException e'+                     | isAlreadyExistsError e' ->+                        return False+                    _ -> do pwd <- getCurrentDirectory+                            throwIO $ add_to_error_loc e+                                            ("takeLock "++toFilePath fp++" in "++toFilePath pwd)++takeFile :: FilePath -> IO Bool+takeFile fp =+    do sloppy_atomic_create fp+       return True+  `catch` \e -> case e of+                    IOException e'+                     | isAlreadyExistsError e' ->+                        return False+                    _ -> do pwd <- getCurrentDirectory+                            throwIO $ add_to_error_loc e+                                            ("takeFile "++fp++" in "++toFilePath pwd)++-- |'withTemp' safely creates an empty file (not open for writing) and+-- returns its name.+--+-- The temp file operations are rather similar to the locking operations, in+-- that they both should always try to clean up, so exitWith causes trouble.+withTemp :: (String -> IO a) -> IO a+withTemp = bracket get_empty_file removeFileMayNotExist+    where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"+                              hClose h+                              return f++-- |'withOpenTemp' creates an already open temporary+-- file.  Both of them run their argument and then delete the file.  Also,+-- both of them (to my knowledge) are not susceptible to race conditions on+-- the temporary file (as long as you never delete the temporary file; that+-- would reintroduce a race condition).+withOpenTemp :: ((Handle, String) -> IO a) -> IO a+withOpenTemp = bracket get_empty_file cleanup+    where cleanup (h,f) = do try $ hClose h+                             removeFileMayNotExist f+          get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"+          invert (a,b) = (b,a)++withStdoutTemp :: (String -> IO a) -> IO a+withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist++tempdir_loc :: IO FilePath+tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir,+                            maybeGetEnv "DARCS_TMPDIR" >>= chkdir,+                            getTemporaryDirectory >>= chkdir . Just,+                            getCurrentDirectorySansDarcs,+                            return $ Just "."  -- always returns a Just+                          ]+              >>= return . fromJust+    where chkdir Nothing = return Nothing+          chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing++environmentHelpTmpdir :: ([String], [String])+environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [+ "Darcs often creates temporary directories.  For example, the `darcs",+ "diff' command creates two for the working trees to be diffed.  By",+ "default temporary directories are created in /tmp, or if that doesn't",+ "exist, in _darcs (within the current repo).  This can be overridden by",+ "specifying some other directory in the file _darcs/prefs/tmpdir or the",+ "environment variable $DARCS_TMPDIR or $TMPDIR."])++getCurrentDirectorySansDarcs :: IO (Maybe FilePath)+getCurrentDirectorySansDarcs = do+  c <- getCurrentDirectory+  return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c+  where no_darcs x = not $ darcsdir `elem` splitDirectories x++data WithDirKind = Perm | Temp | Delayed++withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a+withDir _ "" _ = bug "withDir called with empty directory name"+withDir kind abs_or_relative_name job = do+  absolute_name <- if is_relative abs_or_relative_name+                   then fmap (++ abs_or_relative_name) tempdir_loc+                   else return abs_or_relative_name+  formerdir <- getCurrentDirectory+  bracket (create_directory absolute_name 0)+          (\dir -> do setCurrentDirectory formerdir+                      k <- keep_tmpdir+                      unless k $ do case kind of+                                      Perm -> return ()+                                      Temp -> rm_recursive (toFilePath dir)+                                      Delayed -> atexit $ rm_recursive (toFilePath dir))+          job+    where newname name 0 = name+          newname name n = name ++ "-" ++ show n+          create_directory :: FilePath -> Int -> IO AbsolutePath+          create_directory name n+              = do createDirectory $ newname name n+                   setCurrentDirectory $ newname name n+                   getCurrentDirectory+                `catch` (\e -> case e of+                              IOException e'+                               | isAlreadyExistsError e' ->+                                  create_directory name (n+1)+                              _ -> throwIO e)+          keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"++environmentHelpKeepTmpdir :: ([String], [String])+environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[+ "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",+ "not remove the temporary directories it creates.  This is intended",+ "primarily for debugging Darcs itself, but it can also be useful, for",+ "example, to determine why your test preference (see `darcs setpref')",+ "is failing when you run `darcs record', but working when run manually."])++-- |'withPermDir' is like 'withTempDir', except that it doesn't+-- delete the directory afterwards.+withPermDir :: String -> (AbsolutePath -> IO a) -> IO a+withPermDir = withDir Perm++-- |'withTempDir' creates an empty directory and then removes it when it+-- is no longer needed.  withTempDir creates a temporary directory.  The+-- location of that directory is determined by the contents of+-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if+-- that doesn't exist then whatever your operating system considers to be a+-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under+-- Windows).+--+-- If none of those exist it creates the temporary directory+-- in the current directory, unless the current directory is under a _darcs+-- directory, in which case the temporary directory in the parent of the highest+-- _darcs directory to avoid accidentally corrupting darcs's internals.+-- This should not fail, but if it does indeed fail, we go ahead and use the+-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set+-- temporary directory is not removed, this can be useful for debugging.+withTempDir :: String -> (AbsolutePath -> IO a) -> IO a+withTempDir = withDir Temp++withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a+withDelayedDir = withDir Delayed++doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f =+    catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False++rm_recursive :: FilePath -> IO ()+rm_recursive d =+    do isd <- doesDirectoryReallyExist d+       if not isd+          then removeFile d+          else when isd $ do conts <- actual_dir_contents+                             withCurrentDirectory d $+                               mapM_ rm_recursive conts+                             removeDirectory d+    where actual_dir_contents = -- doesn't include . or ..+              do c <- getDirectoryContents d+                 return $ filter (/=".") $ filter (/="..") c++world_readable_temp :: String -> IO String+world_readable_temp f = wrt 0+    where wrt :: Int -> IO String+          wrt 100 = fail $ "Failure creating temp named "++f+          wrt n = let f_new = f++"-"++show n+                  in do ok <- takeFile f_new+                        if ok then do atexit $ removeFileMayNotExist f_new+                                      return f_new+                              else wrt (n+1)++withNamedTemp :: String -> (String -> IO a) -> IO a+withNamedTemp n = bracket get_empty_file removeFileMayNotExist+    where get_empty_file = world_readable_temp n++readBinFile :: FilePathLike p => p -> IO String+readBinFile = fmap BC.unpack . B.readFile . toFilePath++readDocBinFile :: FilePathLike p => p -> IO Doc+readDocBinFile fp = do ps <- B.readFile $ toFilePath fp+                       return $ if B.null ps then empty else packedString ps++appendBinFile :: FilePathLike p => p -> String -> IO ()+appendBinFile f s = appendToFile f $ \h -> hPutStr h s++appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()+appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d++writeBinFile :: FilePathLike p => p -> String -> IO ()+writeBinFile f s = writeToFile f $ \h -> hPutStr h s++writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()+writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d++writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps++gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]++gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()+gzWriteAtomicFilePSs f pss =+    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+    gzWriteFilePSs newf pss+    already_exists <- doesFileExist $ toFilePath f+    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+                             setFileMode newf mode+             `catchall` return ()+    renameFile newf (toFilePath f)++gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()+gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d++writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()+writeToFile f job =+    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+    bracket (openBinaryFile newf WriteMode) hClose job+    already_exists <- doesFileExist (toFilePath f)+    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+                             setFileMode newf mode+             `catchall` return ()+    renameFile newf (toFilePath f)++appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()+appendToFile f job = withSignalsBlocked $ +    bracket (openBinaryFile (toFilePath f) AppendMode) hClose job
+ src/Darcs/Match.lhs view
@@ -0,0 +1,568 @@+%  Copyright (C) 2004-2005 David Roundy+%+%  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.++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}++#include "gadts.h"++module Darcs.Match ( match_first_patchset, match_second_patchset,+               match_patch,+               match_a_patch, match_a_patchread,+               get_first_match, get_nonrange_match,+               get_partial_first_match, get_partial_second_match,+               get_partial_nonrange_match,+               first_match, second_match, have_nonrange_match,+               have_patchset_match, get_one_patchset,+               checkMatchSyntax,+             ) where++import Text.Regex ( mkRegex, matchRegex )+import Control.Monad ( when )+import Data.Maybe ( isJust )++import Darcs.Hopefully ( PatchInfoAnd, info, piap,+                         conscientiously, hopefully )+import Darcs.Patch.Info ( just_name )+import Darcs.Patch ( RepoPatch, Patch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )+import Darcs.Repository ( Repository, PatchSet, SealedPatchSet, read_repo,+                    slurp_recorded, createPristineDirectoryTree )+import Darcs.Repository.ApplyPatches ( apply_patches )+import Darcs.Patch.Depends ( get_patches_in_tag, get_patches_beyond_tag )+import Darcs.Ordered ( RL(..), concatRL, consRLSealed )++import ByteStringUtils ( mmapFilePS )+import qualified Data.ByteString as B (ByteString)++import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,+                                StoreInMemory,+                               AfterPatch, UpToPatch, LastN, PatchIndexRange,+                               OneTag, AfterTag, UpToTag,+                               OnePattern, SeveralPattern,+                               AfterPattern, UpToPattern ) )+import Darcs.Patch.Bundle ( scan_context )+import Darcs.Patch.Match ( Matcher, MatchFun, match_pattern, apply_matcher, make_matcher, parseMatch )+import Darcs.Patch.MatchData ( PatchMatch )+import Printer ( text, ($$) )++import Darcs.RepoPath ( toFilePath )+import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )+import Darcs.SlurpDirectory ( SlurpMonad, writeSlurpy, withSlurpy )+import Darcs.Patch.FileName ( FileName, super_name, norm_path, (///) )+import Darcs.Sealed ( FlippedSeal(..), Sealed2(..),+                      seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )+#include "impossible.h"+\end{code}++\paragraph{Selecting patches}\label{selecting}++Many commands operate on a patch or patches that have already been recorded.+There are a number of options that specify which patches are selected for+these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants+on these, which for \verb!--patch! are \verb!--patches!,+\verb!--from-patch!, and \verb!--to-patch!.  The \verb!--patch! and+\verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular+expressions and match them against tag and patch names.  \verb!--match!,+described below, allows more powerful patterns.++The plural forms of these options select all matching patches.  The singular+forms select the last matching patch.  The range (from and to) forms select+patches after or up to (both inclusive) the last matching patch.++These options use the current order of patches in the repository.  darcs may+reorder patches, so this is not necessarily the order of creation or the+order in which patches were applied.  However, as long as you are just+recording patches in your own repository, they will remain in order.++% NOTE --no-deps is implemented in SelectChanges.lhs, but documented here+% for concistency.+When a patch or a group of patches is selected, all patches they depend on+get silently selected too. For example: \verb!darcs pull --patches bugfix!+means ``pull all the patches with `bugfix' in their name, along with any+patches they require.''  If you really only want patches with `bugfix' in+their name, you should use the \verb!--no-deps! option, which makes darcs+exclude any matched patches from the selection which have dependencies that+are themselves not explicitly matched by the selection.++For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that+depend on the selected patches are silently included, or if+\verb!--no-deps! is used selected patches with dependencies on not selected+patches are excluded from the selection.++\begin{code}+data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq++-- | @have_nonrange_match flags@ tells whether there is a flag in+-- @flags@ which corresponds to a match that is "non-range". Thus,+-- @--match@, @--patch@ and @--index@ make @have_nonrange_match@+-- true, but not @--from-patch@ or @--to-patch@.+have_nonrange_match :: [DarcsFlag] -> Bool+have_nonrange_match fs = isJust (has_index_range fs) || isJust (nonrange_matcher fs::Maybe (Matcher Patch))++-- | @have_patchset_match flags@ tells whether there is a "patchset+-- match" in the flag list. A patchset match is @--match@ or+-- @--patch@, or @--context@, but not @--from-patch@ nor (!)+-- @--index@.+-- Question: Is it supposed not to be a subset of @have_nonrange_match@?+have_patchset_match :: [DarcsFlag] -> Bool+have_patchset_match fs = isJust (nonrange_matcher fs::Maybe (Matcher Patch)) || hasC fs+    where hasC [] = False+          hasC (Context _:_) = True+          hasC (_:xs) = hasC xs++get_nonrange_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()+get_nonrange_match r fs = withRecordedMatchSmart fs r (get_nonrange_match_s fs)++get_partial_nonrange_match :: RepoPatch p => Repository p C(r u t)+                           -> [DarcsFlag] -> [FileName] -> IO ()+get_partial_nonrange_match r fs files =+    withRecordedMatchOnlySomeSmart fs r files (get_nonrange_match_s fs)++get_nonrange_match_s :: (MatchMonad m p, RepoPatch p) =>+                        [DarcsFlag] -> PatchSet p C(x) -> m ()+get_nonrange_match_s fs repo =+    case nonrange_matcher fs of+        Just m -> if nonrange_matcher_is_tag fs+                        then get_tag_s m repo+                        else get_matcher_s Exclusive m repo+        Nothing -> fail "Pattern not specified in get_nonrange_match."++-- | @first_match fs@ tells whether @fs@ implies a "first match", that+-- is if we match against patches from a point in the past on, rather+-- than against all patches since the creation of the repository.+first_match :: [DarcsFlag] -> Bool+first_match fs = isJust (has_lastn fs)+                 || isJust (first_matcher fs::Maybe (Matcher Patch))+                 || isJust (has_index_range fs)++get_first_match :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO ()+get_first_match r fs = withRecordedMatchSmart fs r (get_first_match_s fs)++get_partial_first_match :: RepoPatch p => Repository p C(r u t)+                        -> [DarcsFlag] -> [FileName] -> IO ()+get_partial_first_match r fs files =+    withRecordedMatchOnlySomeSmart fs r files (get_first_match_s fs)++get_first_match_s :: (MatchMonad m p, RepoPatch p) =>+                     [DarcsFlag] -> PatchSet p C(x) -> m ()+get_first_match_s fs repo =+    case has_lastn fs of+    Just n -> applyInvRL `unsealFlipped` (safetake n $ concatRL repo)+    Nothing -> case first_matcher fs of+               Nothing -> fail "Pattern not specified in get_first_match."+               Just m -> if first_matcher_is_tag fs+                         then get_tag_s m repo+                         else get_matcher_s Inclusive m repo+++-- | @second_match fs@ tells whether @fs@ implies a "second match", that+-- is if we match against patches up to a point in the past on, rather+-- than against all patches until now.+second_match :: [DarcsFlag] -> Bool+second_match fs = isJust (second_matcher fs::Maybe (Matcher Patch)) || isJust (has_index_range fs)++get_partial_second_match :: RepoPatch p => Repository p C(r u t)+                        -> [DarcsFlag] -> [FileName] -> IO ()+get_partial_second_match r fs files =+    withRecordedMatchOnlySomeSmart fs r files $ \repo ->+    case second_matcher fs of+    Nothing -> fail "Two patterns not specified in get_second_match."+    Just m -> if second_matcher_is_tag fs+              then get_tag_s m repo+              else get_matcher_s Exclusive m repo++checkMatchSyntax :: [DarcsFlag] -> IO ()+checkMatchSyntax opts = do+ case get_match_pattern opts of+  Nothing -> return ()+  Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun Patch))++get_match_pattern :: [DarcsFlag] -> Maybe PatchMatch+get_match_pattern [] = Nothing+get_match_pattern (OnePattern m:_) = Just m+get_match_pattern (SeveralPattern m:_) = Just m+get_match_pattern (_:fs) = get_match_pattern fs++tagmatch :: String -> Matcher p+tagmatch r = make_matcher ("tag-name "++r) tm+    where tm (Sealed2 p) =+              let n = just_name (info p) in+              take 4 n == "TAG " && isJust (matchRegex (mkRegex r) $ drop 4 n)++mymatch :: String -> Matcher p+mymatch r = make_matcher ("patch-name "++r) mm+    where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . just_name . info $ p+++-- | strictJust is a strict version of the Just constructor, used to ensure+-- that if we claim we've got a pattern match, that the pattern will+-- actually match (rathern than fail to compile properly).+--+-- /First matcher, Second matcher and Nonrange matcher/+--+-- When we match for patches, we have a PatchSet, of which we want a+-- subset. This subset is formed by the patches in a given interval+-- which match a given criterion. If we represent time going left to+-- right (which means the 'PatchSet' is written right to left), then+-- we have (up to) three 'Matcher's: the 'nonrange_matcher' is the+-- criterion we use to select among patches in the interval, the+-- 'first_matcher' is the left bound of the interval, and the+-- 'last_matcher' is the right bound. Each of these matchers can be+-- present or not according to the options.+strictJust :: a -> Maybe a+strictJust x = Just $! x++-- | @nonrange_matcher@ is the criterion that is used to match against+-- patches in the interval. It is 'Just m' when the @--patch@, @--match@,+-- @--tag@ options are passed (or their plural variants).+nonrange_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+nonrange_matcher [] = Nothing+nonrange_matcher (OnePattern m:_) = strictJust $ match_pattern m+nonrange_matcher (OneTag t:_) = strictJust $ tagmatch t+nonrange_matcher (OnePatch p:_) = strictJust $ mymatch p+nonrange_matcher (SeveralPattern m:_) = strictJust $ match_pattern m+nonrange_matcher (SeveralPatch p:_) = strictJust $ mymatch p+nonrange_matcher (_:fs) = nonrange_matcher fs++-- | @nonrange_matcher_is_tag@ returns true if the matching option was+-- '--tag'+nonrange_matcher_is_tag :: [DarcsFlag] -> Bool+nonrange_matcher_is_tag [] = False+nonrange_matcher_is_tag (OneTag _:_) = True+nonrange_matcher_is_tag (_:fs) = nonrange_matcher_is_tag fs++-- | @first_matcher@ returns the left bound of the matched interval.+-- This left bound is also specified when we use the singular versions+-- of @--patch@, @--match@ and @--tag@. Otherwise, @first_matcher@+-- returns @Nothing@.+first_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+first_matcher [] = Nothing+first_matcher (OnePattern m:_) = strictJust $ match_pattern m+first_matcher (AfterPattern m:_) = strictJust $ match_pattern m+first_matcher (AfterTag t:_) = strictJust $ tagmatch t+first_matcher (OnePatch p:_) = strictJust $ mymatch p+first_matcher (AfterPatch p:_) = strictJust $ mymatch p+first_matcher (_:fs) = first_matcher fs++first_matcher_is_tag :: [DarcsFlag] -> Bool+first_matcher_is_tag [] = False+first_matcher_is_tag (AfterTag _:_) = True+first_matcher_is_tag (_:fs) = first_matcher_is_tag fs++second_matcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)+second_matcher [] = Nothing+second_matcher (OnePattern m:_) = strictJust $ match_pattern m+second_matcher (UpToPattern m:_) = strictJust $ match_pattern m+second_matcher (OnePatch p:_) = strictJust $ mymatch p+second_matcher (UpToPatch p:_) = strictJust $ mymatch p+second_matcher (UpToTag t:_) = strictJust $ tagmatch t+second_matcher (_:fs) = second_matcher fs++second_matcher_is_tag :: [DarcsFlag] -> Bool+second_matcher_is_tag [] = False+second_matcher_is_tag (UpToTag _:_) = True+second_matcher_is_tag (_:fs) = second_matcher_is_tag fs++-- | @match_a_patchread fs p@ tells whether @p@ matches the matchers in+-- the flags listed in @fs@.+match_a_patchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool+match_a_patchread fs = case nonrange_matcher fs of+                       Nothing -> const True+                       Just m -> apply_matcher m++-- | @match_a_patch fs p@ tells whether @p@ matches the matchers in+-- the flags @fs@+match_a_patch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool+match_a_patch fs p =+    case nonrange_matcher fs of+    Nothing -> True+    Just m -> apply_matcher m (patch2patchinfo p `piap` p)++match_patch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> Sealed2 (Named p)+match_patch fs ps =+    case has_index_range fs of+    Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of+                             Just (Sealed2 p) -> seal2 $ hopefully p+                             Nothing -> error "Patch out of range!"+                | otherwise -> bug ("Invalid index range match given to match_patch: "+++                                    show (PatchIndexRange a a'))+                where myhead :: PatchSet p C(x) -> Maybe (Sealed2 (PatchInfoAnd p))+                      myhead (NilRL:<:x) = myhead x+                      myhead ((x:<:_):<:_) = Just $ seal2 x+                      myhead NilRL = Nothing+    Nothing -> case nonrange_matcher fs of+                    Nothing -> bug "Couldn't match_patch"+                    Just m -> find_a_patch m ps++get_one_patchset :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> IO (SealedPatchSet p)+get_one_patchset repository fs =+    case nonrange_matcher fs of+        Just m -> do ps <- read_repo repository+                     if nonrange_matcher_is_tag fs+                        then return $ get_matching_tag m ps+                        else return $ match_a_patchset m ps+        Nothing -> (seal . scan_context) `fmap` mmapFilePS (toFilePath $ context_f fs)+    where context_f [] = bug "Couldn't match_nonrange_patchset"+          context_f (Context f:_) = f+          context_f (_:xs) = context_f xs++-- | @has_lastn fs@ return the @--last@ argument in @fs@, if any.+has_lastn :: [DarcsFlag] -> Maybe Int+has_lastn [] = Nothing+has_lastn (LastN (-1):_) = error "--last requires a positive integer argument."+has_lastn (LastN n:_) = Just n+has_lastn (_:fs) = has_lastn fs++has_index_range :: [DarcsFlag] -> Maybe (Int,Int)+has_index_range [] = Nothing+has_index_range (PatchIndexRange x y:_) = Just (x,y)+has_index_range (_:fs) = has_index_range fs++-- | @match_first_patchset fs ps@ returns the part of @ps@ before its+-- first matcher, ie the one that comes first dependencywise. Hence,+-- patches in @match_first_patchset fs ps@ are the ones we don't want.+--+-- Question: are they really? Florent+match_first_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p+match_first_patchset fs patchset =+    case has_lastn fs of+    Just n -> dropn n patchset+    Nothing ->+        case has_index_range fs of+        Just (_,b) -> dropn b patchset+        Nothing ->+               case first_matcher fs of+               Nothing -> bug "Couldn't match_first_patchset"+               Just m -> unseal (dropn 1) $ if first_matcher_is_tag fs+                                            then get_matching_tag m patchset+                                            else match_a_patchset m patchset++-- | @dropn n ps@ drops the @n@ last patches from @ps@.+dropn :: Int -> PatchSet p C(x) -> SealedPatchSet p+dropn n ps | n <= 0 = seal ps+dropn n (NilRL:<:ps) = dropn n ps+dropn _ NilRL = seal $ NilRL:<:NilRL+dropn n ((_:<:ps):<:xs) = dropn (n-1) $ ps:<:xs++-- | @match_second_patchset fs ps@ returns the part of @ps@ before its+-- second matcher, ie the one that comes last dependencywise.+match_second_patchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> SealedPatchSet p+match_second_patchset fs ps =+  case has_index_range fs of+  Just (a,_) -> dropn (a-1) ps+  Nothing ->+    case second_matcher fs of+    Nothing -> bug "Couldn't match_second_patchset"+    Just m -> if second_matcher_is_tag fs+              then get_matching_tag m ps+              else match_a_patchset m ps++-- | @find_a_patch m ps@ returns the last patch in @ps@ matching @m@, and+-- calls 'error' if there is none.+find_a_patch :: RepoPatch p => Matcher p -> PatchSet p C(x) -> Sealed2 (Named p)+find_a_patch m NilRL = error $ "Couldn't find patch matching " ++ show m+find_a_patch m (NilRL:<:xs) = find_a_patch m xs+find_a_patch m ((p:<:ps):<:xs) | apply_matcher m p = seal2 $ hopefully p+                               | otherwise = find_a_patch m (ps:<:xs)++-- | @match_a_patchset m ps@ returns a (the largest?) subset of @ps@+-- ending in patch which matches @m@. Calls 'error' if there is none.+match_a_patchset :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p+match_a_patchset m NilRL = error $ "Couldn't find patch matching " ++ show m+match_a_patchset m (NilRL:<:xs) = match_a_patchset m xs+match_a_patchset m ((p:<:ps):<:xs) | apply_matcher m p = seal ((p:<:ps):<:xs)+                                   | otherwise = match_a_patchset m (ps:<:xs)++-- | @get_matching_tag m ps@, where @m@ is a 'Matcher' which matches tags+-- returns a 'SealedPatchSet' containing all patches in the last tag which+-- matches @m@. Last tag means the most recent tag in repository order,+-- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls+-- 'error' if there is no matching tag.+get_matching_tag :: RepoPatch p => Matcher p -> PatchSet p C(x) -> SealedPatchSet p+get_matching_tag m NilRL = error $ "Couldn't find a tag matching " ++ show m+get_matching_tag m (NilRL:<:xs) = get_matching_tag m xs+get_matching_tag m xxx@((p:<:ps):<:xs)+    | apply_matcher m p = get_patches_in_tag (info p) xxx+    | otherwise = get_matching_tag m (ps:<:xs)++-- | @match_exists m ps@ tells whether there is a patch matching+-- @m@ in @ps@+match_exists :: Matcher p -> PatchSet p C(x) -> Bool+match_exists _ NilRL = False+match_exists m (NilRL:<:xs) = match_exists m xs+match_exists m ((p:<:ps):<:xs) | apply_matcher m $ p = True+                               | otherwise = match_exists m (ps:<:xs)++apply_inv_to_matcher :: (RepoPatch p, WriteableDirectory m) => InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()+apply_inv_to_matcher _ _ NilRL = impossible+apply_inv_to_matcher ioe m (NilRL:<:xs) = apply_inv_to_matcher ioe m xs+apply_inv_to_matcher ioe m ((p:<:ps):<:xs)+    | apply_matcher m p = when (ioe == Inclusive) (apply_invp p)+    | otherwise = apply_invp p >> apply_inv_to_matcher ioe m (ps:<:xs)++-- | @maybe_read_file@ recursively gets the contents of all files+-- in a directory, or just the contents of a file if called on a+-- simple file.+maybe_read_file :: ReadableDirectory m => FileName -> m ([(FileName, B.ByteString)])+maybe_read_file file = do+    d <- mDoesDirectoryExist file+    if d+      then do+        children <- mInCurrentDirectory file mGetDirectoryContents+        maybe_read_files [file /// ch | ch <-  children]+      else do+         e <- mDoesFileExist file+         if e+           then do+             contents <- mReadFilePS file+             return  [(norm_path file, contents)]+           else return []+  where maybe_read_files [] =  return []+        maybe_read_files (f:fs) = do+                      x <- maybe_read_file f+                      y <- maybe_read_files fs+                      return $ concat [x,y]++get_matcher_s :: (MatchMonad m p, RepoPatch p) =>+                 InclusiveOrExclusive -> Matcher p -> PatchSet p C(x) -> m ()+get_matcher_s ioe m repo =+    if match_exists m repo+    then apply_inv_to_matcher ioe m repo+    else fail $ "Couldn't match pattern "++ show m++get_tag_s :: (MatchMonad m p, RepoPatch p) =>+             Matcher p -> PatchSet p C(x) -> m ()+get_tag_s match repo = do+    let pinfo = patch2patchinfo `unseal2` (find_a_patch match repo)+    case get_patches_beyond_tag pinfo repo of+        FlippedSeal (extras:<:NilRL) -> applyInvRL $ extras+        _ -> impossible++-- | @apply_invp@ tries to get the patch that's in a 'PatchInfoAnd+-- patch', and to apply its inverse. If we fail to fetch the patch+-- (presumably in a partial repositiory), then we share our sorrow+-- with the user.+apply_invp :: (Patchy p, WriteableDirectory m) => PatchInfoAnd p C(x y) -> m ()+apply_invp hp = apply [] (invert $ fromHopefully hp)+    where fromHopefully = conscientiously $ \e ->+                     text "Sorry, partial repository problem.  Patch not available:"+                     $$ e+                     $$ text ""+                     $$ text "If you think what you're trying to do is ok then"+                     $$ text "report this as a bug on the darcs-user list."++-- | a version of 'take' for 'RL' lists that cater for contexts.+safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)+safetake 0 _ = flipSeal NilRL+safetake _ NilRL = error "There aren't that many patches..."+safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as++-- | A @MatchMonad p m@ is a monad in which we match patches from @p@+-- by playing with them in @m@, a 'WriteableDirectory' monad. How we+-- play with the patches depends on the instance of @MatchMonad@ we're+-- using. If we use @IO@, then we'll apply the patches directly in+-- @m@, if we use @SlurpMonad@, then we'll apply the patches to a+-- slurpy, and write to disk at the end. Note that both @IO@ and+-- @SlurpMonad@ have an instance of 'WriteableDirectory' that+-- implicitely writes in the current directory.+class (RepoPatch p, WriteableDirectory m) => MatchMonad m p where+    withRecordedMatch :: Repository p C(r u t)+                      -> (PatchSet p C(r) -> m ()) -> IO ()+    -- ^ @withRecordedMatch@ is responsible for getting the recorded state+    -- into the monad, and then applying the second argument, and+    -- finally placing the resulting state into the current directory.+    withRecordedMatchOnlySomeFiles+        :: Repository p C(r u t) -> [FileName]+        -> (PatchSet p C(r) -> m ()) -> IO ()+    -- ^ @withRecordedMatchOnlySomeFiles@ is a variant of+    -- withRecordedMatch that may only return some of the files+    -- (e.g. if we want to run diff on just a few files).+    withRecordedMatchOnlySomeFiles r _ j = withRecordedMatch r j+    applyInvRL :: RL (PatchInfoAnd p) C(x r) -> m ()+    applyInvRL NilRL = return ()+    applyInvRL (p:<:ps) = apply_invp p >> applyInvRL ps++withRecordedMatchIO :: RepoPatch p => Repository p C(r u t)+                    -> (PatchSet p C(r) -> IO ()) -> IO ()+withRecordedMatchIO = withRecordedMatch++-- | @withRecordedMatchSmart@ hides away the choice of the+-- 'SlurpMonad' to use in order to apply 'withRecordedMatch'.+-- If we have the @--store-in-memory@ flag, then use 'SlurpMonad', else+-- use @IO@. In both case, the result is in the @IO@ monad.+--+-- Suggestion: shouldn't we name @withRecordedMatchSmart@+-- @withRecordedMatch@, and give the monad function another name such+-- as @withRecordedMatchRaw@?+withRecordedMatchSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)+                       -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())+                       -> IO ()+withRecordedMatchSmart opts r j =+ do if StoreInMemory `elem` opts then withSM r j+                                 else withRecordedMatchIO r j+    where withSM :: RepoPatch p => Repository p C(r u t)+                 -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()+          withSM = withRecordedMatch++-- | @withRecordedMatchOnlySomeSmart@ is the smart version of+-- 'withRecordedMatchOnlySome'. It runs 'withRecordedMatchOnlySome'+-- either in the 'SlurpMonad' or in @IO@ according to the+-- @--store-in-memory@ flag.+withRecordedMatchOnlySomeSmart :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)+                       -> [FileName]+                       -> (forall m. MatchMonad m p => PatchSet p C(r) -> m ())+                       -> IO ()+withRecordedMatchOnlySomeSmart opts r [] j = withRecordedMatchSmart opts r j+withRecordedMatchOnlySomeSmart opts r files j =+ do if StoreInMemory `elem` opts then withSM r files j+                                 else withIO r files j+    where withSM :: RepoPatch p => Repository p C(r u t) -> [FileName]+                 -> (PatchSet p C(r) -> SlurpMonad ()) -> IO ()+          withSM = withRecordedMatchOnlySomeFiles+          withIO :: RepoPatch p => Repository p C(r u t) -> [FileName]+                 -> (PatchSet p C(r) -> IO ()) -> IO ()+          withIO = withRecordedMatchOnlySomeFiles++instance RepoPatch p => MatchMonad IO p where+    withRecordedMatch r job = do createPristineDirectoryTree r "."+                                 read_repo r >>= job+    applyInvRL = apply_patches [] . invertRL -- this gives nicer feedback++instance RepoPatch p => MatchMonad SlurpMonad p where+    withRecordedMatch r job =+        do ps <- read_repo r+           s <- slurp_recorded r+           case withSlurpy s (job ps) of+             Left err -> fail err+             Right (s',_) -> writeSlurpy s' "."+    withRecordedMatchOnlySomeFiles r fs job =+        do ps <- read_repo r+           s <- slurp_recorded r+           case withSlurpy s (job ps >> mapM maybe_read_file fs) of+             Left err -> fail err+             Right (_,fcs) -> mapM_ createAFile $ concat fcs+               where createAFile (p,c) = do ensureDirectories $ super_name p+                                            mWriteFilePS p c+                     ensureDirectories d =+                         do isPar <- mDoesDirectoryExist d+                            if isPar+                              then return ()+                              else do ensureDirectories $ super_name d+                                      mCreateDirectory d++\end{code}
+ src/Darcs/Ordered.hs view
@@ -0,0 +1,277 @@+-- Copyright (C) 2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash, TypeOperators, GADTs #-}++#include "gadts.h"++module Darcs.Ordered ( EqCheck(..), isEq, (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..),+                             FL(..), RL(..),Proof(..),+#ifndef GADT_WITNESSES+                             unsafeUnFL, unsafeFL, unsafeRL, unsafeUnRL,+#endif+                             lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL,+                             splitAtFL, bunchFL, foldlRL,+                             lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL,+                             unsafeMap_l2f, filterE, filterFL,+                             reverseFL, reverseRL, (+>+), (+<+),+                             nullFL, concatFL, concatRL, concatReverseFL, headRL,+                             MyEq, unsafeCompare, (=\/=), (=/\=),+                             consRLSealed, nullRL,+                             unsafeCoerceP, unsafeCoerceP2+                           ) where++#include "impossible.h"+import GHC.Base (unsafeCoerce#)+import Darcs.Show+import Darcs.Sealed ( FlippedSeal(..), flipSeal )++data EqCheck C(a b) where+    IsEq :: EqCheck C(a a)+    NotEq :: EqCheck C(a b)++instance Eq (EqCheck C(a b)) where+    IsEq == IsEq = True+    NotEq == NotEq = True+    _ == _ = False++isEq :: EqCheck C(a b) -> Bool+isEq IsEq = True+isEq NotEq = False++instance Show (EqCheck C(a b)) where+    show IsEq = "IsEq"+    show NotEq = "NotEq"++data Proof a C(x y) where+    Proof :: a -> Proof a C(x x)++data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y))+infixr 1 :>+data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z))+infix 1 :<+infix 1 :/\:, :\/:+data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y))+data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z))+class MyEq p where+    -- Minimal definition defines any one of unsafeCompare, =\/= and =/\=.+    unsafeCompare :: p C(a b) -> p C(c d) -> Bool+    unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)+    (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c)+    a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq+             | otherwise = NotEq+    (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b)+    a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq+             | otherwise = NotEq++infix 4 =\/=, =/\=++unsafeCoerceP :: a C(x y) -> a C(b c)+unsafeCoerceP = unsafeCoerce#++unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d)+unsafeCoerceP2 = unsafeCoerce#++instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where+    showsPrec d (x :> y) = showOp2 1 ":>" d x y++instance (Show2 a, Show2 b) => Show2 (a :> b) where+    showsPrec2 = showsPrec++instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where+    showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y++instance (Show2 a, Show2 b) => Show2 (a :\/: b) where+    showsPrec2 = showsPrec++infixr 5 :>:, :<:, +>+, +<+++-- forward list+data FL a C(x z) where+    (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z)+    NilFL :: FL a C(x x)++instance Show2 a => Show (FL a C(x z)) where+   showsPrec _ NilFL = showString "NilFL"+   showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                            showString " :>: " . showsPrec (prec + 1) xs+       where prec = 5++instance Show2 a => Show2 (FL a) where+   showsPrec2 = showsPrec++-- reverse list+data RL a C(x z) where+    (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z)+    NilRL :: RL a C(x x)++nullFL :: FL a C(x z) -> Bool+nullFL NilFL = True+nullFL _ = False++nullRL :: RL a C(x z) -> Bool+nullRL NilRL = True+nullRL _ = False++filterFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z)+filterFL _ NilFL = NilFL+filterFL f (x:>:xs) | IsEq <- f x = filterFL f xs+                    | otherwise = x :>: filterFL f xs++filterE :: (a -> EqCheck C(x y)) -> [a] -> [Proof a C(x y)]+filterE _ [] = []+filterE p (x:xs)+    | IsEq <- p x = Proof x : filterE p xs+    | otherwise   = filterE p xs++(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z)+NilFL +>+ ys = ys+(x:>:xs) +>+ ys = x :>: xs +>+ ys++(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z)+NilRL +<+ ys = ys+(x:<:xs) +<+ ys = x :<: xs +<+ ys++reverseFL :: FL a C(x z) -> RL a C(x z)+reverseFL xs = r NilRL xs+  where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o)+        r ls NilFL = ls+        r ls (a:>:as) = r (a:<:ls) as++reverseRL :: RL a C(x z) -> FL a C(x z)+reverseRL xs = r NilFL xs -- r (xs :> NilFL)+  where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o)+        r ls NilRL = ls+        r ls (a:<:as) = r (a:>:ls) as++concatFL :: FL (FL a) C(x z) -> FL a C(x z)+concatFL NilFL = NilFL+concatFL (a:>:as) = a +>+ concatFL as++concatRL :: RL (RL a) C(x z) -> RL a C(x z)+concatRL NilRL = NilRL+concatRL (a:<:as) = a +<+ concatRL as++spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z)+spanFL f (x:>:xs) | f x = case spanFL f xs of+                            ys :> zs -> (x:>:ys) :> zs+spanFL _ xs = NilFL :> xs++splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z)+splitAtFL 0 xs = NilFL :> xs+splitAtFL _ NilFL = NilFL :> NilFL+splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of+                       (xs':>xs'') -> (x:>:xs' :> xs'')++-- 'bunchFL n' groups patches into batches of n, except that it always puts+-- the first patch in its own group, this being a recognition that the+-- first patch is often *very* large.++bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y)+bunchFL _ NilFL = NilFL+bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs+    where bFL :: FL a C(x y) -> FL (FL a) C(x y)+          bFL NilFL = NilFL+          bFL bs = case splitAtFL n bs of+                   a :> b -> a :>: bFL b+++allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool+allFL f xs = and $ mapFL f xs++foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a+foldlFL _ x NilFL = x+foldlFL f x (y:>:ys) = foldlFL f (f x y) ys++foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a+foldlRL _ x NilRL = x+foldlRL f x (y:<:ys) = foldlRL f (f x y) ys++mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z)+mapFL_FL _ NilFL = NilFL+mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as++zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y))+          -> [a] -> FL p C(w z) -> FL q C(w z)+zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys+zipWithFL _ _ NilFL = NilFL+zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"++mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z)+mapRL_RL _ NilRL = NilRL+mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as++mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b]+mapFL _ NilFL = []+mapFL f (a :>: b) = f a : mapFL f b++mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b]+mapRL _ NilRL = []+mapRL f (a :<: b) = f a : mapRL f b++unsafeMap_l2f :: (FORALL(w z) a -> b C(w z)) -> [a] -> FL b C(x y)+unsafeMap_l2f _ [] = unsafeCoerceP NilFL+unsafeMap_l2f f (x:xs) = f x :>: unsafeMap_l2f f xs++lengthFL :: FL a C(x z) -> Int+lengthFL xs = l xs 0+  where l :: FL a C(x z) -> Int -> Int+        l NilFL n = n+        l (_:>:as) n = l as $! n+1++lengthRL :: RL a C(x z) -> Int+lengthRL xs = l xs 0+  where l :: RL a C(x z) -> Int -> Int+        l NilRL n = n+        l (_:<:as) n = l as $! n+1++isShorterThanRL :: RL a C(x y) -> Int -> Bool+isShorterThanRL _ n | n <= 0 = False+isShorterThanRL NilRL _ = True+isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)++concatReverseFL :: FL (RL a) C(x y) -> RL a C(x y)+concatReverseFL = concatRL . reverseFL++headRL :: RL a C(x y) -> FlippedSeal a C(y)+headRL (x:<:_) = flipSeal x+headRL _ = impossible++consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z)+consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as++#ifndef GADT_WITNESSES+-- These are useful for interfacing with modules outside of+-- patch theory, such as Show.lhs+unsafeUnFL :: FL a -> [a]+unsafeUnFL NilFL = []+unsafeUnFL (a:>:as) = a : unsafeUnFL as++unsafeUnRL :: RL a -> [a]+unsafeUnRL NilRL = []+unsafeUnRL (a:<:as) = a : unsafeUnRL as++unsafeFL :: [a] -> FL a+unsafeFL [] = NilFL+unsafeFL (a:as) = a :>: unsafeFL as++unsafeRL :: [a] -> RL a+unsafeRL [] = NilRL+unsafeRL (a:as) = a :<: unsafeRL as+#endif
+ src/Darcs/Patch.lhs view
@@ -0,0 +1,151 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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.++\chapter{Theory of patches}+\label{Patch}++\newtheorem{thm}{Theorem}+\newtheorem{dfn}{Definition}++\section{Background}++I think a little background on the author is in order.  I am a physicist,+and think like a physicist.  The proofs and theorems given here are what I+would call ``physicist'' proofs and theorems, which is to say that while+the proofs may not be rigorous, they are practical, and the theorems are+intended to give physical insight.  It would be great to have a+mathematician work on this to give patch theory better formalized+foundations.++From the beginning of this theory, which originated as the result of a+series of email discussions with Tom Lord, I have looked at patches as+being analogous to the operators of quantum mechanics.  I include in this+appendix footnotes explaining the theory of patches in terms of the theory+of quantum mechanics.  I advise against taking this analogy too seriously,+although it could provide some insight into how a physicist might think+about darcs.++\begin{code}+{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}+#include "gadts.h"+module Darcs.Patch ( RepoPatch, Prim, Patch, RealPatch, Named, Patchy,+                     flattenFL, joinPatches,+                     fromPrim, fromPrims,+               is_null_patch, nullP,+               rmfile, addfile, rmdir, adddir, move,+               hunk, tokreplace, namepatch, anonymous,+               binary,+               description,+               showContextPatch, showPatch, showNicely,+               infopatch, changepref,+               thing, things,+               is_similar, is_addfile, is_hunk, is_setpref,+#ifndef GADT_WITNESSES+               merger, is_merger, merge,+               commute, commutex, list_touched_files,+               -- for PatchTest+               unravel, elegant_merge,+#else+               Commute(..),+#endif+               resolve_conflicts,+               Effect, effect,+               is_binary, gzWritePatch, writePatch, is_adddir,+               invert, invertFL, invertRL, identity,+               commuteFL, commuteRL,+               readPatch,+               canonize, sort_coalesceFL,+               try_to_shrink,+               apply_to_slurpy, patchname, patchcontents,+               apply_to_filepaths, force_replace_slurpy, apply,+               patch2patchinfo,+               LineMark(AddedLine, RemovedLine, AddedRemovedLine, None),+               MarkedUpFile, markup_file, empty_markedup_file,+               summary, summarize, xml_summary,+               adddeps, getdeps,+               list_conflicted_files,+               modernize_patch,+               -- for Population+               DirMark(..), patchChanges, applyToPop,+             ) where+import Darcs.PopulationData ( DirMark(..) )+import Darcs.Patch.Core ( Patch, Named,+                          flattenFL,+                          adddeps, namepatch,+                          anonymous,+#ifndef GADT_WITNESSES+                          is_merger,+#endif+                          getdeps,+                          is_null_patch, nullP, infopatch,+                          patch2patchinfo, patchname, patchcontents )+import Darcs.Patch.Read ( readPatch )+import Darcs.Patch.Patchy ( Patchy, writePatch, gzWritePatch,+                            showPatch, showNicely, showContextPatch,+                            invert, invertRL, invertFL, identity,+                            thing, things,+                            commuteFL, commuteRL, apply,+                            description, summary,+#ifndef GADT_WITNESSES+                            commute, commutex, list_touched_files,+#else+                            Commute(..)+#endif+                          )+import Darcs.Patch.Viewing ( xml_summary, summarize )+import Darcs.Patch.Apply ( applyToPop, patchChanges, empty_markedup_file,+                           markup_file, force_replace_slurpy,+                           apply_to_filepaths, apply_to_slurpy,+                           LineMark(..), MarkedUpFile )+import Darcs.Patch.Commute ( modernize_patch,+#ifndef GADT_WITNESSES+                             unravel,+                             merger, merge, elegant_merge,+#endif+                            )+import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim,+                          Conflict, Effect(effect), list_conflicted_files, resolve_conflicts,+                          Prim, canonize,+                          sort_coalesceFL,+                          rmdir, rmfile, tokreplace, adddir, addfile,+                          binary, changepref, hunk, move, +                          is_adddir, is_addfile,+                          is_hunk, is_binary, is_setpref,+                          is_similar,+                          try_to_shrink )+import Darcs.Ordered ( FL )+import Darcs.Patch.Real ( RealPatch )++instance Patchy Patch+instance (Conflict p, Effect p, Patchy p) => Patchy (Named p)++class (Patchy p, Effect p, FromPrim p, Conflict p) => RepoPatchBase p+instance RepoPatchBase Patch+instance RepoPatchBase RealPatch++class (Patchy p, Effect p, FromPrims p, Conflict p) => RepoPatch p+instance RepoPatch Patch+instance RepoPatchBase p => RepoPatch (FL p)++\end{code}++\input{Darcs/Patch/Apply.lhs}+\input{Darcs/Patch/Core.lhs}+\input{Darcs/Patch/Prim.lhs}+\input{Darcs/Patch/Commute.lhs}+\input{Darcs/Patch/Show.lhs}+
+ src/Darcs/Patch/Apply.lhs view
@@ -0,0 +1,522 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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.+++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Apply ( apply_to_filepaths, apply_to_slurpy,+                           forceTokReplace,+                           markup_file, empty_markedup_file,+                           patchChanges,+                           applyToPop,+                           LineMark(..), MarkedUpFile,+                           force_replace_slurpy )+    where++import Prelude hiding ( catch, pi )+import Darcs.Flags ( DarcsFlag( SetScriptsExecutable ) )++import qualified Data.ByteString.Char8 as BC (split, break, pack, singleton)++import qualified Data.ByteString       as B (ByteString, null, empty, concat, isPrefixOf)+import ByteStringUtils ( linesPS, unlinesPS, break_after_nth_newline, break_before_nth_newline, )++import Darcs.Patch.FileName ( fn2ps, fn2fp, fp2fn,+                              movedirfilename )+import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..) )+import Data.List ( intersperse )+import Data.Maybe ( catMaybes )+import Darcs.Patch.Patchy ( Apply, apply, applyAndTryToFixFL, applyAndTryToFix,+                            mapMaybeSnd )+import Darcs.Patch.Commute ()+import Darcs.Patch.Core ( Patch(..), Named(..) )+import Darcs.Patch.Prim ( Prim(..), Effect(effect),+                          DirPatchType(..), FilePatchType(..),+                          try_tok_internal )+import Darcs.Patch.Info ( PatchInfo )+import Control.Monad ( when )+import Darcs.SlurpDirectory ( FileContents, Slurpy, withSlurpy, slurp_modfile )+import RegChars ( regChars )+import Darcs.Repository.Prefs ( change_prefval )+import Darcs.Global ( darcsdir )+import Darcs.IO ( WriteableDirectory(..), ReadableDirectory(..) )+import Darcs.FilePathMonad ( withFilePaths )+#include "impossible.h"+import Darcs.Ordered ( FL(..), (:>)(..),+                             mapFL, mapFL_FL, spanFL, foldlFL )+\end{code}++++\section{Introduction}++A patch describes a change to the tree.  It could be either a primitive+patch (such as a file add/remove, a directory rename, or a hunk replacement+within a file), or a composite patch describing many such changes.  Every+patch type must satisfy the conditions described in this appendix.  The+theory of patches is independent of the data which the patches manipulate,+which is what makes it both powerful and useful, as it provides a framework+upon which one can build a revision control system in a sane manner.++Although in a sense, the defining property of any patch is that it can be+applied to a certain tree, and thus make a certain change, this change does+not wholly define the patch.  A patch is defined by a+\emph{representation}, together with a set of rules for how it behaves+(which it has in common with its patch type).  The \emph{representation} of+a patch defines what change that particular patch makes, and must be+defined in the context of a specific tree.  The theory of patches is a+theory of the many ways one can change the representation of a patch to+place it in the context of a different tree.  The patch itself is not+changed, since it describes a single change, which must be the same+regardless of its representation\footnote{For those comfortable with+quantum mechanics, think of a patch as a quantum mechanical operator, and+the representation as the basis set.  The analogy breaks down pretty+quickly, however, since an operator could be described in any complete+basis set, while a patch modifying the file {\tt foo} can only be described+in the rather small set of contexts which have a file {\tt foo} to be+modified.}.++So how does one define a tree, or the context of a patch? The simplest way+to define a tree is as the result of a series of patches applied to the+empty tree\footnote{This is very similar to the second-quantized picture,+in which any state is seen as the result of a number of creation operators+acting on the vacuum, and provides a similar set of simplifications---in+particular, the exclusion principle is very elegantly enforced by the+properties of the anti-hermitian fermion creation operators.}.  Thus, the+context of a patch consists of the set of patches that precede it.++\section{Applying patches}+++\begin{code}+apply_to_filepaths :: Apply p => p C(x y) -> [FilePath] -> [FilePath]+apply_to_filepaths pa fs = withFilePaths fs (apply [] pa)++apply_to_slurpy :: (Apply p, Monad m) => p C(x y) -> Slurpy -> m Slurpy+apply_to_slurpy p s = case withSlurpy s (apply [] p) of+                          Left err -> fail err+                          Right (s', ()) -> return s'++instance Apply p => Apply (Named p) where+    apply opts (NamedP _ _ p) = apply opts p+    applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p++instance Apply Patch where+    apply opts p = applyFL opts $ effect p+    applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x+    applyAndTryToFixFL (ComP xs) = mapMaybeSnd (\xs' -> ComP xs' :>: NilFL) `fmap` applyAndTryToFix xs+    applyAndTryToFixFL x = do apply [] x; return Nothing+    applyAndTryToFix (ComP xs) = mapMaybeSnd ComP `fmap` applyAndTryToFix xs+    applyAndTryToFix x = do mapMaybeSnd ComP `fmap` applyAndTryToFixFL x++force_replace_slurpy :: Prim C(x y) -> Slurpy -> Maybe Slurpy+force_replace_slurpy (FP f (TokReplace tcs old new)) s =+    slurp_modfile f (forceTokReplace tcs old new) s+force_replace_slurpy _ _ = bug "Can only force_replace_slurpy on a replace."++instance Apply Prim where+    apply opts (Split ps) = applyFL opts ps+    apply _ Identity = return ()+    apply _ (FP f RmFile) = mRemoveFile f+    apply _ (FP f AddFile) = mCreateFile f+    apply opts p@(FP _ (Hunk _ _ _)) = applyFL opts (p :>: NilFL)+    apply _ (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace+        where doreplace ls =+                  case mapM (try_tok_internal t (BC.pack o) (BC.pack n)) ls of+                  Nothing -> fail $ "replace patch to " ++ fn2fp f+                             ++ " couldn't apply."+                  Just ls' -> return $ map B.concat ls'+    apply _ (FP f (Binary o n)) = mModifyFilePS f doapply+        where doapply oldf = if o == oldf+                             then return n+                             else fail $ "binary patch to " ++ fn2fp f+                                  ++ " couldn't apply."+    apply _ (DP d AddDir) = mCreateDirectory d+    apply _ (DP d RmDir) = mRemoveDirectory d+    apply _ (Move f f') = mRename f f'+    apply _ (ChangePref p f t) =+        do b <- mDoesDirectoryExist (fp2fn $ darcsdir++"/prefs")+           when b $ change_prefval p f t+    applyAndTryToFixFL (FP f RmFile) =+        do x <- mReadFilePS f+           if B.null x then do mRemoveFile f+                               return Nothing+                       else do mWriteFilePS f B.empty+                               mRemoveFile f+                               return $ Just ("WARNING: Fixing removal of non-empty file "++fn2fp f,+                                              FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL )+    applyAndTryToFixFL p = do apply [] p; return Nothing++applyFL :: WriteableDirectory m => [DarcsFlag] -> FL Prim C(x y) -> m ()+applyFL _ NilFL = return ()+applyFL opts ((FP f h@(Hunk _ _ _)):>:the_ps)+ = case spanFL f_hunk the_ps of+       (xs :> ps') ->+           do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs+              mModifyFilePS f $ hunkmod foo+              case h of+                (Hunk 1 _ (n:_)) | BC.pack "#!" `B.isPrefixOf` n &&+                                   SetScriptsExecutable `elem` opts+                                 -> mSetFileExecutable f True+                _ -> return ()+              applyFL opts ps'+    where f_hunk (FP f' (Hunk _ _ _)) | f == f' = True+          f_hunk _ = False+          hunkmod :: WriteableDirectory m => FL FilePatchType C(x y)+                  -> B.ByteString -> m B.ByteString+          hunkmod NilFL ps = return ps+          hunkmod (Hunk line old new:>:hs) ps+           = case applyHunkLines [(line,old,new)] ps of+                 Just ps' -> hunkmod hs ps'+                 Nothing -> fail $ "Error applying hunk to file " ++ fn2fp f+          hunkmod _ _ = impossible+applyFL opts (p:>:ps) = do apply opts p+                           applyFL opts ps+\end{code}++\subsection{Hunk patches}++Hunks are an example of a complex filepatch.  A hunk is a set of lines of a+text file to be replaced by a different set of lines.  Either of these sets+may be empty, which would mean a deletion or insertion of lines.+\begin{code}+applyHunks :: [(Int, [B.ByteString], [B.ByteString])]+           -> B.ByteString -> Maybe [B.ByteString]+applyHunks [] ps = Just [ps]+applyHunks ((l, [], n):hs) ps+    = case break_before_nth_newline (l - 2) ps of+      (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix+                                  return $ intersperse nl (prfix:n) ++ rest+                                       where nl = BC.singleton '\n'+applyHunks ((l, o, n):hs) ps+    = case break_before_nth_newline (l - 2) ps of+      (prfix, after_prefix) ->+          case break_before_nth_newline (length o) after_prefix of+          (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error"+          (_, suffix) ->+              do rest <- applyHunks hs suffix+                 return $ intersperse nl (prfix:n) ++ rest+    where nl = BC.singleton '\n'++applyHunkLines :: [(Int, [B.ByteString], [B.ByteString])]+               -> FileContents -> Maybe FileContents+applyHunkLines [] c = Just c+applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty])+applyHunkLines hs@((l, o, n):hs') ps =+ do pss <- case l of+           1 -> case break_after_nth_newline (length o) ps of+                Nothing -> if ps == unlinesPS o+                           then return $ intersperse nl n+                           else fail "applyHunkLines: Unexpected hunks"+                Just (shouldbeo, suffix)+                    | shouldbeo /= unlinesPS (o++[B.empty]) ->+                        fail $ "applyHunkLines: Bad patch!"+                    | null n ->+                        do x <- applyHunkLines hs' suffix+                           return [x]+                    | otherwise ->+                        do rest <- applyHunks hs' suffix+                           return $ intersperse nl n ++ nl:rest+           _ | l < 0 -> bug "Prim.applyHunkLines: After -ve lines?"+             | otherwise -> applyHunks hs ps+    let result = B.concat pss+    return result+    where nl = BC.singleton '\n'+\end{code}++\subsection{Token replace patches}\label{token_replace}++Although most filepatches will be hunks, darcs is clever enough to support+other types of changes as well.  A ``token replace'' patch replaces all+instances of a given token with some other version.  A token, here, is+defined by a regular expression, which must be of the simple [a--z\ldots]\ type,+indicating which characters are allowed in a token, with all other+characters acting as delimiters.  For example, a C identifier would be a+token with the flag \verb![A-Za-z_0-9]!.++\begin{code}+forceTokReplace :: String -> String -> String+                -> FileContents -> Maybe FileContents+forceTokReplace t os ns c = Just $ unlinesPS $ map forceReplace $ linesPS c+    where o = BC.pack os+          n = BC.pack ns+          tokchar = regChars t+          toks_and_intratoks ps | B.null ps = []+          toks_and_intratoks ps =+              let (before,s') = BC.break tokchar ps+                  (tok, after) = BC.break (not . tokchar) s'+                  in before : tok : toks_and_intratoks after+          forceReplace ps = B.concat $ map o_t_n $ toks_and_intratoks ps+          o_t_n s | s == o = n+                  | otherwise = s+\end{code}++What makes the token replace patch special is the fact that a token replace+can be merged with almost any ordinary hunk, giving exactly what you would+want.  For example, you might want to change the patch type {\tt+TokReplace} to {\tt TokenReplace} (if you decided that saving two+characters of space was stupid).  If you did this using hunks, it would+modify every line where {\tt TokReplace} occurred, and quite likely provoke+a conflict with another patch modifying those lines.  On the other hand, if+you did this using a token replace patch, the only change that it could+conflict with would be if someone else had used the token ``{\tt+TokenReplace}'' in their patch rather than TokReplace---and that actually+would be a real conflict!++%\section{Outputting interesting and useful information}++%Just being able to manipulate patches and trees is not enough.  We also+%want to be able to view the patches and files.  This requires another set+%of functions, closely related to the patch application functions, which+%will give us the necessary information to browse the changes we have made.+%It is \emph{not} the Patch module's responsibility to add any sort of+%markup or formatting, but simply to provide the information necessary for an+%external module to do the formatting.++\begin{code}+data LineMark = AddedLine PatchInfo | RemovedLine PatchInfo+              | AddedRemovedLine PatchInfo PatchInfo | None+                deriving (Show)+type MarkedUpFile = [(B.ByteString, LineMark)]+empty_markedup_file :: MarkedUpFile+empty_markedup_file = [(B.empty, None)]++markup_file :: Effect p => PatchInfo -> p C(x y)+            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)+markup_file x p = mps (effect p)+    where mps :: FL Prim C(a b) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)+          mps NilFL = id+          mps (pp:>:pps) = mps pps . markup_prim x pp++markup_prim :: PatchInfo -> Prim C(x y)+            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)+markup_prim _ (Split NilFL) (f, mk) = (f, mk)+markup_prim n (Split (p:>:ps)) (f, mk) = markup_prim n (Split ps) $+                                       markup_prim n p (f, mk)+markup_prim _ (FP _ AddFile) (f, mk) = (f, mk)+markup_prim _ (FP _ RmFile) (f, mk) = (f, mk)+markup_prim n (FP f' (Hunk line old new)) (f, mk)+    | fn2fp f' /= f = (f, mk)+    | otherwise = (f, markup_hunk n line old new mk)+markup_prim name (FP f' (TokReplace t o n)) (f, mk)+    | fn2fp f' /= f = (f, mk)+    | otherwise = (f, markup_tok name t o n mk)+markup_prim _ (DP _ _) (f, mk) = (f, mk)+markup_prim _ (Move d d') (f, mk) = (fn2fp $ movedirfilename d d' (fp2fn f), mk)+markup_prim _ (ChangePref _ _ _) (f,mk) = (f,mk)+markup_prim _ Identity (f,mk) = (f,mk)+markup_prim n (FP f' (Binary _ _)) (f,mk)+    | fn2fp f' == f = (f,(BC.pack "Binary file", AddedLine n):mk)+    | otherwise = (f,mk)++markup_hunk :: PatchInfo -> Int -> [B.ByteString] -> [B.ByteString]+            -> MarkedUpFile -> MarkedUpFile+markup_hunk n l old new ((sf, RemovedLine pi):mk) =+    (sf, RemovedLine pi) : markup_hunk n l old new mk+markup_hunk n l old new ((sf, AddedRemovedLine po pn):mk) =+    (sf, AddedRemovedLine po pn) : markup_hunk n l old new mk++markup_hunk name 1 old (n:ns) mk =+    (n, AddedLine name) : markup_hunk name 1 old ns mk+markup_hunk n 1 (o:os) [] ((sf, None):mk)+    | o == sf = (sf, RemovedLine n) : markup_hunk n 1 os [] mk+    | otherwise = [(BC.pack "Error in patch application", AddedLine n)]+markup_hunk n 1 (o:os) [] ((sf, AddedLine nold):mk)+    | o == sf = (sf, AddedRemovedLine nold n) : markup_hunk n 1 os [] mk+    | otherwise = [(BC.pack "Error in patch application", AddedLine n)]+markup_hunk _ 1 [] [] mk = mk++markup_hunk n l old new ((sf, AddedLine pi):mk)+    | l > 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk+    | l < 1 = (sf, AddedLine pi) : markup_hunk n (l-1) old new mk+markup_hunk n l old new ((sf, None):mk)+    | l > 1 = (sf, None) : markup_hunk n (l-1) old new mk+    | l < 1 = (sf, None) : markup_hunk n (l-1) old new mk++markup_hunk _ _ _ _ [] = []++markup_hunk _ _ _ _ mk = (BC.pack "Error: ",None) : mk++markup_tok :: PatchInfo -> String -> String -> String+           -> MarkedUpFile -> MarkedUpFile+markup_tok name t ostr nstr mk = concatMap mt mk+    where o = BC.pack ostr+          n = BC.pack nstr+          mt (sf, AddedLine pi) =+              case B.concat `fmap` try_tok_internal t o n sf of+              Just sf' | sf' == sf -> [(sf, AddedLine pi)]+                       | otherwise -> [(sf, AddedRemovedLine pi name),+                                       (sf', AddedLine name)]+              Nothing ->+                  [(sf, AddedLine pi),+                   (BC.pack "There seems to be an inconsistency...", None),+                   (BC.pack "Please run darcs check.", None)]+          mt mark = [mark]+\end{code}++%files or directories, changed by a patch+%we get it solely from the patch here+%instead of performing patch apply on a population+%we !could! achieve the same by applying a patch to a cleaned population+%and getting modified files and dirs+%but this should be significantly slower when the population grows large+%This could be useful for just presenting a summary of what a patch does+%(especially useful for larger repos)++\begin{code}+patchChanges :: Prim C(x y) -> [(String,DirMark)]+patchChanges (Move f1 f2) = [(fn2fp f1,MovedFile $ fn2fp f2),+                             (fn2fp f2,MovedFile $ fn2fp f1)]+patchChanges (DP d AddDir) = [(fn2fp d,AddedDir)]+patchChanges (DP d RmDir) = [(fn2fp d,RemovedDir)]+patchChanges (FP f AddFile) = [(fn2fp f,AddedFile)]+patchChanges (FP f RmFile) = [(fn2fp f,RemovedFile)]+patchChanges (FP f _) = [(fn2fp f,ModifiedFile)]+patchChanges (Split ps) = concat $ mapFL patchChanges ps+patchChanges (ChangePref _ _ _) = []+patchChanges Identity = []+\end{code}++%apply a patch to a population at a given time++\begin{code}+applyToPop :: PatchInfo -> FL Prim C(x y) -> Population -> Population+applyToPop _ NilFL = id+applyToPop pinf (p:>:ps) = applyToPop pinf ps . applyToPop' pinf p ++applyToPop'+    :: PatchInfo -> Prim C(x y) -> Population -> Population+applyToPop' pi patch (Pop _ tree)+ = Pop pi (applyToPopTree patch tree)+   -- ``pi'' is global below!+ where applyToPopTree :: Prim C(x y) -> PopTree -> PopTree+       applyToPopTree (Split ps) tr =+        foldlFL (\t p -> applyToPopTree p t) tr ps+       applyToPopTree p@(FP f AddFile) tr =+           let xxx = BC.split '/' (fn2ps  f) in+               popChange xxx p $ fst $ breakP xxx tr+       applyToPopTree p@(FP f _) tr = popChange (BC.split '/' (fn2ps  f)) p tr+       applyToPopTree p@(DP f AddDir) tr =+           let xxx = BC.split '/' (fn2ps  f) in+               popChange xxx p $ fst $ breakP xxx tr+       applyToPopTree p@(DP d _) tr = popChange (BC.split '/' (fn2ps  d)) p tr+       -- precondition: ``to'' does not exist yet!+       applyToPopTree (Move from to) tr+        = case breakP (BC.split '/' (fn2ps from)) $+               fst $ breakP (BC.split '/' $ fn2ps to) tr of+           (tr',Just ins) ->+               let to' = (BC.split '/' (fn2ps to))+                   ins' = case ins of+                          PopDir i trs -> PopDir (i {nameI = last to',+                                                     modifiedByI = pi,+                                                     modifiedHowI = MovedDir (fn2fp from)})+                                                 trs+                          PopFile i -> PopFile (i {nameI = last to',+                                                   modifiedByI = pi,+                                                   modifiedHowI = MovedFile (fn2fp from)})+                             in insertP to' tr' ins'+           _ -> tr -- ignore the move if ``from'' couldn't be found+       applyToPopTree (ChangePref _ _ _) tr = tr+       applyToPopTree Identity tr = tr++       -- insert snd arg into fst arg+       insertP :: [B.ByteString] -> PopTree -> PopTree -> PopTree+       insertP [parent,_] org@(PopDir f trs) tr+        | parent == (nameI f) = PopDir f (tr:trs)+        | otherwise = org+       insertP (n:rest) org@(PopDir f trs) tr+        | (nameI f) == n = PopDir f trs'+        | otherwise = org+          where trs' = map (\o -> insertP rest o tr) trs+       insertP _ org _ = org++       -- change a population according to a patch+       popChange :: [B.ByteString] -> Prim C(x y) -> PopTree -> PopTree+       popChange [parent,path] (DP d AddDir) tr@(PopDir f trs)+        | parent == (nameI f) = PopDir f (new:trs)+        | otherwise = tr+              where new = PopDir (Info {nameI = path,+                                        modifiedByI = pi,+                                        modifiedHowI = AddedDir,+                                        createdByI = Just pi,+                                        creationNameI = Just $ fn2ps d}) []+       -- only mark a directory (and contents) as ``deleted'' do not delete it actually+       popChange [path] (DP _ RmDir) tr@(PopDir f trs)+        | path == (nameI f) = PopDir (f {modifiedByI = pi,+                                         modifiedHowI = RemovedDir}) trs'+        | otherwise = tr+          where trs' = map markDel trs -- recursively ``delete'' the contents++       popChange [parent,path] (FP d AddFile) tr@(PopDir f trs)+        | parent == (nameI f) = PopDir f (new:trs)+        | otherwise = tr+              where new = PopFile (Info {nameI = path,+                                         modifiedByI = pi,+                                         modifiedHowI = AddedFile,+                                         createdByI = Just pi,+                                         creationNameI = Just $ fn2ps d})+       popChange [path] (FP _ RmFile) tr@(PopFile f)+        | path == (nameI f) = PopFile (f {modifiedByI = pi,+                                         modifiedHowI = RemovedFile})+        | otherwise = tr+       popChange [path] (FP _ _) (PopFile f)+        | path == (nameI f)+           = PopFile (f {modifiedByI = pi,+                         modifiedHowI = if modifiedHowI f == AddedFile && modifiedByI f == pi+                                        then AddedFile+                                        else ModifiedFile})+       popChange (n:rest) p tr@(PopDir f trs)+        | (nameI f) == n = PopDir f (map (popChange rest p) trs)+        | otherwise = tr+       popChange _ _ tr = tr+       markDel (PopDir f trs) = PopDir (f {modifiedByI = pi,+                                           modifiedHowI = RemovedDir}) trs'+                where trs' = map markDel trs+       markDel (PopFile f) = PopFile (f {modifiedByI = pi,+                                         modifiedHowI = RemovedFile})++-- break a poptree fst: org tree with subtree removed,+--                 snd: removed subtree+breakP :: [B.ByteString] -> PopTree -> (PopTree,Maybe PopTree)+breakP [parent,path] tr@(PopDir f trees)+ | parent == (nameI f) = case findRem path trees of+                         Just (trees',tree') -> (PopDir f trees',Just tree')+                         _ -> (tr,Nothing)+ | otherwise = (tr,Nothing)+ where findRem _ [] = Nothing+       findRem the_path (d:trs)+        | the_path == pname d = Just (trs,d)+        | otherwise = do (trs',d') <- findRem the_path trs+                         return (d:trs',d')+breakP (n:rest) tr@(PopDir f trs)+ | (nameI f) == n = case catMaybes inss of+                    [ins] -> (PopDir f trs', Just ins)+                    [] -> (tr,Nothing)+                    _ -> error "breakP: more than one break"+ | otherwise = (tr,Nothing)+   where (trs',inss) = unzip (map (breakP rest) trs)+breakP _ tr = (tr,Nothing)++pname :: PopTree -> B.ByteString+pname (PopDir i _) = nameI i+pname (PopFile i) = nameI i+\end{code}+
+ src/Darcs/Patch/Bundle.hs view
@@ -0,0 +1,211 @@+-- Copyright (C) 2002-2004,2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Bundle ( hash_bundle, make_bundle, make_bundle2, scan_bundle,+                     make_context, scan_context,+                   ) where++import Darcs.Flags ( DarcsFlag( Unified ) )+import Darcs.Hopefully ( PatchInfoAnd, piap,+                         patchInfoAndPatch,+                         unavailable, hopefully )+import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch )+import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP,+                             reverseFL, (+<+), mapFL, mapFL_FL )+import Printer ( Doc, renderPS, newline, text, ($$),+                 (<>), vcat, vsep, renderString )+import Darcs.SlurpDirectory ( Slurpy )++import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS)+import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf)+import qualified Data.ByteString.Char8 as BC (unpack, break, pack)++import SHA1( sha1PS )+import Darcs.Sealed ( Sealed(Sealed), mapSeal )++hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String+hash_bundle _ to_be_sent = sha1PS $ renderPS+                         $ vcat (mapFL showPatch to_be_sent) <> newline++make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc+make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent++-- | In make_bundle2, it is presumed that the two patch sequences are+-- identical, but that they may be lazily generated.  If two different+-- patch sequences are passed, a bundle with a mismatched hash will be+-- generated, which is not the end of the world, but isn't very useful+-- either.+make_bundle2 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo]+             -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc+make_bundle2 opts the_s common to_be_sent to_be_sent2 =+    text ""+ $$ text "New patches:"+ $$ text ""+ $$ the_new+ $$ text ""+ $$ text "Context:"+ $$ text ""+ $$ (vcat $ map showPatchInfo common)+ $$ text "Patch bundle hash:"+ $$ text (hash_bundle common to_be_sent2)+ $$ text ""+      where the_new = if Unified `elem` opts+                      then showContextPatch the_s to_be_sent+                      else vsep $ mapFL showPatch to_be_sent++scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p)+scan_bundle ps+  | B.null ps = Left "Bad patch bundle!"+  | otherwise =+    case silly_lex ps of+    ("New patches:",rest) ->+        case get_patches rest of+        (Sealed patches, rest') ->+            case silly_lex rest' of+            ("Context:", rest'') ->+                case get_context rest'' of+                (cont,maybe_hash) ->+                    case substrPS (BC.pack "Patch bundle hash:")+                         maybe_hash of+                    Just n ->+                        if hash_bundle cont (mapFL_FL hopefully patches)+                               == fst (silly_lex $ snd $ silly_lex $+                                       B.drop n maybe_hash)+                        then seal_up_patches patches cont+                        else Left $+                                 "Patch bundle failed hash!\n" +++                                 "This probably means that the patch has been "+++                                 "corrupted by a mailer.\n"+++                                 "The most likely culprit is CRLF newlines."+                    Nothing -> seal_up_patches patches cont+            (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"+                     ++ "\n" ++ BC.unpack r+    ("Context:",rest) ->+        case get_context rest of+        (cont, rest') ->+            case silly_lex rest' of+            ("New patches:", rest'') ->+                case parse_patches rest'' of+                Sealed ps'' -> seal_up_patches ps'' cont+            (a,_) -> Left $ "Malformed patch bundle: '" ++ a +++                     "' is not 'New patches:'"+    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->+            scan_bundle $ filter_gpg_dashes rest+    (_,rest) -> scan_bundle rest+    where seal_up_patches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> [PatchInfo]+                          -> Either String (SealedPatchSet p)+          seal_up_patches xxx yyy =+              case reverse yyy of+              (x:_) | is_tag x ->+                        Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy)+                                        :<: NilRL)+                                        -- The above NilRL isn't quite+                                        -- right, because ther *are*+                                        -- earlier patches, but we+                                        -- can't set this to undefined+                                        -- because there are+                                        -- situations where we look at+                                        -- the rest.  :{++                                        -- bug "No more patches in patch bundle!")+              _ -> Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy)+                                   :<: NilRL)++-- filter_gpg_dashes is needed because clearsigned patches escape dashes:+filter_gpg_dashes :: B.ByteString -> B.ByteString+filter_gpg_dashes ps =+    unlinesPS $ map drop_dashes $+    takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $+    dropWhile not_context_or_newpatches $ linesPS ps+    where drop_dashes x = if B.length x < 2 then x+                          else if BC.pack "- " `B.isPrefixOf` x+                               then B.drop 2 x+                               else x+          not_context_or_newpatches s = (s /= BC.pack "Context:") &&+                                        (s /= BC.pack "New patches:")++unavailable_patches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y)+unavailable_patches [] = unsafeCoerceP NilRL+unavailable_patches (x:xs) = pi_unavailable x :<: unavailable_patches xs++pi_unavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y)+pi_unavailable i = (i `patchInfoAndPatch`+                      unavailable ("Patch not stored in patch bundle:\n" +++                                   renderString (human_friendly i)))+get_context :: B.ByteString -> ([PatchInfo],B.ByteString)+get_context ps =+    case readPatchInfo ps of+    Just (pinfo,r') ->+        case get_context r' of+        (pis,r'') -> (pinfo:pis, r'')+    Nothing -> ([],ps)+(-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b)+p -:- (Sealed ps, r) = (Sealed (p:>:ps), r)+get_patches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString)+get_patches ps =+    case readPatchInfo ps of+    Nothing -> (Sealed NilFL, ps)+    Just (pinfo,_) ->+        case readPatch ps of+        Nothing -> (Sealed NilFL, ps)+        Just (Sealed p, r) -> (pinfo `piap` p) -:- get_patches r+parse_patches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x))+parse_patches ps =+  case readPatchInfo ps of+  Nothing -> Sealed NilFL+  Just (pinfo,_) ->+    case readPatch ps of+    Nothing -> Sealed NilFL+    Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parse_patches r++silly_lex :: B.ByteString -> (String, B.ByteString)+silly_lex ps = (BC.unpack a, b)+    where+        (a, b) = BC.break (== '\n') (dropSpace ps)++{-+silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps')+    where+        ps' = dropSpace ps+-}++make_context :: [PatchInfo] -> Doc+make_context common =+    text ""+ $$ text "Context:"+ $$ text ""+ $$ (vcat $ map showPatchInfo $ common)+ $$ text ""++scan_context :: RepoPatch p => B.ByteString -> PatchSet p C(x)+scan_context ps+  | B.null ps = error "Bad context!"+  | otherwise =+    case silly_lex ps of+    ("Context:",rest) ->+        case get_context rest of+        (cont, _) -> unavailable_patches cont :<: NilRL+    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->+            scan_context $ filter_gpg_dashes rest+    (_,rest) -> scan_context rest
+ src/Darcs/Patch/Check.hs view
@@ -0,0 +1,335 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++module Darcs.Patch.Check ( PatchCheck(), do_check, file_exists, dir_exists,+                    remove_file, remove_dir, create_file, create_dir,+                    insert_line, delete_line, is_valid, do_verbose_check,+                    file_empty,+                    check_move, modify_file, FileContents(..)+                  ) where++import System.IO.Unsafe ( unsafePerformIO )+import qualified Data.ByteString as B (ByteString)+import Data.List ( isPrefixOf, inits )+import Control.Monad.State ( State, evalState, runState )+import Control.Monad.State.Class ( get, put, modify )+-- use Map, not IntMap, because Map has mapKeys and IntMap hasn't+import Data.Map ( Map )+import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null )+import System.FilePath ( joinPath, splitDirectories )++-- | File contents are represented by a map from line numbers to line contents.+--   If for a certain line number, the line contents are Nothing, that means+--   that we are sure that that line exists, but we don't know its contents.+--   We must also store the greatest line number that is known to exist in a+--   file, to be able to exclude the possibility of it being empty without+--   knowing its contents.+data FileContents = FC { fc_lines   :: Map Int B.ByteString+                       , fc_maxline :: Int+                       } deriving (Eq, Show)+data Prop = FileEx String | DirEx String | NotEx String+          | FileLines String FileContents+            deriving (Eq)+-- | A @KnownState@ is a simulated repository state. The repository is either+-- inconsistent, or it has two lists of properties: one list with properties+-- that hold for this repo, and one with properties that do not hold for this+-- repo. These two lists may not have any common elements: if they had, the+-- repository would be inconsistent.+data KnownState = P [Prop] [Prop]+                | Inconsistent+                  deriving (Show)+instance  Show Prop  where+    show (FileEx f) = "FileEx "++f+    show (DirEx d)  = "DirEx "++d+    show (NotEx f) = "NotEx"++f+    show (FileLines f l)  = "FileLines "++f++": "++show l++-- | PatchCheck is a state monad with a simulated repository state+type PatchCheck = State KnownState++-- | The @FileContents@ structure for an empty file+empty_filecontents :: FileContents+empty_filecontents = FC M.empty 0++-- | Returns a given value if the repository state is inconsistent, and performs+--   a given action otherwise.+handle_inconsistent :: a            -- ^ The value to return if the state is inconsistent+                   -> PatchCheck a -- ^ The action to perform otherwise+                   -> PatchCheck a+handle_inconsistent v a = do state <- get+                             case state of+                               Inconsistent -> return v+                               _            -> a++do_check :: PatchCheck a -> a+do_check p = evalState p (P [] [])++-- | Run a check, and print the final repository state+do_verbose_check :: PatchCheck a -> a+do_verbose_check p =+    case runState p (P [] []) of+    (b, pc) -> unsafePerformIO $ do putStrLn $ show pc+                                    return b++-- | Returns true if the current repository state is not inconsistent+is_valid :: PatchCheck Bool+is_valid = handle_inconsistent False (return True)++has :: Prop -> [Prop] -> Bool+has _ [] = False+has k (k':ks) = k == k' || has k ks++modify_file :: String+            -> (Maybe FileContents -> Maybe FileContents)+            -> PatchCheck Bool+modify_file f change = do+    file_exists f+    c <- file_contents f+    case change c of+      Nothing -> assert_not $ FileEx f -- shorthand for "FAIL"+      Just c' -> do set_contents f c'+                    is_valid++insert_line :: String -> Int -> B.ByteString -> PatchCheck Bool+insert_line f n l = do+    c <- file_contents f+    case c of+      Nothing -> assert_not $ FileEx f -- in this case, the repo is inconsistent+      Just c' -> do+        let lines'   = M.mapKeys (\k -> if k >= n then k+1 else k) (fc_lines c')+            lines''  = M.insert n l lines'+            maxline' = max n (fc_maxline c')+        set_contents f (FC lines'' maxline')+        return True++-- deletes a line from a hunk patch (third argument) in the given file (first+-- argument) at the given line number (second argument)+delete_line :: String -> Int -> B.ByteString -> PatchCheck Bool+delete_line f n l = do+    c <- file_contents f+    case c of+      Nothing -> assert_not $ FileEx f+      Just c' ->+        let flines  = fc_lines c'+            flines' = M.mapKeys (\k -> if k > n then k-1 else k)+                                (M.delete n flines)+            maxlinenum' | n <= fc_maxline c'  = fc_maxline c' - 1+                        | otherwise           = n - 1+            c'' = FC flines' maxlinenum'+            do_delete = do+              set_contents f c''+              is_valid+        in case M.lookup n flines of+          Nothing -> do_delete+          Just l' -> if l == l'+                       then do_delete+                       else assert_not $ FileEx f++set_contents :: String -> FileContents -> PatchCheck ()+set_contents f c = handle_inconsistent () $ do+    P ks nots <- get+    let ks' = FileLines f c : filter (not . is_file_lines_for f) ks+    put (P ks' nots)+  where is_file_lines_for file prop = case prop of +                                        FileLines f' _ -> file == f'+                                        _              -> False++-- | Get (as much as we know about) the contents of a file in the current state.+--   Returns Nothing if the state is inconsistent.+file_contents :: String -> PatchCheck (Maybe FileContents)+file_contents f = handle_inconsistent Nothing $ do+      P ks _ <- get+      return (fic ks)+    where fic (FileLines f' c:_) | f == f' = Just c+          fic (_:ks) = fic ks+          fic [] = Just empty_filecontents++-- | Checks if a file is empty+file_empty :: String          -- ^ Name of the file to check+           -> PatchCheck Bool+file_empty f = do+  c <- file_contents f+  let empty = case c of+               Just c' -> fc_maxline c' == 0 && M.null (fc_lines c')+               Nothing -> True+  if empty+     then do set_contents f empty_filecontents+             is_valid+     -- Crude way to make it inconsistent and return false:+     else assert_not $ FileEx f+  return empty++movedirfilename :: String -> String -> String -> String+movedirfilename d d' f =+    if (d ++ "/") `isPrefixOf` f+    then d'++drop (length d) f+    else if f == d+         then d'+         else f++-- | Replaces a filename by another in all paths. Returns True if the repository+--   is consistent, False if it is not.+do_swap :: String -> String -> PatchCheck Bool+do_swap f f' = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (map sw ks) (map sw nots))+    return True+  where sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a+                      | f' `is_soe` a = FileEx $ movedirfilename f' f a+        sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a+                     | f' `is_soe` a = DirEx $ movedirfilename f' f a+        sw (FileLines a c) | f  `is_soe` a = FileLines (movedirfilename f f' a) c+                           | f' `is_soe` a = FileLines (movedirfilename f' f a) c+        sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a+                     | f' `is_soe` a = NotEx $ movedirfilename f' f a+        sw p = p+        is_soe d1 d2 = -- is_superdir_or_equal+            d1 == d2 || (d1 ++ "/") `isPrefixOf` d2++-- | Assert a property about the repository. If the property is already present+-- in the repo state, nothing changes, and the function returns True. If it is+-- not present yet, it is added to the repo state, and the function is True. If+-- the property is already in the list of properties that do not hold for the+-- repo, the state becomes inconsistent, and the function returns false.+assert :: Prop -> PatchCheck Bool+assert p = handle_inconsistent False $ do+    P ks nots <- get+    if has p nots+      then do+        put Inconsistent+        return False+      else if has p ks+             then return True+             else do+               put (P (p:ks) nots)+               return True++-- | Like @assert@, but negatively: state that some property must not hold for+--   the current repo.+assert_not :: Prop -> PatchCheck Bool+assert_not p = handle_inconsistent False $ do+    P ks nots <- get+    if has p ks+      then do+        put Inconsistent+        return False+      else if has p nots+             then return True+             else do+               put (P ks (p:nots))+               return True++-- | Remove a property from the list of properties that do not hold for this+-- repo (if it's there), and add it to the list of properties that hold.+-- Returns False if the repo is inconsistent, True otherwise.+change_to_true :: Prop -> PatchCheck Bool+change_to_true p = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (p:ks) (filter (p /=) nots))+    return True++-- | Remove a property from the list of properties that hold for this repo (if+-- it's in there), and add it to the list of properties that do not hold.+-- Returns False if the repo is inconsistent, True otherwise.+change_to_false :: Prop -> PatchCheck Bool+change_to_false p = handle_inconsistent False $ do+    modify (\(P ks nots) -> P (filter (p /=) ks) (p:nots))+    return True++assert_file_exists :: String -> PatchCheck Bool+assert_file_exists f = do assert_not $ NotEx f+                          assert_not $ DirEx f+                          assert $ FileEx f+assert_dir_exists :: String -> PatchCheck Bool+assert_dir_exists d = do assert_not $ NotEx d+                         assert_not $ FileEx d+                         assert $ DirEx d+assert_exists :: String -> PatchCheck Bool+assert_exists f = assert_not $ NotEx f++assert_no_such :: String -> PatchCheck Bool+assert_no_such f = do assert_not $ FileEx f+                      assert_not $ DirEx f+                      assert $ NotEx f++create_file :: String -> PatchCheck Bool+create_file fn = do+  superdirs_exist fn+  assert_no_such fn+  change_to_true (FileEx fn)+  change_to_false (NotEx fn)++create_dir :: String -> PatchCheck Bool+create_dir fn = do+  substuff_dont_exist fn+  superdirs_exist fn+  assert_no_such fn+  change_to_true (DirEx fn)+  change_to_false (NotEx fn)++remove_file :: String -> PatchCheck Bool+remove_file fn = do+  superdirs_exist fn+  assert_file_exists fn+  file_empty fn+  change_to_false (FileEx fn)+  change_to_true (NotEx fn)++remove_dir :: String -> PatchCheck Bool+remove_dir fn = do+  substuff_dont_exist fn+  superdirs_exist fn+  assert_dir_exists fn+  change_to_false (DirEx fn)+  change_to_true (NotEx fn)++check_move :: String -> String -> PatchCheck Bool+check_move f f' = do+  superdirs_exist f+  superdirs_exist f'+  assert_exists f+  assert_no_such f'+  do_swap f f'++substuff_dont_exist :: String -> PatchCheck Bool+substuff_dont_exist d = handle_inconsistent False $ do+    P ks _ <- get+    if all noss ks+      then return True+      else do+        put Inconsistent+        return False+  where noss (FileEx f) = not (is_within_dir f)+        noss (DirEx f) = not (is_within_dir f)+        noss _ = True+        is_within_dir f = (d ++ "/") `isPrefixOf` f++-- the init and tail calls dump the final init (which is just the path itself+-- again), the first init (which is empty), and the initial "." from+-- splitDirectories+superdirs_exist :: String -> PatchCheck Bool+superdirs_exist fn = and `fmap` mapM assert_dir_exists superdirs+  where superdirs =  map (("./"++) . joinPath) +                         (init (tail (inits (tail (splitDirectories fn)))))++file_exists :: String -> PatchCheck Bool+file_exists fn = do+  superdirs_exist fn+  assert_file_exists fn++dir_exists :: String -> PatchCheck Bool+dir_exists fn = do+  superdirs_exist fn+  assert_dir_exists fn
+ src/Darcs/Patch/Choices.hs view
@@ -0,0 +1,292 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}++#include "gadts.h"++-- | PatchChoices divides a sequence of patches into three sets: "first",+-- "middle" and "last", such that all patches can be applied, if you first+-- apply the first ones then the middle ones and then the last ones.+-- Obviously if there are dependencies between the patches that will put a+-- constraint on how you can choose to divide them up.  The PatchChoices data+-- type and associated functions are here to deal with many of the common+-- cases that come up when choosing a subset of a group of patches.+--+-- 'force_last' tells PatchChoices that a particular patch is required to be in+-- the "last" group, which also means that any patches that depend on it+-- must be in the "last" group.+--+-- Internally, a PatchChoices doesn't actually reorder the patches until it is+-- asked for the final output (e.g. by 'get_first_choice').  Instead, each+-- patch is placed in a state of definitely first, definitely last and+-- undecided; undecided leans towards "middle".  In case you're wondering+-- about the first-middle-last language, it's because in some cases the+-- "yes" answers will be last (as is the case for the revert command), and+-- in others first (as in record, pull and push).+module Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,+                      patch_slot,+                      get_choices,+                      separate_first_middle_from_last,+                      separate_first_from_middle_last,+                      force_first, force_firsts, force_last, force_lasts,+                      force_matching_first, force_matching_last,+                      select_all_middles,+                      make_uncertain, make_everything_later,+                      TaggedPatch, Tag, tag, tp_patch,+                             Slot(..),+                    ) where++import System.IO.Unsafe ( unsafePerformIO )+import Data.IORef ( newIORef, writeIORef, readIORef )+import Darcs.Patch+import Darcs.Patch.Permutations ( commuteWhatWeCanRL )+import Darcs.Patch.Patchy ( Invert, Commute )+import Darcs.Ordered ( FL(..), RL(..), MyEq, unsafeCompare,+                             (:>)(..), (:\/:)(..), (:/\:)(..),+                             zipWithFL, mapFL_FL, mapFL,+                             (+>+), reverseRL, unsafeCoerceP )+++newtype Tag = TG Integer deriving ( Num, Show, Eq, Ord, Enum )+data TaggedPatch p C(x y) = TP Tag (p C(x y))+data PatchChoice p C(x y) = PC (TaggedPatch p C(x y)) Slot+newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y))++data Slot = InFirst | InMiddle | InLast++invertTag :: Slot -> Slot+invertTag InFirst = InLast+invertTag InLast  = InFirst+invertTag t = t++tag :: TaggedPatch p C(x y) -> Tag+tag (TP (TG t) _) = TG t++tp_patch :: TaggedPatch p C(x y) -> p C(x y)+tp_patch (TP _ p) = p++liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))+liftTP f (TP t p) = TP t (f p)++instance MyEq p => MyEq (TaggedPatch p) where+    unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2++instance Invert p => Invert (TaggedPatch p) where+    invert = liftTP invert+    identity = TP (-1) identity++instance Commute p => Commute (TaggedPatch p) where+    commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)+                                        return (TP t2 p2' :> TP t1 p1')+    list_touched_files (TP _ p) = list_touched_files p+    merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of+                                     p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'++patch_choices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)+patch_choices = fst . patch_choices_tps++patch_choices_tps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))+patch_choices_tps ps = let tps = zipWithFL TP [1..] ps+                       in (PCs $ zipWithFL (flip PC) (repeat InMiddle) tps, tps)++make_everything_later :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)++instance MyEq p => MyEq (PatchChoice p) where+    unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2++instance Invert p => Invert (PatchChoice p) where+    invert (PC tp mf) = PC (invert tp) (invertTag mf)+    identity = PC identity InMiddle++instance Commute p => Commute (PatchChoice p) where+    commute (PC t1 x1 :> PC t2 x2)+        = do t2' :> t1' <- commute (t1 :> t2)+             return (PC t2' x2 :> PC t1' x1)+    merge (PC t1 x1 :\/: PC t2 x2)+        = case merge (t1 :\/: t2) of+          t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1+    list_touched_files (PC t _) = list_touched_files t++invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x)+invertSeq (x :> y) = (invert y :> invert x)++separate_first_from_middle_last :: Patchy p => PatchChoices p C(x z)+                                -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+separate_first_from_middle_last (PCs e) = pull_only_firsts e++separate_first_middle_from_last :: Patchy p => PatchChoices p C(x z)+                                -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+separate_first_middle_from_last (PCs e) = pull_firsts_middles e++get_choices :: Patchy p => PatchChoices p C(x y)+            -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)+get_choices (PCs e) = case pull_firsts e of+                      f :> ml -> case pull_firsts (invert ml) of+                                 l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l+  where pc2tp (PC tp _) = tp++pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+pull_firsts_middles easyPC =+    let r = unsafePerformIO+          $ newIORef (error "pull_firsts_middles called badly")+        f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)+        f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)+        f acc (PC tp InLast:>:e) = f (tp:<:acc) e+        f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of+                              more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e+        xs = f NilRL easyPC+    in (xs :> unsafePerformIO (readIORef r))++pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+pull_only_firsts easyPC =+    let r = unsafePerformIO+          $ newIORef (error "pull_only_firsts called badly")+        f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)+        f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)+        f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of+                                        more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e+        f acc (PC tp _:>:e) = f (tp:<:acc) e+        xs = f NilRL easyPC+    in (xs :> unsafePerformIO (readIORef r))++{-+pull_middles_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])+pull_middles_lasts easyPC =+    let r = unsafePerformIO+          $ newIORef (error "pull_middles_lasts called badly")+        f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []+        f acc (PC tp (Just True):e) = f (tp:acc) e+        f acc (PC (TP t p) _:e) = case commute_up_list p acc of+                                  (acc', p') -> TP t p':f acc' e+        xs = f [] easyPC+    in (xs, unsafePerformIO (readIORef r))+-}++--pull_only_lasts :: EasyPC p -> ([TaggedPatch p], [TaggedPatch p])+--pull_only_lasts easyPC =+--    let r = unsafePerformIO+--          $ newIORef (error "pull_only_lasts called badly")+--        f acc [] = unsafePerformIO (writeIORef r (reverse acc)) `seq` []+--        f acc (PC (TP t p) (Just False):e) = case commute_up_list p acc of+--                                             (acc', p') -> TP t p':f acc' e+--        f acc (PC tp _:e) = f (tp:acc) e+--        xs = f [] easyPC+--    in (xs, unsafePerformIO (readIORef r))++pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :>  FL (PatchChoice p)) C(x z)+pull_firsts e = case pull_first e of+                Nothing -> (NilFL :> e)+                Just (p:>e') -> case pull_firsts e' of+                                (ps:>e'') -> (p:>:ps :> e'')++pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y)+pull_lasts e = invertSeq $ pull_firsts $ invert e++pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z))+pull_first NilFL = Nothing+pull_first (PC tp InFirst:>:e) = Just (tp :> e)+pull_first (PC (TP t p) InLast:>:e) =+    case pull_first e of+    Just (TP t2 p2 :> e') ->+        case commute (p:>p2) of+        Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e')+        Nothing -> error "Aaack fixme!"+    Nothing -> Nothing+pull_first (PC tp@(TP t p) InMiddle:>:e) =+    case pull_first e of+    Just (TP t2 p2 :> e') ->+        case commute (p:>p2) of+        Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e'))+        Nothing -> Just (tp :> PC (TP (-t2) p2) InFirst:>:e')+    Nothing -> Nothing++patch_slot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot+patch_slot tp (PCs e) = ipf e+  where ipf :: FL (PatchChoice p) C(u v) -> Slot+        ipf (PC a mb:>:e') | tag a == tag tp = mb+                           | otherwise = ipf e'+        -- actually, the following should be impossible, but this is a reasonable answer+        ipf NilFL = InLast++set_simplys :: [Tag] -> Bool -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)+set_simplys ts b e = mapFL_FL ch e+    where ch (PC tp@(TP t _) _)+           | t `elem` ts = PC tp (if b then InFirst else InLast)+           | otherwise   = PC tp InMiddle+++m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag]+m2ids m (PC tp@(TP t _) _:>:e)+ | m tp = t:m2ids m e+ | otherwise = m2ids m e+m2ids _ NilFL = []++force_matching_first :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)+                     -> PatchChoices p C(a b) -> PatchChoices p C(a b)+force_matching_first m (PCs e) =+    let thd (PC (TP t _) _) = t+        xs = m2ids m e+        not_needed = case pull_firsts $ set_simplys xs True e of+                     _ :> rest -> mapFL thd rest+        ch pc@(PC tp@(TP t _) _)+         | t `elem` not_needed = pc+         | otherwise = PC tp InFirst+    in PCs $ mapFL_FL ch e++force_firsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+force_firsts ps pc = force_matching_first ((`elem` ps) . tag) pc++force_first :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+force_first p pc = force_matching_first ((== p) . tag) pc++select_all_middles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)+select_all_middles b (PCs e) = PCs (mapFL_FL f e)+    where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst)+          f pc = pc++reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x)+reverse_pc (PCs e) = PCs $ invert e++force_matching_last :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)+                    -> PatchChoices p C(a b) -> PatchChoices p C(a b)+force_matching_last m (PCs e) =+    let thd (PC (TP t _) _) = t+        xs = m2ids m e+        not_needed = case pull_lasts $ set_simplys xs False e of+                     rest :> _ -> mapFL thd rest+        ch pc@(PC tp@(TP t _) _)+         | t `elem` not_needed = pc+         | otherwise = PC tp InLast+    in PCs $ mapFL_FL ch e++force_last :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+force_last p pc = reverse_pc $ force_first p $ reverse_pc pc++force_lasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+force_lasts ps pc = reverse_pc $ force_firsts ps $ reverse_pc pc++make_uncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)+make_uncertain t (PCs e) = PCs $ mapFL_FL ch e+    where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc++make_everything_later (PCs e) = PCs $ mapFL_FL ch e+    where ch (PC tp InMiddle) = PC tp InLast+          ch (PC tp InFirst)  = PC tp InMiddle+          ch x = x
+ src/Darcs/Patch/Commute.lhs view
@@ -0,0 +1,879 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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.+++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators #-}++#include "gadts.h"++module Darcs.Patch.Commute ( fromPrims,+                             modernize_patch,+#ifndef GADT_WITNESSES+                             merge, elegant_merge,+                             merger, unravel,+#endif+                             public_unravel, mangle_unravelled,+                             CommuteFunction, Perhaps(..),+                             -- for other commutes:+                             toMaybe,+                           )+       where++import Control.Monad ( MonadPlus, mplus, msum, mzero )++import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )+import Darcs.Patch.Info ( invert_name, idpatchinfo )+import Darcs.Patch.Patchy ( Commute(..), Invert(..) )+import Darcs.Patch.Core ( Patch(..), Named(..),+#ifndef GADT_WITNESSES+                          flattenFL,+                          is_merger,+#endif+                          merger_undo,+                          join_patchesFL )+import Darcs.Patch.Prim ( Prim(..), FromPrims(..),+                          Conflict(..), Effect(..),+                          is_filepatch, sort_coalesceFL,+#ifndef GADT_WITNESSES+                          FilePatchType(..), DirPatchType(..),+#else+                          FilePatchType(Hunk),+#endif+                          is_hunk, modernizePrim )+import qualified Data.ByteString.Char8 as BC (pack, last)+import qualified Data.ByteString       as B (null, ByteString)+import Data.Maybe ( isJust )+import Data.List ( intersperse, sort )+#ifndef GADT_WITNESSES+import Darcs.Patch.Permutations ( head_permutationsRL, head_permutationsFL )+import Printer ( text, vcat, ($$) )+import Darcs.Patch.Patchy ( invertRL )+import Darcs.Patch.Show ( showPatch_ )+import Data.List ( nubBy )+import Darcs.Sealed ( unsafeUnseal )+#endif+import Darcs.Utils ( nubsort )+#include "impossible.h"+import Darcs.Sealed ( Sealed(..), mapSeal )+import Darcs.Ordered ( mapFL, mapFL_FL, unsafeCoerceP,+                             FL(..), RL(..),+                             (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..),+#ifndef GADT_WITNESSES+                             lengthFL, mapRL,+#endif+                             reverseFL, reverseRL, concatFL,+                             MyEq, unsafeCompare+                           )++--import Darcs.ColorPrinter ( traceDoc )+--import Printer ( greenText )+\end{code}+ +\section{Commuting patches}++\subsection{Composite patches}++Composite patches are made up of a series of patches intended to be applied+sequentially.  They are represented by a list of patches, with the first+patch in the list being applied first.++\newcommand{\commutex}{\longleftrightarrow}+\newcommand{\commutes}{\longleftrightarrow}++The first way (of only two) to change the context of a patch is by+commutation, which is the process of changing the order of two sequential+patches.+\begin{dfn}+The commutation of patches $P_1$ and $P_2$ is represented by+\[ P_2 P_1 \commutes {P_1}' {P_2}'. \]+Here $P_1'$ is intended to describe the same change as $P_1$, with the+only difference being that $P_1'$ is applied after $P_2'$ rather than+before $P_2$.+\end{dfn}+The above definition is obviously rather vague, the reason being that what+is the ``same change'' has not been defined, and we simply assume (and+hope) that the code's view of what is the ``same change'' will match those+of its human users.  The `$\commutes$' operator should be read as something+like the $==$ operator in C, indicating that the right hand side performs+identical changes to the left hand side, but the two patches are in+reversed order.  When read in this manner, it is clear that commutation+must be a reversible process, and indeed this means that commutation+\emph{can} fail, and must fail in certain cases.  For example, the creation+and deletion of the same file cannot be commuted.  When two patches fail to+commutex, it is said that the second patch depends on the first, meaning+that it must have the first patch in its context (remembering that the+context of a patch is a set of patches, which is how we represent a tree).+\footnote{The fact that commutation can fail makes a huge difference in the+whole patch formalism.  It may be possible to create a formalism in which+commutation always succeeds, with the result of what would otherwise be a+commutation that fails being something like a virtual particle (which can+violate conservation of energy), and it may be that such a formalism would+allow strict mathematical proofs (whereas those used in the current+formalism are mostly only hand waving ``physicist'' proofs).  However, I'm+not sure how you'd deal with a request to delete a file that has not yet+been created, for example.  Obviously you'd need to create some kind of+antifile, which would annihilate with the file when that file finally got+created, but I'm not entirely sure how I'd go about doing this.+$\ddot\frown$ So I'm sticking with my hand waving formalism.}++%I should add that one using the inversion relationship of sequential+%patches, one can avoid having to provide redundant definitions of+%commutation.++% There is another interesting property which is that a commutex's results+% can't be affected by commuting another thingamabopper.++\begin{code}+data Perhaps a = Unknown | Failed | Succeeded a++instance  Monad Perhaps where+    (Succeeded x) >>= k =  k x+    Failed   >>= _      =  Failed+    Unknown  >>= _      =  Unknown+    Failed   >> _       =  Failed+    (Succeeded _) >> k  =  k+    Unknown  >> k       =  k+    return              =  Succeeded+    fail _              =  Unknown++instance  MonadPlus Perhaps where+    mzero                 = Unknown+    Unknown `mplus` ys    = ys+    Failed  `mplus` _     = Failed+    (Succeeded x) `mplus` _ = Succeeded x++toMaybe :: Perhaps a -> Maybe a+toMaybe (Succeeded x) = Just x+toMaybe _ = Nothing++toPerhaps :: Maybe a -> Perhaps a+toPerhaps (Just x) = Succeeded x+toPerhaps Nothing = Failed++#ifndef GADT_WITNESSES+clever_commute :: CommuteFunction -> CommuteFunction+clever_commute c (p1:<p2) =+    case c (p1 :< p2) of+    Succeeded x -> Succeeded x+    Failed -> Failed+    Unknown -> case c (invert p2 :< invert p1) of+               Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')+               Failed -> Failed+               Unknown -> Unknown+#endif++speedy_commute :: CommuteFunction+speedy_commute (p1 :< p2) -- Deal with common case quickly!+    | p1_modifies /= Nothing && p2_modifies /= Nothing &&+      p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1)+    | otherwise = Unknown+    where p1_modifies = is_filepatch_merger p1+          p2_modifies = is_filepatch_merger p2++instance Commute p => Commute (Named p) where+    commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) =+        if n2 `elem` d1 || n1 `elem` d2+        then Nothing+        else do (p2' :> p1') <- commute (p1 :> p2)+                return (NamedP n2 d2 p2' :> NamedP n1 d1 p1')+    merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)+        = case merge (p1 :\/: p2) of+          (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'+    list_touched_files (NamedP _ _ p) = list_touched_files p++instance Conflict p => Conflict (Named p) where+    list_conflicted_files (NamedP _ _ p) = list_conflicted_files p+    resolve_conflicts (NamedP _ _ p) = resolve_conflicts p++everything_else_commute :: MaybeCommute -> CommuteFunction+everything_else_commute c x = eec x+    where+    eec :: CommuteFunction+    eec (PP px :< PP py) = toPerhaps $ do y' :< x' <- commutex (px :< py)+                                          return (PP y' :< PP x')+    eec (ComP NilFL :< p1) = Succeeded (unsafeCoerceP p1 :< (ComP NilFL))+    eec (p2 :< ComP NilFL) = Succeeded (ComP NilFL :< unsafeCoerceP p2)+    eec (ComP (p:>:ps) :< p1) = toPerhaps $ do+                              (p1' :< p') <- c (p :< p1)+                              (p1'' :< ComP ps') <- c (ComP ps :< p1')+                              return (p1'' :< ComP (p':>:ps'))+    eec (patch2 :< ComP patches) =+        toPerhaps $ do (patches' :< patch2') <- ccr (patch2 :< reverseFL patches)+                       return (ComP (reverseRL patches') :< patch2')+        where ccr :: FORALL(x y) (Patch :< RL Patch) C(x y) -> Maybe ((RL Patch :< Patch) C(x y))+              ccr (p2 :< NilRL) = seq p2 $ return (NilRL :< p2)+              ccr (p2 :< p:<:ps) = do (p' :< p2') <- c (p2 :< p)+                                      (ps' :< p2'') <- ccr (p2' :< ps)+                                      return (p':<:ps' :< p2'')+    eec _xx =+        msum [+#ifndef GADT_WITNESSES+              clever_commute commute_recursive_merger       _xx+             ,clever_commute other_commute_recursive_merger _xx+#endif+             ]++{-+Note that it must be true that++commutex (A^-1 A, P) = Just (P, A'^-1 A')++and++if commutex (A, B) == Just (B', A')+then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1)+-}++#ifndef GADT_WITNESSES+merger_commute :: (Patch :< Patch) -> Perhaps (Patch :< Patch)+merger_commute (Merger _ _ p1 p2 :< pA)+    | unsafeCompare pA p1 = Succeeded (merger "0.0" p2 p1 :< p2)+    | unsafeCompare pA (invert (merger "0.0" p2 p1)) = Failed+merger_commute (Merger _ _+                (Merger _ _ c b)+                (Merger _ _ c' a) :<+                Merger _ _ b' c'')+    | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' =+        Succeeded (merger "0.0" (merger "0.0" b a) (merger "0.0" b c) :<+                   merger "0.0" b a)+merger_commute _ = Unknown+#endif++instance Commute Patch where+    merge (y :\/: z) =+#ifndef GADT_WITNESSES+        case actual_merge (y:\/:z) of+        y' -> case commutex (y' :< z) of+                         Nothing -> bugDoc $ text "merge_patches bug"+                                    $$ showPatch_ y+                                   $$ showPatch_ z+                                   $$ showPatch_ y'+                         Just (z' :< _) -> z' :/\: y'+#else+        case elegant_merge (y:\/:z) of+        Just (z' :/\: y') -> z' :/\: y'+        Nothing -> undefined+#endif+    commutex x = toMaybe $ msum [speedy_commute x,+#ifndef GADT_WITNESSES+                                 clever_commute merger_commute x,+#endif+                                 everything_else_commute commutex x+                        ]+    -- Recurse on everything, these are potentially spoofed patches+    list_touched_files (ComP ps) = nubsort $ concat $ mapFL list_touched_files ps+    list_touched_files (Merger _ _ p1 p2) = nubsort $ list_touched_files p1+                                            ++ list_touched_files p2+    list_touched_files c@(Regrem _ _ _ _) = list_touched_files $ invert c+    list_touched_files (PP p) = list_touched_files p++commute_no_merger :: MaybeCommute+commute_no_merger x =+#ifndef GADT_WITNESSES+    toMaybe $ msum [speedy_commute x,+                    everything_else_commute commute_no_merger x]+#else+    bug "commute_no_merger undefined when compiled with GADTs" x+#endif++is_filepatch_merger :: Patch C(x y) -> Maybe FileName+is_filepatch_merger (PP p) = is_filepatch p+is_filepatch_merger (Merger _ _ p1 p2) = do+     f1 <- is_filepatch_merger p1+     f2 <- is_filepatch_merger p2+     if f1 == f2 then return f1 else Nothing+is_filepatch_merger (Regrem und unw p1 p2)+    = is_filepatch_merger (Merger und unw p1 p2)+is_filepatch_merger (ComP _) = Nothing++#ifndef GADT_WITNESSES+commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch)+commute_recursive_merger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $+  do (pA' :< _) <- commutex (undo :< pA)+     commutex (invert undo :< pA')+     (pAmid :< _) <- commutex (invert p1 :< pA)+     (pAx :< p1') <- commutex (p1 :< pAmid)+     assert (pAx `unsafeCompare` pA)+     (_ :<p2') <- commutex (p2 :< pAmid)+     (_ :< p2o) <- commutex (p2' :< invert pAmid)+     assert (p2o `unsafeCompare` p2)+     let p' = if unsafeCompare p1' p1 && unsafeCompare p2' p2+              then p+              else merger "0.0" p1' p2'+         undo' = merger_undo p'+     (_ :< pAo) <- commutex (pA' :< undo')+     assert (pAo `unsafeCompare` pA)+     return (pA' :< p')+    where undo = merger_undo p+commute_recursive_merger _ = Unknown++other_commute_recursive_merger :: (Patch :< Patch) -> Perhaps (Patch :< Patch)+other_commute_recursive_merger (pA':< p_old@(Merger _ _ p1' p2')) =+  toPerhaps $+  do (_ :< pA) <- commutex (pA' :< merger_undo p_old)+     (p1 :< pAmid) <- commutex (pA :< p1')+     (pAmido :< _) <- commutex (invert p1 :< pA)+     assert (pAmido `unsafeCompare` pAmid)+     (_ :< p2) <- commutex (p2' :< invert pAmid)+     (_ :< p2o') <- commutex (p2 :< pAmid)+     assert (p2o' `unsafeCompare` p2')+     let p = if p1 `unsafeCompare` p1' && p2 `unsafeCompare` p2'+             then p_old+             else merger "0.0" p1 p2+         undo = merger_undo p+     assert (not $ pA `unsafeCompare` p1) -- special case here...+     (pAo' :< _) <- commutex (undo :<pA)+     assert (pAo' `unsafeCompare` pA')+     return (p :< pA)+other_commute_recursive_merger _ = Unknown++assert :: Bool -> Maybe ()+assert False = Nothing+assert True = Just ()+#endif++type CommuteFunction = FORALL(x y) (Patch :< Patch) C(x y) -> Perhaps ((Patch :< Patch) C(x y))+type MaybeCommute = FORALL(x y) (Patch :< Patch) C(x y) -> Maybe ((Patch :< Patch) C(x y))+\end{code}++\paragraph{Merge}+\newcommand{\merge}{\Longrightarrow}+The second way one can change the context of a patch is by a {\bf merge}+operation.  A merge is an operation that takes two parallel patches and+gives a pair of sequential patches.  The merge operation is represented by+the arrow ``\( \merge \)''.+\begin{dfn}\label{merge_dfn}+The result of a merge of two patches, $P_1$ and $P_2$ is one of two patches,+$P_1'$ and $P_2'$, which satisfy the relationship:+\[  P_2 \parallel P_1 \merge {P_2}' P_1 \commutex {P_1}' P_2. \]+\end{dfn}+Note that the sequential patches resulting from a merge are \emph{required}+to commutex.  This is an important consideration, as without it most of the+manipulations we would like to perform would not be possible.  The other+important fact is that a merge \emph{cannot fail}.  Naively, those two+requirements seem contradictory.  In reality, what it means is that the+result of a merge may be a patch which is much more complex than any we+have yet considered\footnote{Alas, I don't know how to prove that the two+constraints even \emph{can} be satisfied.  The best I have been able to do+is to believe that they can be satisfied, and to be unable to find an case+in which my implementation fails to satisfy them.  These two requirements+are the foundation of the entire theory of patches (have you been counting+how many foundations it has?).}.++\subsection{How merges are actually performed}++The constraint that any two compatible patches (patches which can+successfully be applied to the same tree) can be merged is actually quite+difficult to apply.  The above merge constraints also imply that the result+of a series of merges must be independent of the order of the merges.  So+I'm putting a whole section here for the interested to see what algorithms+I use to actually perform the merges (as this is pretty close to being the+most difficult part of the code).++The first case is that in which the two merges don't actually conflict, but+don't trivially merge either (e.g.\ hunk patches on the same file, where the+line number has to be shifted as they are merged).  This kind of merge can+actually be very elegantly dealt with using only commutation and inversion.++There is a handy little theorem which is immensely useful when trying to+merge two patches.+\begin{thm}\label{merge_thm}+$ P_2' P_1 \commutex P_1' P_2 $ if and only if $ P_1'^{ -1}+P_2' \commutex P_2 P_1^{ -1} $, provided both commutations succeed.  If+either commutex fails, this theorem does not apply.+\end{thm}+This can easily be proven by multiplying both sides of the first+commutation by $P_1'^{ -1}$ on the left, and by $P_1^{ -1}$ on the right.+Besides being used in merging, this theorem is also useful in the recursive+commutations of mergers.  From Theorem~\ref{merge_thm}, we see that the+merge of $P_1$ and $P_2'$ is simply the commutation of $P_2$ with $P_1^{+-1}$ (making sure to do the commutation the right way).  Of course, if this+commutation fails, the patches conflict.  Moreover, one must check that the+merged result actually commutes with $P_1$, as the theorem applies only+when \emph{both} commutations are successful.++\begin{code}++elegant_merge :: (Patch :\/: Patch) C(x y)+              -> Maybe ((Patch :/\: Patch) C(x y))+elegant_merge (p1 :\/: p2) =+  case commutex (p1 :< invert p2) of+  Just (ip2':<p1') -> case commutex (p1' :< p2) of+                      Nothing -> Nothing -- should be a redundant check+                      Just (_:<p1o) -> if unsafeCompare p1o p1+                                       then Just (invert ip2' :/\: p1')+                                       else Nothing+  Nothing -> Nothing++\end{code}++Of course, there are patches that actually conflict, meaning a merge where+the two patches truly cannot both be applied (e.g.\ trying to create a file+and a directory with the same name).  We deal with this case by creating a+special kind of patch to support the merge, which we will call a+``merger''.  Basically, a merger is a patch that contains the two patches+that conflicted, and instructs darcs basically to resolve the conflict.  By+construction a merger will satisfy the commutation property (see+Definition~\ref{merge_dfn}) that characterizes all merges.  Moreover the+merger's properties are what makes the order of merges unimportant (which+is a rather critical property for darcs as a whole).++The job of a merger is basically to undo the two conflicting patches, and+then apply some sort of a ``resolution'' of the two instead.  In the case+of two conflicting hunks, this will look much like what CVS does, where it+inserts both versions into the file.  In general, of course, the two+conflicting patches may both be mergers themselves, in which case the+situation is considerably more complicated.++\begin{code}+#ifndef GADT_WITNESSES+actual_merge :: (Patch :\/: Patch) -> Patch+actual_merge (ComP the_p1s :\/: ComP the_p2s) =+    join_patchesFL $ mc the_p1s the_p2s+    where mc :: FL Patch -> FL Patch -> FL Patch+          mc NilFL (_:>:_) = NilFL+          mc p1s NilFL = p1s+          mc p1s (p2:>:p2s) = mc (merge_patches_after_patch p1s p2) p2s+actual_merge (ComP p1s :\/: p2) = seq p2 $+                              join_patchesFL $ merge_patches_after_patch p1s p2+actual_merge (p1 :\/: ComP p2s) = seq p1 $ merge_patch_after_patches p1 p2s++actual_merge (p1 :\/: p2) = case elegant_merge (p1:\/:p2) of+                            Just (_ :/\: p1') -> p1'+                            Nothing -> merger "0.0" p2 p1++merge_patch_after_patches :: Patch -> FL Patch -> Patch+merge_patch_after_patches p (p1:>:p1s) =+    merge_patch_after_patches (actual_merge (p:\/:p1)) p1s+merge_patch_after_patches p NilFL = p++merge_patches_after_patch :: FL Patch -> Patch -> FL Patch+merge_patches_after_patch p2s p =+    case commutex (merge_patch_after_patches p p2s :< join_patchesFL p2s) of+    Just (ComP p2s':< _) -> p2s'+    _ -> impossible+#endif+\end{code}++Much of the merger code depends on a routine which recreates from a single+merger the entire sequence of patches which led up to that merger (this is,+of course, assuming that this is the complicated general case of a merger+of mergers of mergers).  This ``unwind'' procedure is rather complicated,+but absolutely critical to the merger code, as without it we wouldn't even+be able to undo the effects of the patches involved in the merger, since we+wouldn't know what patches were all involved in it.++Basically, unwind takes a merger such as+\begin{verbatim}+M( M(A,B), M(A,M(C,D)))+\end{verbatim}+From which it recreates a merge history:+\begin{verbatim}+C+A+M(A,B)+M( M(A,B), M(A,M(C,D)))+\end{verbatim}+(For the curious, yes I can easily unwind this merger in my head [and on+paper can unwind insanely more complex mergers]---that's what comes of+working for a few months on an algorithm.)  Let's start with a simple+unwinding.  The merger \verb!M(A,B)! simply means that two patches+(\verb!A! and \verb!B!) conflicted, and of the two of them \verb!A! is+first in the history.  The last two patches in the unwinding of any merger+are always just this easy.  So this unwinds to:+\begin{verbatim}+A+M(A,B)+\end{verbatim}+What about a merger of mergers? How about \verb!M(A,M(C,D))!.  In this case+we know the two most recent patches are:+\begin{verbatim}+A+M(A,M(C,D))+\end{verbatim}+But obviously the unwinding isn't complete, since we don't yet see where+\verb!C! and \verb!D! came from.  In this case we take the unwinding of+\verb!M(C,D)! and drop its latest patch (which is \verb!M(C,D)! itself) and+place that at the beginning of our patch train:+\begin{verbatim}+C+A+M(A,M(C,D))+\end{verbatim}+As we look at \verb!M( M(A,B), M(A,M(C,D)))!, we consider the unwindings of+each of its subpatches:+\begin{verbatim}+          C+A         A+M(A,B)    M(A,M(C,D))+\end{verbatim}+As we did with \verb!M(A,M(C,D))!, we'll drop the first patch on the+right and insert the first patch on the left.  That moves us up to the two+\verb!A!'s.  Since these agree, we can use just one of them (they+``should'' agree).  That leaves us with the \verb!C! which goes first.++The catch is that things don't always turn out this easily.  There is no+guarantee that the two \verb!A!'s would come out at the same time, and if+they didn't, we'd have to rearrange things until they did.  Or if there was+no way to rearrange things so that they would agree, we have to go on to+plan B, which I will explain now.++Consider the case of \verb!M( M(A,B), M(C,D))!.  We can easily unwind the+two subpatches+\begin{verbatim}+A         C+M(A,B)    M(C,D)+\end{verbatim}+Now we need to reconcile the \verb!A! and \verb!C!.  How do we do this?+Well, as usual, the solution is to use the most wonderful+Theorem~\ref{merge_thm}.  In this case we have to use it in the reverse of+how we used it when merging, since we know that \verb!A! and \verb!C! could+either one be the \emph{last} patch applied before \verb!M(A,B)! or+\verb!M(C,D)!.  So we can find \verb!C'! using+\[+A^{ -1} C \commutex C' A'^{ -1}+\]+Giving an unwinding of+\begin{verbatim}+C'+A+M(A,B)+M( M(A,B), M(C,D) )+\end{verbatim}+There is a bit more complexity to the unwinding process (mostly having to+do with cases where you have deeper nesting), but I think the general+principles that are followed are pretty much included in the above+discussion.++\begin{code}+#ifndef GADT_WITNESSES+unwind :: Patch -> RL Patch -- Recreates a patch history in reverse.+unwind (Merger _ unwindings _ _) = unwindings+unwind p = p :<: NilRL;++true_unwind :: Patch -> RL Patch -- Recreates a patch history in reverse.+true_unwind p@(Merger _ _ p1 p2) =+    case (unwind p1, unwind p2) of+    (_:<:p1s,_:<:p2s) -> p :<: p1 :<: reconcile_unwindings p p1s p2s+    _ -> impossible+true_unwind _ = impossible++reconcile_unwindings :: Patch -> RL Patch -> RL Patch -> RL Patch+reconcile_unwindings _ NilRL p2s = p2s+reconcile_unwindings _ p1s NilRL = p1s+reconcile_unwindings p (p1:<:p1s) p2s =+    case [(p1s', p2s')|+          p1s'@(hp1s':<:_) <- head_permutationsRL (p1:<:p1s),+          p2s'@(hp2s':<:_) <- head_permutationsRL p2s,+          hp1s' `unsafeCompare` hp2s'] of+    ((p1':<:p1s', _:<:p2s'):_) ->+        p1' :<: reconcile_unwindings p p1s' p2s'+    [] -> case reverseFL `fmap` put_before p1 (reverseRL p2s) of+          Just p2s' -> p1 :<: reconcile_unwindings p p1s p2s'+          Nothing ->+              case fmap reverseFL $ put_before (headRL p2s) $+                   reverseRL (p1:<:p1s) of+              Just p1s' -> case p2s of+                           hp2s:<:tp2s -> hp2s :<:+                                          reconcile_unwindings p p1s' tp2s+                           NilRL -> impossible+              Nothing ->+                  bugDoc $ text "in function reconcile_unwindings"+                        $$ text "Original patch:"+                        $$ showPatch_ p+    _ -> bug "in reconcile_unwindings"++put_before :: Patch -> FL Patch -> Maybe (FL Patch)+put_before p1 (p2:>:p2s) =+    do p2':<p1' <- commutex (invert p1:<p2)+       commutex (p1:<p2')+       (p2' :>:) `fmap` put_before p1' p2s+put_before _ NilFL = Just NilFL+#endif+\end{code}+ +\section{Conflicts}++There are a couple of simple constraints on the routine which determines+how to resolve two conflicting patches (which is called `glump').  These+must be satisfied in order that the result of a series of merges is always+independent of their order.  Firstly, the output of glump cannot change+when the order of the two conflicting patches is switched.  If it did, then+commuting the merger could change the resulting patch, which would be bad.+Secondly, the result of the merge of three (or more) conflicting patches+cannot depend on the order in which the merges are performed.++The conflict resolution code (glump) begins by ``unravelling'' the merger+into a set of sequences of patches.  Each sequence of patches corresponds+to one non-conflicted patch that got merged together with the others.  The+result of the unravelling of a series of merges must obviously be+independent of the order in which those merges are performed.  This+unravelling code (which uses the unwind code mentioned above) uses probably+the second most complicated algorithm.  Fortunately, if we can successfully+unravel the merger, almost any function of the unravelled merger satisfies+the two constraints mentioned above that the conflict resolution code must+satisfy.++\begin{code}+instance Conflict Patch where+  commute_no_conflicts (x:>y) = do x' :< y' <- commute_no_merger (y :< x)+                                   return (y':>x')+#ifndef GADT_WITNESSES+  resolve_conflicts patch = rcs NilFL $ reverseFL $ flattenFL patch+    where rcs :: FL Patch C(w y) -> RL Patch C(x y) -> [[Sealed (FL Prim C(w))]]+          rcs _ NilRL = []+          rcs passedby (p@(Merger _ _ _ _):<:ps) =+              case commute_no_merger (join_patchesFL passedby:<p) of+              Just (p'@(Merger _ _ p1 p2):<_) ->+                  (map Sealed $ nubBy unsafeCompare $ effect (glump09 p1 p2) : unravel p')+                  : rcs (p :>: passedby) ps+              Nothing -> rcs (p :>: passedby) ps+              _ -> impossible+          rcs passedby (p:<:ps) = seq passedby $+                                  rcs (p :>: passedby) ps+#else+  resolve_conflicts = bug "haven't defined resolve_conflicts with type witnesses."+#endif++public_unravel :: Patch C(x y) -> [Sealed (FL Prim C(y))]+#ifdef GADT_WITNESSES+public_unravel = bug "Haven't implemented public_unravel with type witnesses."+#else+public_unravel p = map Sealed $ unravel p+#endif++#ifndef GADT_WITNESSES+unravel :: Patch -> [FL Prim]+unravel p = nubBy unsafeCompare $+            map (sort_coalesceFL . concatFL . mapFL_FL effect) $+            get_supers $ map reverseRL $ new_ur p $ unwind p++get_supers :: [FL Patch] -> [FL Patch]+get_supers (x:xs) =+    case filter (not.(x `is_superpatch_of`)) xs of+    xs' -> if or $ map (`is_superpatch_of` x) xs'+           then get_supers xs'+           else x : get_supers xs'+get_supers [] = []+is_superpatch_of :: FL Patch -> FL Patch -> Bool+x `is_superpatch_of` y | lengthFL y > lengthFL x = False+x `is_superpatch_of` y = x `iso` y+    where iso :: FL Patch -> FL Patch -> Bool+          _ `iso` NilFL = True+          NilFL `iso` _ = False+          a `iso` (b:>:bs) =+              case filter ((`unsafeCompare` b) . headFL) $+                   head_permutationsFL a of+              ((_:>:as):_) -> as `iso` bs+              [] -> False+              _ -> bug "bug in is_superpatch_of"++headFL :: FL a -> a+headFL (x:>:_) = x+headFL NilFL = bug "bad headFL"++merger :: String -> Patch -> Patch -> Patch+merger "0.0" p1 p2 = Merger undoit unwindings p1 p2+    where fake_p = Merger identity NilRL p1 p2+          unwindings = true_unwind fake_p+          p = Merger identity unwindings p1 p2+          undoit =+              case (is_merger p1, is_merger p2) of+              (True ,True ) -> join_patchesFL $ invertRL $ tailRL $ unwind p+                               where tailRL (_:<:t) = t+                                     tailRL _ = impossible+              (False,False) -> invert p1+              (True ,False) -> join_patchesFL NilFL+              (False,True ) -> join_patchesFL (invert p1 :>: merger_undo p2 :>: NilFL)+merger g _ _ =+    error $ "Cannot handle mergers other than version 0.0\n"++g+    ++ "\nPlease use darcs optimize --modernize with an older darcs."++glump09 :: Patch -> Patch -> Patch+glump09 p1 p2 = fromPrims $ unsafeUnseal $ mangle_unravelled $ map Sealed $ unravel $ merger "0.0" p1 p2++#endif++mangle_unravelled :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x))+mangle_unravelled pss = if only_hunks pss+                        then (:>: NilFL) `mapSeal` mangle_unravelled_hunks pss+                        else head pss++only_hunks :: [Sealed (FL Prim C(x))] -> Bool+only_hunks [] = False+only_hunks pss = fn2fp f /= "" && all oh pss+    where f = get_a_filename pss+          oh :: Sealed (FL Prim C(x)) -> Bool+          oh (Sealed (p:>:ps)) = is_hunk p &&+                                 [fn2fp f] == list_touched_files p &&+                                 oh (Sealed ps)+          oh (Sealed NilFL) = True++apply_hunks :: [Maybe B.ByteString] -> FL Prim C(x y) -> [Maybe B.ByteString]+apply_hunks ms (FP _ (Hunk l o n):>:ps) = apply_hunks (rls l ms) ps+    where rls 1 mls = map Just n ++ drop (length o) mls+          rls i (ml:mls) = ml : rls (i-1) mls+          rls _ [] = bug "rls in apply_hunks"+apply_hunks ms NilFL = ms+apply_hunks _ (_:>:_) = impossible++get_old :: [Maybe B.ByteString] -> [Sealed (FL Prim C(x))] -> [Maybe B.ByteString]+get_old mls (ps:pss) = get_old (get_hunks_old mls ps) pss+get_old mls [] = mls++get_a_filename :: [Sealed (FL Prim C(x))] -> FileName+get_a_filename ((Sealed (FP f _:>:_)):_) = f+get_a_filename _ = fp2fn ""++get_hunks_old :: [Maybe B.ByteString] -> Sealed (FL Prim C(x))+              -> [Maybe B.ByteString]+get_hunks_old mls (Sealed ps) =+    apply_hunks (apply_hunks mls ps) (invert ps)++get_hunks_new :: [Maybe B.ByteString] -> Sealed (FL Prim C(x))+              -> [Maybe B.ByteString]+get_hunks_new mls (Sealed ps) = apply_hunks mls ps++get_hunkline :: [[Maybe B.ByteString]] -> Int+get_hunkline = ghl 1+    where ghl :: Int -> [[Maybe B.ByteString]] -> Int+          ghl n pps =+            if any (isJust . head) pps+            then n+            else ghl (n+1) $ map tail pps++make_chunk :: Int -> [Maybe B.ByteString] -> [B.ByteString]+make_chunk n mls = pull_chunk $ drop (n-1) mls+    where pull_chunk (Just l:mls') = l : pull_chunk mls'+          pull_chunk (Nothing:_) = []+          pull_chunk [] = bug "should this be [] in pull_chunk?"++mangle_unravelled_hunks :: [Sealed (FL Prim C(x))] -> Sealed (Prim C(x))+--mangle_unravelled_hunks [[h1],[h2]] = Deal with simple cases handily?+mangle_unravelled_hunks pss =+        if null nchs then bug "mangle_unravelled_hunks"+                     else Sealed (FP filename (Hunk l old new))+    where oldf = get_old (repeat Nothing) pss+          newfs = map (get_hunks_new oldf) pss+          l = get_hunkline $ oldf : newfs+          nchs = sort $ map (make_chunk l) newfs+          filename = get_a_filename pss+          old = make_chunk l oldf+          new = [top] ++ concat (intersperse [middle] nchs) ++ [bottom]+          top    = BC.pack $ "v v v v v v v" ++ eol_c+          middle = BC.pack $ "*************" ++ eol_c+          bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c+          eol_c  = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old+                   then "\r"+                   else ""++instance Effect Patch where+    effect p@(Merger _ _ _ _) = sort_coalesceFL $ effect $ merger_undo p+    effect p@(Regrem _ _ _ _) = invert $ effect $ invert p+    effect (ComP ps) = concatFL $ mapFL_FL effect ps+    effect (PP p) = effect p+    isHunk p = do PP p' <- return p+                  isHunk p'++modernize_patch :: Patch C(x y) -> Patch C(x y)+modernize_patch p@(Merger _ _ _ _) = fromPrims $ effect p+modernize_patch p@(Regrem _ _ _ _) = fromPrims $ effect p+modernize_patch (ComP ps) = ComP $ filtermv $ mapFL_FL modernize_patch ps+    where filtermv :: FL Patch C(x y) -> FL Patch C(x y)+#ifndef GADT_WITNESSES+          filtermv (PP (Move _ b):>:xs) | hasadd xs = filtermv xs+              where hasadd (PP (FP b' AddFile):>:_) | b' == b = True+                    hasadd (PP (DP b' AddDir):>:_) | b' == b = True+                    hasadd (PP (FP b' RmFile):>:_) | b' == b = False+                    hasadd (PP (DP b' RmDir):>:_) | b' == b = False+                    hasadd (_:>:z) = hasadd z+                    hasadd NilFL = False+#endif+          filtermv (x:>:xs) = x :>: filtermv xs+          filtermv NilFL = NilFL++modernize_patch (PP p) = fromPrims $ modernizePrim p++instance FromPrims Patch where+    fromPrims (p :>: NilFL) = PP p+    fromPrims ps = join_patchesFL $ mapFL_FL PP ps+    joinPatches = join_patchesFL++#ifndef GADT_WITNESSES+new_ur :: Patch -> RL Patch -> [RL Patch]+new_ur p (Merger _ _ p1 p2 :<: ps) =+   case filter ((`unsafeCompare` p1) . headRL) $ head_permutationsRL ps of+   ((_:<:ps'):_) -> new_ur p (p1:<:ps') ++ new_ur p (p2:<:ps')+   _ -> bugDoc $ text "in function new_ur"+              $$ text "Original patch:"+              $$ showPatch_ p+              $$ text "Unwound:"+              $$ vcat (mapRL showPatch_ $ unwind p)++new_ur op ps =+    case filter (is_merger.headRL) $ head_permutationsRL ps of+    [] -> [ps]+    (ps':_) -> new_ur op ps'++headRL :: RL a -> a+headRL (x:<:_) = x+headRL _ = bug "bad headRL"+#endif++instance Invert p => Invert (Named p) where+    invert (NamedP n d p)  = NamedP (invert_name n) (map invert_name d) (invert p)+    identity = NamedP idpatchinfo [] identity++instance Invert Patch where+    invert (Merger undo unwindings p1 p2)+        = Regrem undo unwindings p1 p2+    invert (Regrem undo unwindings p1 p2)+        = Merger undo unwindings p1 p2+    invert (PP p) = PP (invert p)+    invert (ComP ps)  = ComP $ invert ps+    identity = ComP NilFL++instance MyEq Patch where+    unsafeCompare = eq_patches+instance MyEq p => MyEq (Named p) where+    unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) =+        n1 == n2 && d1 == d2 && unsafeCompare p1 p2++eq_patches :: Patch C(x y) -> Patch C(w z) -> Bool+eq_patches (PP p1) (PP p2) = unsafeCompare p1 p2+eq_patches (ComP ps1) (ComP ps2)+ = eq_FL eq_patches ps1 ps2+eq_patches (ComP NilFL) (PP Identity) = True+eq_patches (PP Identity) (ComP NilFL) = True+eq_patches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b)+ = eq_patches p1a p2a &&+   eq_patches p1b p2b+eq_patches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b)+ = eq_patches p1a p2a &&+   eq_patches p1b p2b+eq_patches _ _ = False++eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool)+      -> FL a C(x y) -> FL a C(w z) -> Bool+eq_FL _ NilFL NilFL = True+eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys+eq_FL _ _ _ = False++\end{code}
+ src/Darcs/Patch/Core.lhs view
@@ -0,0 +1,173 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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.+++\section{Patch relationships}++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , GADTs, PatternGuards #-}++#include "gadts.h"++module Darcs.Patch.Core+       ( Patch(..), Named(..),+         join_patchesFL, concatFL, flattenFL,+         nullP, is_null_patch, infopatch,+         n_fn,+         adddeps, namepatch, anonymous,+         merger_undo, is_merger,+         getdeps,+         patch2patchinfo, patchname, patchcontents,+       )+       where++import Prelude hiding ( pi )+import Darcs.Patch.Info ( PatchInfo, patchinfo, make_filename )+import Darcs.Patch.Patchy ( Patchy )+import Darcs.Ordered+import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), n_fn )+#include "impossible.h"++data Patch C(x y) where+    PP :: Prim C(x y) -> Patch C(x y)+    ComP :: FL Patch C(x y) -> Patch C(x y)+    Merger :: Patch C(x y)+           -> RL Patch C(x b)+           -> Patch C(c b)+           -> Patch C(c d)+           -> Patch C(x y)+    Regrem :: Patch C(x y)+           -> RL Patch C(x b)+           -> Patch C(c b)+           -> Patch C(c a)+           -> Patch C(y x)++instance FromPrim Patch where+    fromPrim = PP++data Named p C(x y) where+    NamedP :: !PatchInfo -> ![PatchInfo] -> !(p C(x y)) -> Named p C(x y)++instance Effect p => Effect (Named p) where+    effect (NamedP _ _ p) = effect p+    effectRL (NamedP _ _ p) = effectRL p++is_null_patch :: Patch C(x y) -> Bool+is_null_patch (ComP ps) = and $ mapFL is_null_patch ps+is_null_patch _ = False++nullP :: Patch C(x y) -> EqCheck C(x y)+nullP (ComP NilFL) = IsEq+nullP (ComP (x:>:xs)) | IsEq <- nullP x = nullP (ComP xs)+nullP _ = NotEq++is_merger :: Patch C(a b) -> Bool+is_merger (Merger _ _ _ _) = True+is_merger (Regrem _ _ _ _) = True+is_merger _ = False++merger_undo :: Patch C(x y) -> Patch C(x y)+merger_undo (Merger undo _ _ _) = undo+merger_undo _ = impossible+\end{code}++%Another nice thing to be able to do with composite patches is to `flatten'+%them, that is, turn them into a simple list of patches (appropriately+%ordered, of course), with all nested compositeness unnested.++\begin{code}+{- INLINE flattenFL -}+flattenFL :: Patch C(x y) -> FL Patch C(x y)+flattenFL (ComP ps) = concatFL (mapFL_FL flattenFL ps)+flattenFL (PP Identity) = NilFL+flattenFL p = p :>: NilFL++join_patchesFL :: FL Patch C(x y) -> Patch C(x y)+join_patchesFL ps = ComP $! ps++infopatch :: Patchy p => PatchInfo -> p C(x y) -> Named p C(x y)+adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y)+getdeps :: Named p C(x y) -> [PatchInfo]++namepatch :: Patchy p => String -> String -> String -> [String] -> p C(x y) -> IO (Named p C(x y))+namepatch date name author desc p+    | '\n' `elem` name = error "Patch names cannot contain newlines."+    | otherwise = do pinf <- patchinfo date name author desc+                     return $ NamedP pinf [] p++anonymous :: Patchy p => p C(x y) -> IO (Named p C(x y))+anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p++infopatch pi p = NamedP pi [] p+adddeps (NamedP pi _ p) ds = NamedP pi ds p+getdeps (NamedP _ ds _) = ds++patch2patchinfo :: Named p C(x y) -> PatchInfo+patch2patchinfo (NamedP i _ _) = i++patchname :: Named p C(x y) -> String+patchname (NamedP i _ _) = make_filename i++patchcontents :: Named p C(x y) -> p C(x y)+patchcontents (NamedP _ _ p) = p+\end{code}++The simplest relationship between two patches is that of ``sequential''+patches, which means that the context of the second patch (the one on the+left) consists of the first patch (on the right) plus the context of the+first patch.  The composition of two patches (which is also a patch) refers+to the patch which is formed by first applying one and then the other.  The+composition of two patches, $P_1$ and $P_2$ is represented as $P_2P_1$,+where $P_1$ is to be applied first, then $P_2$\footnote{This notation is+inspired by the notation of matrix multiplication or the application of+operators upon a Hilbert space.  In the algebra of patches, there is+multiplication (i.e.\ composition), which is associative but not+commutative, but no addition or subtraction.}++There is one other very useful relationship that two patches can have,+which is to be parallel patches, which means that the two patches have an+identical context (i.e.\ their representation applies to identical trees).+This is represented by $P_1\parallel P_2$.  Of course, two patches may also+have no simple relationship to one another.  In that case, if you want to+do something with them, you'll have to manipulate them with respect to+other patches until they are either in sequence or in parallel.++The most fundamental and simple property of patches is that they must be+invertible.  The inverse of a patch is described by: $P^{ -1}$.  In the+darcs implementation, the inverse is required to be computable from+knowledge of the patch only, without knowledge of its context, but that+(although convenient) is not required by the theory of patches.+\begin{dfn}+The inverse of patch $P$ is $P^{ -1}$, which is the ``simplest'' patch for+which the composition \( P^{ -1} P \) makes no changes to the tree.+\end{dfn}+Using this definition, it is trivial to prove the following theorem+relating to the inverse of a composition of two patches.+\begin{thm} The inverse of the composition of two patches is+\[ (P_2 P_1)^{ -1} = P_1^{ -1} P_2^{ -1}. \]+\end{thm}+Moreover, it is possible to show that the right inverse of a patch is equal+to its left inverse.  In this respect, patches continue to be analogous to+square matrices, and indeed the proofs relating to these properties of the+inverse are entirely analogous to the proofs in the case of matrix+multiplication.  The compositions proofs can also readily be extended to+the composition of more than two patches.+\begin{code}++\end{code}
+ src/Darcs/Patch/Depends.hs view
@@ -0,0 +1,498 @@+-- Copyright (C) 2003-2004 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , ScopedTypeVariables, TypeOperators #-}++#include "gadts.h"++module Darcs.Patch.Depends ( get_common_and_uncommon, get_tags_right,+                 get_common_and_uncommon_or_missing,+                 optimize_patchset, deep_optimize_patchset,+                 slightly_optimize_patchset,+                 get_patches_beyond_tag, get_patches_in_tag,+                 patchset_union, patchset_intersection,+                 commute_to_end,+               ) where+import Data.List ( delete, intersect )+import Control.Monad ( liftM2 )+import Control.Monad.Error ( Error(..) )++import Darcs.Patch ( RepoPatch, Named, getdeps, commutex,+                     commuteFL,+                     patch2patchinfo, merge )+import Darcs.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..),+                             RL(..), FL(..),+                             (+<+),+                             reverseFL, mapFL_FL, mapFL, concatReverseFL,+                             lengthRL, concatRL, reverseRL, mapRL,+                             unsafeCoerceP, EqCheck(..) )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.Info ( PatchInfo, human_friendly, is_tag )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.Patchy ( sloppyIdentity )+import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia,+                         hopefully, conscientiously, hopefullyM )+import Darcs.ProgressPatches ( progressRL )+import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..)+                    , flipSeal, seal, unseal )+import Printer ( errorDoc, renderString, ($$), text )+#include "impossible.h"++get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->+                           ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->+                                      Either PatchInfo ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))++get_common_and_uncommon = +    either missingPatchError id . get_common_and_uncommon_err++get_common_and_uncommon_or_missing = +    either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err++get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->+                               Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2++{-|+with_partial_intersection takes two 'PatchSet's and splits them into a /common/+intersection portion and two sets of patches.  The intersection, however,+is only lazily determined, so there is no guarantee that all intersecting+patches will be included in the intersection 'PatchSet'.  This is a pretty+efficient function, because it makes use of the already-broken-up nature of+'PatchSet's.++'PatchSet's have the property that if+@+(info $ last $ head a) == (info $ last $ head b)+@+then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take+advantage of this if possible, to avoid reading too many inventories.  In+the case of --partial repositories or patch bundles, it is crucial that we+don't need to read the whole history, since it isn't available.++TODO:++The length equalising isn't necessarily right. We probably also be+thinking about not going past the end of a partial repository, or favour+local repository stuff over remote repository stuff.++Also, when comparing l1 to l2, we should really be comparing the+newly discovered one to /all/ the lasts in the other patch set+that we've got so far.+-}+with_partial_intersection :: forall a p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)+                          -> (FORALL(z) PatchSet p C(z) -> RL (PatchInfoAnd p) C(z x)+                                                        -> RL (PatchInfoAnd p) C(z y) -> a)+                          -> a+with_partial_intersection NilRL ps2 j = j (NilRL:<:NilRL) NilRL (concatRL ps2)+with_partial_intersection ps1 NilRL j = j (NilRL:<:NilRL) (concatRL ps1) NilRL+with_partial_intersection (NilRL:<:ps1) ps2 j =+    with_partial_intersection ps1 ps2 j+with_partial_intersection ps1 (NilRL:<:ps2) j =+    with_partial_intersection ps1 ps2 j+-- NOTE: symmetry is broken here, so we want the PatchSet with more history+-- first!+with_partial_intersection ((pi1:<:NilRL):<:common) ((pi2:<:NilRL):<:_) j+-- NOTE: Since the patchsets have the same starting but different ending+-- we can coerce them.  The type system is not aware of our invariant on tags,+-- but both pi1 and pi2 should be tags, thus we check they are both identity+-- patches.+    | info pi1 == info pi2+    , IsEq <- sloppyIdentity pi1+    , IsEq <- sloppyIdentity pi2 = j common NilRL (unsafeCoerceP NilRL)+with_partial_intersection (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) j+ = f (lengthRL orig_ps1) (last $ mapRL info orig_ps1) (orig_ps1:>:NilFL) orig_ps1s+     (lengthRL orig_ps2) (last $ mapRL info orig_ps2) (orig_ps2:>:NilFL) orig_ps2s+    where {- Invariants: nx = length $ concatReverseFL psx+                         lx = last $ concatReverseFL psx   -}+          f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)+            -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)+            -> a+          f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s+           | l1 == l2 = j ps1s (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))+          f n1 l1 ps1 ps1s n2 l2 ps2 ps2s+           = case compare n1 n2 of+             GT -> case dropWhileNilRL ps2s of+                   ps2':<:ps2s' ->+                       f n1 l1 ps1 ps1s+                         (n2 + lengthRL ps2') (last $ mapRL info ps2') (ps2':>:ps2) ps2s'+                   NilRL -> -- We keep going round f so the l1 == l2 case+                            -- has a chance to kick in+                         case dropWhileNilRL ps1s of+                         ps1':<:ps1s' ->+                             f (n1 + lengthRL ps1') (last $ mapRL info ps1')+                               (ps1':>:ps1) ps1s'+                               n2 l2 ps2 ps2s+                         NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)+             _  -> case dropWhileNilRL ps1s of+                   ps1':<:ps1s' ->+                       f (n1 + lengthRL ps1') (last $ mapRL info ps1') (ps1':>:ps1) ps1s'+                         n2 l2 ps2 ps2s+                   NilRL -> -- We keep going round f so the l1 == l2 case+                            -- has a chance to kick in+                         case dropWhileNilRL ps2s of+                         ps2':<:ps2s' ->+                             f n1 l1 ps1 NilRL+                               (n2 + lengthRL ps2') (last $ mapRL info ps2')+                               (ps2':>:ps2) ps2s'+                         NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)++{-|+'gcau' determines a list of /common/ patches and patches unique to each of+the two 'PatchSet's.  The list of /common/ patches only needs to include all+patches that are not interspersed with the /unique/ patches, but including+more patches in the list of /common/ patches doesn't really hurt, except+for efficiency considerations.  Mostly, we want to access as few elements+as possible of the 'PatchSet' list, since those can be expensive (or+unavailable).  In other words, the /common/ patches need not be minimal,+whereas the 'PatchSet's should be minimal for performance reasons.++'PatchSet's have the property that if+@+(info $ last $ head a) == (info $ last $ head b)+@+then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take+advantage of this if possible, to avoid reading too many inventories.  In+the case of --partial repositories or patch bundles, it is crucial that we+don't need to read the whole history, since it isn't available.++TODO:++The length equalising isn't necessarily right. We probably also be+thinking about not going past the end of a partial repository, or favour+local repository stuff over remote repo stuff.++Also, when comparing l1 to l2, we should really be comparing the+newly discovered one to /all/ the lasts in the other patch set+that we've got so far.+-}++gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)+     -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+gcau NilRL ps2 = return ([], NilRL:<:NilRL :\/: concatRL ps2 :<: NilRL)+gcau ps1 NilRL = return ([], concatRL ps1 :<: NilRL :\/: NilRL:<:NilRL)+gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2+gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2+gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_)+ | info pi1 == info pi2+ , IsEq <- sloppyIdentity pi1+ , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL:<:NilRL :\/: unsafeCoerceP (NilRL:<:NilRL))+gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s)+ = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s+     (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s+    where {- Invariants: nx = lengthRL $ concatReverseFL psx+                         lx = last $ concatReverseFL psx   -}+          f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)+            -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)+            -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+          f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s+           | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))+          f n1 l1 ps1 ps1s n2 l2 ps2 ps2s+           = case n1 `compare` n2 of+             GT -> case dropWhileNilRL ps2s of+                   ps2':<:ps2s' ->+                       f n1 l1 ps1 ps1s+                         (n2 + lengthRL ps2') (unseal info $ lastRL ps2') (ps2':>:ps2) ps2s'+                   NilRL -> -- We keep going round f so the l1 == l2 case+                            -- has a chance to kick in+                         case dropWhileNilRL ps1s of+                         ps1':<:ps1s' ->+                             f (n1 + lengthRL ps1') (unseal info $ lastRL ps1')+                               (ps1':>:ps1) ps1s'+                               n2 l2 ps2 ps2s+                         NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)+             _  -> case dropWhileNilRL ps1s of+                   ps1':<:ps1s' ->+                       f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') (ps1':>:ps1) ps1s'+                         n2 l2 ps2 ps2s+                   NilRL -> -- We keep going round f so the l1 == l2 case+                            -- has a chance to kick in+                         case dropWhileNilRL ps2s of+                         ps2':<:ps2s' ->+                             f n1 l1 ps1 NilRL+                               (n2 + lengthRL ps2') (unseal info $ lastRL ps2')+                               (ps2':>:ps2) ps2s'+                         NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)++lastRL :: RL a C(x y) -> Sealed (a C(x))+lastRL (a:<:NilRL) = seal a+lastRL (_:<:as) = lastRL as+lastRL NilRL = bug "lastRL on empty list"++dropWhileNilRL :: PatchSet p C(x) -> PatchSet p C(x)+dropWhileNilRL (NilRL:<:xs) = dropWhileNilRL xs+dropWhileNilRL xs = xs++-- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences.+gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@+            -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@+            -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(y v))+gcau_simple ps1 ps2 = do+ FlippedSeal ex1 <- get_extra common ps1+ FlippedSeal ex2 <- get_extra common ps2+ let ps1' = filter (`elem` common) $ ps1_info+ return (ps1', (unsafeCoerceP ex1 :<: NilRL) :\/: ex2 :<: NilRL)+  where common   = ps1_info `intersect` mapRL info ps2+        ps1_info = mapRL info ps1++data MissingPatch = MissingPatch !PatchInfo !String++instance Error MissingPatch where+    -- we don't really need those methods+    noMsg = bug "MissingPatch doesn't define noMsg."++-- | Returns a sub-sequence from @patches@, where all the elements of @common@ have+-- been removed by commuting them out.+get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@+          -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@+          -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))+get_extra = get_extra_aux (return $ unsafeCoerceP NilFL)+  where+  get_extra_aux :: RepoPatch p => Either MissingPatch (FL (Named p) C(x y))+                -> [PatchInfo]+                -> RL (PatchInfoAnd p) C(u x)+                -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))+  get_extra_aux _ _ NilRL = return (flipSeal NilRL)+  get_extra_aux skipped common (hp:<:pps) =+      if info hp `elem` common && is_tag (info hp)+      then case getdeps `fmap` hopefullyM hp of+           Just ds -> get_extra_aux (liftM2 (:>:) ep skipped) (ds++delete (info hp) common) pps+           Nothing -> get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps+      else if info hp `elem` common+           then get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps+           else do+              p <- ep+              skpd <- skipped+              case commuteFL (p :> skpd) of+                Right (skipped_patch' :> p') -> do+                    FlippedSeal x <- get_extra_aux (return skipped_patch') common pps+                    return $ flipSeal (info hp `piap` p' :<: x)+                -- Failure to commute indicates a bug because it means+                -- that a patch was interspersed between the common+                -- patches.  This should only happen if that patch was+                -- commuted there.  This uses 2 properties:+                -- 1) commute is its own inverse+                -- 2) if patches commute in one adjacent context then+                --    they commute in any context where they are+                --    adjacent+                Left (Sealed2 hpc) -> errorDoc $ text "bug in get_extra commuting patches:"+                         $$ text "First patch is:"+                         $$ human_friendly (info hp)+                         $$ text "Second patch is:"+                         $$ human_friendly (info $ n2pia hpc)+      where ep = case hopefullyM hp of+                 Right p' -> return p'+                 Left e -> Left (MissingPatch (info hp) e)++missingPatchError :: MissingPatch -> a+missingPatchError (MissingPatch pinfo e) =+    errorDoc+        ( text "failed to read patch in get_extra:"+          $$ human_friendly pinfo $$ text e+          $$ text "Perhaps this is a 'partial' repository?" )++get_extra_old :: RepoPatch p => [PatchInfo]+              -> RL (PatchInfoAnd p) C(u x)+              -> FlippedSeal (RL (PatchInfoAnd p)) C(y)+get_extra_old common pps =+    either missingPatchError id (get_extra common pps)++get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x)+get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal $ NilRL :<: NilRL+get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) =+    if info hp == t+    then if get_tags_right patchset == [info hp]+         then flipSeal $ NilRL :<: NilRL -- special case to avoid looking at redundant patches+         else case get_extra_old [t] (concatRL patchset) of+              FlippedSeal x -> flipSeal $ x :<: NilRL+    else hp `prepend` get_patches_beyond_tag t (ps:<:pps)+ where+ prepend :: (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(y)+ prepend pp (FlippedSeal NilRL)     = flipSeal $ (pp:<:NilRL) :<: NilRL+ prepend pp (FlippedSeal (p:<:ps')) = flipSeal $ (pp:<:p)     :<: ps'+get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps+get_patches_beyond_tag t NilRL = bug $ "tag\n" +++                                 renderString (human_friendly t) +++                                 "\nis not in the patchset in get_patches_beyond_tag."++-- | @get_patches_in_tag t ps@ returns a 'SealedPatchSet' of all+-- patches in @ps@ which are contained in @t@.+get_patches_in_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> SealedPatchSet p+get_patches_in_tag t pps@((hp:<:NilRL):<:xs)+    | info hp == t = seal pps+    | otherwise = get_patches_in_tag t xs++get_patches_in_tag t ((hp:<:ps):<:xs)+    | info hp /= t = get_patches_in_tag t (ps:<:xs)++get_patches_in_tag t ((pa:<:ps):<:xs) = gpit thepis (pa:>:NilFL) (ps:<:xs)+    where thepis = getdeps $ conscientiously+                   (\e -> text "Couldn't read tag"+                          $$ human_friendly t+                          $$ text ""+                          $$ e) pa+          gpit :: RepoPatch p => [PatchInfo] -> (FL (PatchInfoAnd p)) C(x y) -> PatchSet p C(x) -> SealedPatchSet p+          gpit _ sofar NilRL = seal $ reverseFL sofar :<: NilRL+          gpit deps sofar ((hp:<:NilRL):<:xs')+              | info hp `elem` deps+              , IsEq <- sloppyIdentity hp = seal $ (reverseFL $ hp :>: sofar) :<: xs'+              | IsEq <- sloppyIdentity hp = gpit deps sofar xs'+          gpit deps sofar (NilRL:<:xs') = gpit deps sofar xs'+          gpit deps sofar ((hp:<:ps'):<:xs')+              | info hp `elem` deps+                  = let odeps = filter (/=info hp) deps+                        alldeps = if is_tag $ info hp+                                  then odeps ++ getdeps (hopefully hp)+                                  else odeps+                    in gpit alldeps (hp:>:sofar) (ps':<:xs')+              | otherwise+                  = gpit deps (commute_by sofar $ hopefully hp) (ps':<:xs')+          commute_by :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (Named p) C(w x)+                     -> FL (PatchInfoAnd p) C(w z)+          commute_by NilFL _ = unsafeCoerceP NilFL+          commute_by (hpa:>:xs') p =+              case commutex (hopefully hpa :< p) of+                Nothing -> bug "Failure commuting patches in commute_by called by gpit!"+                Just (p':<a') -> (info hpa `piap` a') :>: commute_by xs' p'++get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag"+                                 $$ human_friendly t++get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo]+get_tags_right NilRL = []+get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps)+    where+    get_tags_r :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]+    get_tags_r [] = []+    get_tags_r (hp:pps) = case snd hp of+                          Just ds -> fst hp : get_tags_r (drop_tags_r ds pps)+                          Nothing -> fst hp : get_tags_r pps++    drop_tags_r :: [PatchInfo]+                -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])]+    drop_tags_r [] pps = pps+    drop_tags_r _  []  = []+    drop_tags_r ds (hp:pps)+        | fst hp `elem` ds = case snd hp of+                             Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps+                             Nothing -> drop_tags_r (delete (fst hp) ds) pps+        | otherwise = hp : drop_tags_r ds pps+                      +    info_and_deps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo])+    info_and_deps p +        | is_tag (info p) = (info p, getdeps `fmap` hopefullyM p)+        | otherwise = (info p, Nothing)++deep_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)+deep_optimize_patchset pss = optimize_patchset (concatRL pss :<: NilRL)++optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)+optimize_patchset NilRL = NilRL+optimize_patchset (ps:<:pss) = opsp ps +<+ pss+  where +        opsp :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)+        opsp NilRL = NilRL+        opsp (hp:<:pps)+             | is_tag (info hp) && get_tags_right ((hp:<:pps):<:NilRL) == [info hp]+                 = (hp:<:NilRL) :<: opsp pps+             | otherwise = hp -:- opsp pps++(-:-) :: (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(a x) -> RL (RL (PatchInfoAnd p)) C(a y)+pp -:- NilRL = (pp:<:NilRL) :<: NilRL+pp -:- (p:<:ps) = ((pp:<:p) :<: ps)++slightly_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)+slightly_optimize_patchset NilRL = NilRL+slightly_optimize_patchset (ps:<:pss) = sops (progressRL "Optimizing inventory" ps) +<+ pss+    where sops :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)+          sops NilRL = NilRL+          sops (pinfomp :<: NilRL) = (pinfomp :<: NilRL) :<: NilRL+          sops (hp:<:pps) | is_tag (info hp) = if get_tags_right ((hp:<:pps):<:NilRL) == [info hp]+                                               then (hp:<:NilRL) :<: (pps:<: NilRL)+                                               else hp -:- sops (progressRL "Optimizing inventory" pps)+                          | otherwise = hp -:- sops pps++commute_to_end :: forall p C(x y). RepoPatch p => FL (Named p) C(x y) -> PatchSet p C(y)+               -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)+commute_to_end select from = ctt (mapFL patch2patchinfo select) from NilFL+   where+-- In order to preserve the structure of the original PatchSet, we commute+-- the patches we are going to throw away past the patches we plan to keep.+-- This puts them at the end of the PatchSet where it is safe to discard them.+-- We return all the patches in the PatchSet which have been commuted.+      ctt :: [PatchInfo] -> PatchSet p C(v) -> FL (Named p) C(v u)+          -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)+      -- This unsafeCoerceP should be fine, because if we run out of+      -- patches in the selection the ending context of the second param+      -- should be x (because we have commute all of the selected sequence,+      -- with context C(x y), past the elements of the second parameter.+      -- Unfortunately this is hard to express in the type system while+      -- using an accumulator to build up the return value.+      ctt [] ps acc = (unsafeCoerceP acc) :< ps+      ctt sel (NilRL:<:ps) acc = ctt sel ps acc+      ctt sel ((hp:<:hps):<:ps) acc+         | info hp `elem` sel+            = case commuteFL (hopefully hp :> acc) of+              Left _ -> bug "patches to commute_to_end does not commutex (1)"+              Right (acc' :> _) -> ctt (delete (info hp) sel) (hps:<:ps) acc'+         | otherwise+            = ctt sel (hps:<:ps) (hopefully hp:>:acc)+      ctt _ _ _ = bug "patches to commute_to_end does not commutex (2)"++patchset_intersection :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p+patchset_intersection [] = seal (NilRL :<: NilRL)+patchset_intersection [x] = x+patchset_intersection (Sealed y:ys) = +    case patchset_intersection ys of+    Sealed ys' -> with_partial_intersection y ys' $+      \common a b -> +          case mapRL info a `intersect` mapRL info b of+          morecommon -> +              case partitionRL (\e -> info e `notElem` morecommon) a of+                commonps :> _ -> seal $ commonps :<: common++patchset_union :: forall p. RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p+patchset_union [] = seal (NilRL :<: NilRL)+patchset_union [x] = x+patchset_union (Sealed y:ys) = +    case patchset_union ys of+    Sealed ys' -> with_partial_intersection y ys' f+  where+  f :: FORALL(z x y) PatchSet p C(z) -- ^ @common@+    -> RL (PatchInfoAnd p) C(z x) -- ^ @a@+    -> RL (PatchInfoAnd p) C(z y) -- ^ @b@+    -> SealedPatchSet p+  f common a b = g_s $ gcau_simple a b+    where+      g_s :: Either MissingPatch+                    ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))+          -> SealedPatchSet p+      g_s (Left e) = missingPatchError e+      g_s (Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL))) =+          case (merge_sets (a' :\/: b')) of+          Sealed a'b' -> seal $ (a'b' +<+ b) :<: common+      g_s _ = impossible++merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y))+merge_sets (l :\/: r) =+    let pl = mapFL_FL hopefully $ reverseRL l+        pr = mapFL_FL hopefully $ reverseRL r+        p2pimp p = patch2patchinfo p `piap` p+    in case merge (pl:\/: pr) of+       (_:/\:pl') -> seal $ reverseFL $ mapFL_FL p2pimp pl'
+ src/Darcs/Patch/FileName.hs view
@@ -0,0 +1,158 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++-- | FileName is an abstract type intended to facilitate the input and output of+-- unicode filenames.+module Darcs.Patch.FileName ( FileName( ),+                              fp2fn, fn2fp,+                              fn2ps, ps2fn,+                              niceps2fn, fn2niceps,+                              break_on_dir, norm_path, own_name, super_name,+                              movedirfilename,+                              encode_white, decode_white,+                              (///),+                              breakup+                            ) where++import System.IO+import Data.Char ( isSpace, chr, ord )+import qualified UTF8 ( encode )+import Data.Word ( Word8( ) )+import ByteStringUtils ( unpackPSfromUTF8 )+import qualified Data.ByteString.Char8 as BC (unpack, pack)+import qualified Data.ByteString       as B  (ByteString, pack)++newtype FileName = FN FilePath deriving ( Eq, Ord )+encode :: [Char] -> [Word8]+encode = UTF8.encode++instance Show FileName where+   showsPrec d (FN fp) = showParen (d > app_prec) $ showString "fp2fn " . showsPrec (app_prec + 1) fp+      where app_prec = 10++{-# INLINE fp2fn #-}+fp2fn :: FilePath -> FileName+fp2fn fp = FN fp++{-# INLINE fn2fp #-}+fn2fp :: FileName -> FilePath+fn2fp (FN fp) = fp++{-# INLINE niceps2fn #-}+niceps2fn :: B.ByteString -> FileName+niceps2fn = FN . decode_white . BC.unpack++{-# INLINE fn2niceps #-}+fn2niceps :: FileName -> B.ByteString+fn2niceps (FN fp) = BC.pack $ encode_white fp++{-# INLINE fn2ps #-}+fn2ps :: FileName -> B.ByteString+fn2ps (FN fp) = B.pack $ encode $ encode_white fp++{-# INLINE ps2fn #-}+ps2fn :: B.ByteString -> FileName+ps2fn ps = FN $ decode_white $ unpackPSfromUTF8 ps++-- | 'encode_white' translates whitespace in filenames to a darcs-specific+--   format (backslash followed by numerical representation according to 'ord').+--   Note that backslashes are also escaped since they are used in the encoding.+--+--   > encode_white "hello there" == "hello\32there"+--   > encode_white "hello\there" == "hello\\there"+encode_white :: FilePath -> String+encode_white (c:cs) | isSpace c || c == '\\' =+    '\\' : (show $ ord c) ++ "\\" ++ encode_white cs+encode_white (c:cs) = c : encode_white cs+encode_white [] = []++-- | 'decode_white' interprets the Darcs-specific \"encoded\" filenames+--   produced by 'encode_white'+--+--   > decode_white "hello\32there" == "hello there"+--   > decode_white "hello\\there"  == "hello\there"+--   > decode_white "hello\there"   == error "malformed filename"+decode_white :: String -> FilePath+decode_white ('\\':cs) =+    case break (=='\\') cs of+    (theord, '\\':rest) ->+        chr (read theord) : decode_white rest+    _ -> error "malformed filename"+decode_white (c:cs) = c: decode_white cs+decode_white "" = ""++own_name :: FileName -> FileName+own_name (FN f) = case breakLast '/' f of Nothing -> FN f+                                          Just (_,f') -> FN f'+super_name :: FileName -> FileName+super_name fn = case norm_path fn of+                FN f -> case breakLast '/' f of+                        Nothing -> FN "."+                        Just (d,_) -> FN d+break_on_dir :: FileName -> Maybe (FileName,FileName)+break_on_dir (FN p) = case breakFirst '/' p of+                      Nothing -> Nothing+                      Just (d,f) | d == "." -> break_on_dir $ FN f+                                 | otherwise -> Just (FN d, FN f)+norm_path :: FileName -> FileName -- remove "./"+norm_path (FN p) = FN $ repath $ drop_dotdot $ breakup p++repath :: [String] -> String+repath [] = ""+repath [f] = f+repath (d:p) = d ++ "/" ++ repath p++drop_dotdot :: [String] -> [String]+drop_dotdot ("":p) = drop_dotdot p+drop_dotdot (".":p) = drop_dotdot p+drop_dotdot ("..":p) = ".." : (drop_dotdot p)+drop_dotdot (_:"..":p) = drop_dotdot p+drop_dotdot (d:p) = case drop_dotdot p of+                    ("..":p') -> p'+                    p' -> d : p'+drop_dotdot [] = []++-- | Split a file path at the slashes+breakup :: String -> [String]+breakup p = case break (=='/') p of+            (d,"") -> [d]+            (d,p') -> d : breakup (tail p')++breakFirst :: Char -> String -> Maybe (String,String)+breakFirst c l = bf [] l+    where bf a (r:rs) | r == c = Just (reverse a,rs)+                      | otherwise = bf (r:a) rs+          bf _ [] = Nothing+breakLast :: Char -> String -> Maybe (String,String)+breakLast c l = case breakFirst c (reverse l) of+                Nothing -> Nothing+                Just (a,b) -> Just (reverse b, reverse a)++(///) :: FileName -> FileName -> FileName+(FN "")///b = norm_path b+a///b = norm_path $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b++movedirfilename :: FileName -> FileName -> FileName -> FileName+movedirfilename old new name =+    if name' == old' then new+                     else if length name' > length old' &&+                             take (length old'+1) name' == old'++"/"+                          then fp2fn ("./"++new'++drop (length old') name')+                          else name+    where old' = fn2fp $ norm_path old+          new' = fn2fp $ norm_path new+          name' = fn2fp $ norm_path name
+ src/Darcs/Patch/Info.hs view
@@ -0,0 +1,331 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++module Darcs.Patch.Info ( PatchInfo, patchinfo, invert_name, is_inverted,+                          idpatchinfo, add_junk,+                          make_filename, make_alt_filename, readPatchInfo,+                          just_name, just_author, repopatchinfo, RepoPatchInfo,+                          human_friendly, to_xml, pi_date, set_pi_date,+                          pi_name, pi_rename, pi_author, pi_tag, pi_log,+                          showPatchInfo, is_tag+                        ) where+import Text.Html hiding (name, text)+import System.Random ( randomRIO )+import Numeric ( showHex )+import Control.Monad ( when )++import ByteStringUtils +import qualified Data.ByteString       as B  (length, splitAt, null, drop+                                             ,isPrefixOf, tail, concat, ByteString )+import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break)++import Printer ( renderString, Doc, packedString,+                 empty, ($$), (<>), (<+>), vcat, text, blueText, prefix )+import OldDate ( readUTCDate, showIsoDateTime )+import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime,+                     toCalendarTime )+import System.IO.Unsafe ( unsafePerformIO )+import SHA1 ( sha1PS )+import Darcs.Utils ( promptYorn )+import Prelude hiding (pi, log)++data RepoPatchInfo = RPI String PatchInfo++repopatchinfo :: String -> PatchInfo -> RepoPatchInfo+repopatchinfo r pi = RPI r pi++data PatchInfo = PatchInfo { _pi_date    :: !B.ByteString+                           , _pi_name    :: !B.ByteString+                           , _pi_author  :: !B.ByteString+                           , _pi_log     :: ![B.ByteString]+                           , is_inverted :: !Bool+                           }+                 deriving (Eq,Ord)++idpatchinfo :: PatchInfo+idpatchinfo = PatchInfo myid myid myid [] False+    where myid = BC.pack "identity"++patchinfo :: String -> String -> String -> [String] -> IO PatchInfo+patchinfo date name author log =+    add_junk $ PatchInfo { _pi_date     = BC.pack date+                         , _pi_name     = BC.pack name+                         , _pi_author   = BC.pack author+                         , _pi_log      = map BC.pack log+                         , is_inverted  = False }++add_junk :: PatchInfo -> IO PatchInfo+add_junk pinf =+    do x <- randomRIO (0,2^(128 ::Integer) :: Integer)+       when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $+            do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? "+               when (yorn == 'n') $ fail "User cancelled because of Ignore-this."+       return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""):+                                 _pi_log pinf }++ignored :: [String] -- this is a [String] so we can change the junk header.+ignored = ["Ignore-this: "]++ignore_junk :: [B.ByteString] -> [B.ByteString]+ignore_junk = filter isnt_ignored+    where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO+          doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys+++-- * Patch info formatting+invert_name :: PatchInfo -> PatchInfo+invert_name pi = pi { is_inverted = not (is_inverted pi) }++just_name :: PatchInfo -> String+just_name pinf = if is_inverted pinf then "UNDO: " ++ BC.unpack (_pi_name pinf)+                                     else BC.unpack (_pi_name pinf)++just_author :: PatchInfo -> String+just_author = BC.unpack . _pi_author++human_friendly :: PatchInfo -> Doc+human_friendly pi =+    text (friendly_d $ _pi_date pi) <> text "  " <> packedString (_pi_author pi)+ $$ hfn (_pi_name pi)+ $$ vcat (map ((text "  " <>) . packedString) (ignore_junk $ _pi_log pi))+  where hfn x = case pi_tag pi of+                Nothing -> inverted <+> packedString x+                Just t -> text "  tagged" <+> text t+        inverted = if is_inverted pi then text "  UNDO:" else text "  *"++-- note the difference with just_name+pi_name :: PatchInfo -> String+pi_name = BC.unpack . _pi_name++pi_rename :: PatchInfo -> String -> PatchInfo+pi_rename x n = x { _pi_name = BC.pack n }++pi_author :: PatchInfo -> String+pi_author = BC.unpack . _pi_author++is_tag :: PatchInfo -> Bool+is_tag pinfo = take 4 (just_name pinfo) == "TAG "+++-- | Note: we ignore timezone information in the date string,+--   systematically treating a time as UTC.  So if the patch+--   tells me it's 17:00 EST, we're actually treating it as+--   17:00 UTC, in other words 11:00 EST.  This is for+--   backwards compatibility to darcs prior to 2003-11, sometime+--   before 1.0.  Fortunately, newer patch dates are written in+--   UTC, so this timezone truncation is harmless for them.+readPatchDate :: B.ByteString -> CalendarTime+readPatchDate = ignoreTz . readUTCDate . BC.unpack+  where ignoreTz ct = ct { ctTZ = 0 }++pi_date :: PatchInfo -> CalendarTime+pi_date = readPatchDate . _pi_date++set_pi_date :: String -> PatchInfo -> PatchInfo+set_pi_date date pi = pi { _pi_date = BC.pack date }++pi_log :: PatchInfo -> [String]+pi_log = map BC.unpack . ignore_junk . _pi_log++pi_tag :: PatchInfo -> Maybe String+pi_tag pinf =+    if l == t+      then Just $ BC.unpack r+      else Nothing+    where (l, r) = B.splitAt (B.length t) (_pi_name pinf)+          t = BC.pack "TAG "++friendly_d :: B.ByteString -> String+--friendly_d d = calendarTimeToString . readPatchDate . d+friendly_d d = unsafePerformIO $ do+    ct <- toCalendarTime $ toClockTime $ readPatchDate d+    return $ calendarTimeToString ct++to_xml :: PatchInfo -> Doc+to_xml pi =+        text "<patch"+    <+> text "author='" <> escapeXML (just_author pi) <> text "'"+    <+> text "date='" <> escapeXML (BC.unpack $ _pi_date pi) <> text "'"+    <+> text "local_date='" <> escapeXML (friendly_d $ _pi_date pi) <> text "'"+    <+> text "inverted='" <> text (show $ is_inverted pi) <> text "'"+    <+> text "hash='" <> text (make_filename pi) <> text "'>"+ $$     prefix "\t" (+            text "<name>" <> escapeXML (pi_name pi) <> text "</name>"+         $$ comments_as_xml (_pi_log pi))+ $$     text "</patch>"++comments_as_xml :: [B.ByteString] -> Doc+comments_as_xml comments+  | B.length comments' > 0 = text "<comment>"+                          <> escapeXML (BC.unpack comments')+                          <> text "</comment>"+  | otherwise = empty+    where comments' = unlinesPS comments++-- escapeXML is duplicated in Patch.lhs and Annotate.lhs+-- It should probably be refactored to exist in one place.+escapeXML :: String -> Doc+escapeXML = text . strReplace '\'' "&apos;" . strReplace '"' "&quot;" .+  strReplace '>' "&gt;" . strReplace '<' "&lt;" . strReplace '&' "&amp;"+++strReplace :: Char -> String -> String -> String+strReplace _ _ [] = []+strReplace x y (z:zs)+  | x == z    = y ++ (strReplace x y zs)+  | otherwise = z : (strReplace x y zs)++make_alt_filename :: PatchInfo -> String+make_alt_filename pi@(PatchInfo { is_inverted = False }) =+    fix_up_fname (midtrunc (pi_name pi)++"-"++just_author pi++"-"++BC.unpack (_pi_date pi))+make_alt_filename pi@(PatchInfo { is_inverted = True}) =+    make_alt_filename (pi { is_inverted = False }) ++ "-inverted"++-- This makes darcs-1 (non-hashed repos) filenames, and is also generally used in both in+-- hashed and non-hashed repo code for making patch "hashes"+make_filename :: PatchInfo -> String+make_filename pi =+    showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me++".gz"+        where b2ps True = BC.pack "t"+              b2ps False = BC.pack "f"+              sha1_me = B.concat [_pi_name pi,+                                  _pi_author pi,+                                  _pi_date pi,+                                  B.concat $ _pi_log pi,+                                  b2ps $ is_inverted pi]+              d = readPatchDate $ _pi_date pi+              sha1_a = take 5 $ sha1PS $ _pi_author pi++midtrunc :: String -> String+midtrunc s+    | length s < 73 = s+    | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s)+fix_up_fname :: String -> String+fix_up_fname = map munge_char++munge_char :: Char -> Char+munge_char '*' = '+'+munge_char '?' = '2'+munge_char '>' = '7'+munge_char '<' = '2'+munge_char ' ' = '_'+munge_char '"' = '~'+munge_char '`' = '.'+munge_char '\'' = '.'+munge_char '/' = '1'+munge_char '\\' = '1'+munge_char '!' = '1'+munge_char ':' = '.'+munge_char ';' = ','+munge_char '{' = '~'+munge_char '}' = '~'+munge_char '(' = '~'+munge_char ')' = '~'+munge_char '[' = '~'+munge_char ']' = '~'+munge_char '=' = '+'+munge_char '#' = '+'+munge_char '%' = '8'+munge_char '&' = '6'+munge_char '@' = '9'+munge_char '|' = '1'+munge_char  c  =  c++instance  HTML RepoPatchInfo  where+    toHtml = htmlPatchInfo+instance  Show PatchInfo  where+    show pi = renderString (showPatchInfo pi)++-- |Patch is stored between square brackets.+--+-- > [ <patch name>+-- > <patch author>*<patch date>+-- >  <patch log (may be empty)> (indented one)+-- >  <can have multiple lines in patch log,>+-- >  <as long as they're preceded by a space>+-- >  <and don't end with a square bracket.>+-- > ]+--+-- note that below I assume the name has no newline in it.+showPatchInfo :: PatchInfo -> Doc+showPatchInfo pi =+    blueText "[" <> packedString (_pi_name pi)+ $$ packedString (_pi_author pi) <> text inverted <> packedString (_pi_date pi)+                                 <> myunlines (_pi_log pi) <> blueText "] "+    where inverted = if is_inverted pi then "*-" else "**"+          myunlines [] = empty+          myunlines xs = mul xs+              where mul [] = text "\n"+                    mul (s:ss) = text "\n " <> packedString s <> mul ss++--+-- Note, Data.ByteString rewrites break ((==) x) into the memchr-based+-- breakByte. For this rule to fire, we keep it in prefix application form+--++readPatchInfo :: B.ByteString -> Maybe (PatchInfo, B.ByteString)+readPatchInfo s | B.null (dropSpace s) = Nothing+readPatchInfo s =+    if BC.head (dropSpace s) /= '[' -- ]+    then Nothing+    else case BC.break ((==) '\n') $ B.tail $ dropSpace s of+         (name,s') ->+             case BC.break ((==) '*') $ B.tail s' of+             (author,s2) ->+                 case BC.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of+                 (ct,s''') ->+                     do (log, s4) <- lines_starting_with_ending_with ' ' ']' $ dn s'''+                        return $ (PatchInfo { _pi_date = ct+                                            , _pi_name = name+                                            , _pi_author = author+                                            , _pi_log = log+                                            , is_inverted = BC.index s2 1 /= '*'+                                            }, s4)+    where dn x = if B.null x || BC.head x /= '\n' then x else B.tail x++lines_starting_with_ending_with :: Char -> Char -> B.ByteString+                                -> Maybe ([B.ByteString],B.ByteString)+lines_starting_with_ending_with st en s = lswew s+    where+  lswew x | B.null x = Nothing+  lswew x =+    if BC.head x == en+    then Just ([], B.tail x)+    else if BC.head x /= st+         then Nothing+         else case BC.break ((==) '\n') $ B.tail x of+              (l,r) -> case lswew $ B.tail r of+                       Just (ls,r') -> Just (l:ls,r')+                       Nothing ->+                           case breakLastPS en l of+                           Just (l2,_) ->+                               Just ([l2], B.drop (B.length l2+2) x)+                           Nothing -> Nothing++htmlPatchInfo :: RepoPatchInfo -> Html+htmlPatchInfo (RPI r pi) =+    toHtml $ (td << patch_link r pi) `above`+               ((td ! [align "right"] << mail_link (just_author pi)) `beside`+                (td << (friendly_d $ _pi_date pi)))++patch_link :: String -> PatchInfo -> Html+patch_link r pi =+    toHtml $ hotlink+               ("darcs?"++r++"**"++make_filename pi)+               [toHtml $ pi_name pi]+mail_link :: String -> Html+mail_link email = toHtml $ hotlink ("mailto:"++email) [toHtml email]
+ src/Darcs/Patch/Match.lhs view
@@ -0,0 +1,346 @@+%  Copyright (C) 2004 David Roundy+%+%  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.++\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun,+                    patch_match, match_pattern,+                    apply_matcher, make_matcher,+                    parseMatch,+                    match_parser, helpOnMatchers,+                  ) where++import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Expr+import Text.Regex ( mkRegex, matchRegex )+import Data.Maybe ( isJust )+import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import Darcs.Patch ( Patch, Patchy, list_touched_files, patchcontents )+import Darcs.Patch.Info ( just_name, just_author, make_filename,+                          pi_date )+import Darcs.Sealed ( Sealed2(..), seal2 )+import DateMatcher ( parseDateMatcher )++import Darcs.Patch.MatchData ( PatchMatch(..), patch_match )++-- | A type for predicates over patches which do not care about+-- contexts+type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool++-- | A @Matcher@ is made of a 'MatchFun' which we will use to match+-- patches and a @String@ representing it.+data Matcher p = MATCH String (MatchFun p)++instance Show (Matcher p) where+    show (MATCH s _) = '"':s ++ "\""++make_matcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p+make_matcher s m = MATCH s m++-- | @apply_matcher@ applies a matcher to a patch.+apply_matcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool+apply_matcher (MATCH _ m) = m . seal2++parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)+parseMatch (PatternMatch s) =+    case parse match_parser "match" s of+    Left err -> Left $ "Invalid -"++"-match pattern '"++s+++                "'.\n"++ unlines (map ("    "++) $ lines $ show err) -- indent+    Right m -> Right m++match_pattern :: Patchy p => PatchMatch -> Matcher p+match_pattern p@(PatternMatch s) =+    case parseMatch p of+    Left err -> error err+    Right m -> make_matcher s m++trivial :: Patchy p => MatchFun p+trivial = const True+\end{code}++\paragraph{Match}++Currently \verb!--match! accepts six primitive match types, although+there are plans to expand it to match more patterns.  Also, note that the+syntax is still preliminary and subject to change.++The first match type accepts a literal string which is checked against+the patch name.  The syntax is+\begin{verbatim}+darcs annotate --summary --match 'exact foo+bar'+\end{verbatim}+This is useful for situations where a patch name contains characters that+could be considered special for regular expressions.++In this and the other match types, the argument must be enclosed in double+quotes if it contains spaces.  You can escape a quote in the argument with a+backslash; backslash escapes itself, but it is treated literally if followed+by a character other than a double quote or backslash, so it is typically not+necessary to escape a backslash.  No such escaping is necessary unless the+argument is enclosed in double quotes.++The second match type accepts a regular expression which is checked against+the patch name.  The syntax is+\begin{verbatim}+darcs annotate --summary --match 'name foo'+\end{verbatim}+Note that to match regexp metacharacters, such as \verb|(|, literally, they+must be escaped with backslash along with any embedded double quotes.  To+match a literal backslash it must be written quadrupled in general, but often+it need not be escaped, since backslash is only special in regexps when+followed by a metacharacter.  In the following example pairs, the first+literal is matched by the second sequence in the match name:+``\verb|"|'':``\verb|\"|'', ``\verb|\|'':``\verb|\\\\|'',+``\verb|\x|'':``\verb|\x|'', ``\verb|(|'':``\verb|\(|''.++The third match type matches the darcs hash for each patch:+\begin{verbatim}+darcs annotate --summary --match \+  'hash 20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef'+\end{verbatim}+Note you need to provide the full hash string as above.+This is intended to be used, for example, by programs allowing you to view+darcs repositories (e.g.\ CGI scripts like viewCVS).++The fourth match type accepts a regular expression which is checked against+the patch author.  The syntax is+\begin{verbatim}+darcs annotate --summary --match 'author foo'+\end{verbatim}++There is also support for matching by date.  This is done using commands such as+\begin{verbatim}+darcs annotate --summary --match 'date "last week"'+darcs annotate --summary --match 'date yesterday'+darcs annotate --summary --match 'date "today 14:00"'+darcs annotate --summary --match 'date "tea time yesterday"'+darcs annotate --summary --match 'date "3 days before last year at 17:00"'+darcs changes --from-match 'date "Sat Jun  30 11:31:30 EDT 2004"'+\end{verbatim}++Only English date specifications are supported---specifically you must use+English day and month names.  Also, only a limited set of time zones is+supported (compatible with GNU coreutils' date parsing).  Unrecognized zones+are treated as UTC, which may result in the timestamps printed in change+entries not being recognized by the date matching.  You can avoid this problem+on a POSIX-like system by running darcs in the UTC zone to get the times+initially, e.g.:+\begin{verbatim}+TZ=UTC darcs changes+\end{verbatim}++When matching on the ISO format, a partial date is treated as a range.+English dates can either refer to a specific day (``6 months ago',``day before+yesterday''), or to an interval+from some past date (``last month'') to the present.  Putting this all+together, if today is ``2004-07-24'' then the following matches should work:++\begin{tabular}{|ll|}+\hline+\textbf{date} & \textbf{patches selected} \\+\hline+2004          & from 2004-01-01 up to and including 2004-12-31 \\+2004-01       & from 2004-01-01 up to and including 2004-01-31 \\+2004-01-01    & during 2004-01-01 \\+\hline+today         & during 2004-07-24 (starting midnight in your timezone) \\+yesterday     & during 2004-07-23 \\+6 months ago  & during 2004-01-23 \\+\hline+last 6 months & since  2004-01-23 \\+last month    & since  2004-06-23 (not 2004-06-01!) \\+last week     & since  2004-07-16 \\+\hline+\end{tabular}++For more precise control, you may specify an interval, either+in a small subset of English or+of \htmladdnormallinkfoot{the ISO 8601 format}{http://www.w3.org/TR/NOTE-datetime}.+If you use the ISO format, note that durations, when+specified alone, are interpreted as being relative to the current date and time.+\begin{verbatim}+darcs annotate --summary --match 'date "between 2004-03-12 and last week"'+darcs annotate --summary --match 'date "after 2005"'+darcs annotate --summary --match 'date "in the last 3 weeks"'+darcs annotate --summary --match 'date "P3M/2006-03-17"'+darcs annotate --summary --match 'date "2004-01-02/2006-03-17"'+darcs annotate --summary --match 'date "P2M6D"'+\end{verbatim}++You may also prefer to combine date matching with a more specific pattern.+\begin{verbatim}+darcs annotate --summary --match 'date "last week" && name foo'+\end{verbatim}++The sixth match type accepts a regular expression which is checked against+file paths that the patch touches.  The syntax is+\begin{verbatim}+darcs annotate --summary --match 'touch foo/bar.c'+\end{verbatim}++The \verb!--match! pattern can include the logical operators \verb!&&!,+\verb!||! and \verb!not!, as well as grouping of patterns with parentheses.+For example+\begin{verbatim}+darcs annotate --summary --match 'name record && not name overrode'+\end{verbatim}++\begin{code}+match_parser :: Patchy p => CharParser st (MatchFun p)+match_parser = do m <- option trivial submatch+                  eof+                  return m++submatch :: Patchy p => CharParser st (MatchFun p)+submatch = buildExpressionParser table match <?> "match rule"++table :: OperatorTable Char st (MatchFun p)+table   = [ [prefix "not" negate_match,+             prefix "!" negate_match ]+          , [binary "||" or_match,+             binary "or" or_match,+             binary "&&" and_match,+            binary "and" and_match ]+          ]+    where binary name fun =+              Infix (do trystring name+                        spaces+                        return fun) AssocLeft+          prefix  name fun = Prefix $ do trystring name+                                         spaces+                                         return fun+          negate_match a p = not (a p)+          or_match m1 m2 p = (m1 p) || (m2 p)+          and_match m1 m2 p = (m1 p) && (m2 p)++trystring :: String -> CharParser st String+trystring s = try $ string s++match :: Patchy p => CharParser st (MatchFun p)+match = between spaces spaces+        (parens submatch+         <|> choice matchers_+         <?> "simple match")+        where matchers_ = map createMatchHelper primitiveMatchers+++createMatchHelper :: (String, String, [String], String -> MatchFun p)+                  -> CharParser st (MatchFun p)+createMatchHelper (key,_,_,matcher) =+  do trystring key+     spaces+     q <- quoted+     return $ matcher q++-- FIXME: would this be better defined in Darcs.Commands.Help?+-- | The string that is emitted when the user runs @darcs help --match@.+helpOnMatchers :: String+helpOnMatchers = unlines $+  ["Selecting Patches:",+   "",+   "The --patches option yields patches with names matching an `extended'",+   "regular expression.  See regex(7) for details.  The --matches option",+   "yields patches that match a logical (Boolean) expression: one or more",+   "primitive expressions combined by grouping (parentheses) and the",+   "complement (not), conjunction (and) and disjunction (or) operators.",+   "The C notation for logic operators (!, && and ||) can also be used.",+   "",+   " --patches=regex is a synonym for --matches='name regex'", +   " --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",+   " --from-patch and --to-match can be unproblematically combined:",+   " darcs changes --from-patch='html.*documentation' --to-match='date 20040212'",+   "",+   "The following primitive Boolean expressions are supported:"]+  ++ keywords+  ++ ["", "Here are some examples:"]+  ++ examples+  where -- This type signature exists to appease GHC.+        ps :: [(String, String, [String], String -> MatchFun Patch)]+        ps = primitiveMatchers+        keywords = [showKeyword k d | (k,d,_,_) <- ps]+        examples = [showExample k e | (k,_,es,_) <- ps, e <- es]+        showKeyword keyword description =+            -- FIXME: it would be nice to have a variable name here:+            -- "author REGEX - match against author (email address)"+            -- or "exact STRING - match against exact patch name".+            "  " ++ keyword ++ " - " ++ description ++ "."+        showExample keyword example =+            -- FIXME: this string is long, and its not a use case I've+            -- ever seen in practice.  Can we use something else,+            -- like "darcs changes --matches"? --twb, 2008-12-28+            "  darcs annotate --summary --match "+            ++ "'" ++ keyword ++ " " ++ example ++ "'"++primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]+                     -- ^ keyword (operator), help description, list+                     -- of examples, matcher function+primitiveMatchers =+ [ ("exact", "check a literal string against the patch name"+           , ["\"Resolve issue17: use dynamic memory allocation.\""]+           , exactmatch )+ , ("name", "check a regular expression against the patch name"+          , ["issue17", "\"^[Rr]esolve issue17\\>\""]+          , mymatch )+ , ("author", "check a regular expression against the author name"+            , ["\"David Roundy\"", "droundy", "droundy@darcs.net"]+            , authormatch )+ , ("hash",  "match the darcs hash for a patch"+          ,  ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"]+          ,  hashmatch )+ , ("date", "match the patch date"+          , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""]+          , datematch )+ , ("touch", "match file paths for a patch"+          , ["src/foo.c", "src/", "\"src/*.(c|h)\""]+          , touchmatch ) ]++parens :: CharParser st (MatchFun p)+       -> CharParser st (MatchFun p)+parens p  = between (string "(") (string ")") p++quoted :: CharParser st String+quoted = between (char '"') (char '"')+                 (many $ do { char '\\' -- allow escapes+                            ; try (oneOf ['\\', '"']) <|> return '\\'+                            }+                         <|>  noneOf ['"'])+         <|> between spaces spaces (many $ noneOf " ()")+         <?> "string"++mymatch, exactmatch, authormatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p++mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ just_name (info hp)++exactmatch r (Sealed2 hp) = r == (just_name (info hp))++authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ just_author (info hp)++hashmatch h (Sealed2 hp) = let rh = make_filename (info hp) in+                                  (rh == h) || (rh == h++".gz")++datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d+                                  in dm $ pi_date (info hp)++touchmatch r (Sealed2 hp) = let files = list_touched_files $ patchcontents $ hopefully hp+                            in or $ map (isJust . matchRegex (mkRegex r)) files+\end{code}
+ src/Darcs/Patch/MatchData.hs view
@@ -0,0 +1,28 @@+-- Copyright (C) 2004 David Roundy+--+-- 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.++module Darcs.Patch.MatchData ( PatchMatch(..), patch_match,+                      ) where++data PatchMatch = PatternMatch String+                  deriving ( Eq )++instance Show PatchMatch where+    show (PatternMatch m) = "pattern " ++ show m++patch_match :: String -> PatchMatch+patch_match s = PatternMatch s
+ src/Darcs/Patch/Non.hs view
@@ -0,0 +1,187 @@+-- Copyright (C) 2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators, GADTs, FlexibleContexts #-}++#include "gadts.h"++-- |'NonPatch' and 'Non' patches are patches that store a context as a+-- sequence of patches.  See "Darcs.Patch.Real" for example usage.+module Darcs.Patch.Non+       ( NonPatch, Non(..), Nonable(..), unNon,+         showNon, readNon, showNons, readNons,+         add, rem, addP, remP, addPs, remPs, remAddP, remAddPs, remNons,+         (*>), (>*), (*>>), (>>*),+         prop_adjust_twice ) where++import Prelude hiding ( rem )+import Data.List ( delete )+import Control.Monad ( liftM )+import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..),+                          showPrim, FileNameFormat(..), sort_coalesceFL )+import Darcs.Patch.Patchy+import Darcs.Patch.ReadMonads ( ParserM, lex_char )+import Darcs.Ordered+import Darcs.Patch.Read ( readPrim )+import Darcs.Patch.Viewing ()+import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )+import Darcs.Show+import Darcs.Sealed ( Sealed(Sealed) )+import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) )++--import Darcs.ColorPrinter ( traceDoc )+--import Printer ( greenText )++showNons :: ShowPatch (FL p) => [Non p C(x)] -> Doc+showNons [] = empty+showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}"++showNon :: ShowPatch (FL p) => Non p C(x) -> Doc+showNon (Non c p) = hiddenPrefix "|" (showPatch c)+                    $$ hiddenPrefix "|" (blueText ":")+                    $$ showPrim NewFormat p++readNons :: (ReadPatch p, ParserM m) => m [Non p C(x)]+readNons = peekfor "{{" rns (return [])+    where rns = peekfor "}}" (return []) $+                do Just (Sealed ps) <- readPatch' False+                   lex_char ':'+                   Just (Sealed p) <- readPrim NewFormat False+                   (Non ps p :) `liftM` rns++readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x)))+readNon = do Just (Sealed ps) <- readPatch' False+             peekfor ":" (do Just (Sealed p) <- readPatch' False+                             return $ Just $ Non ps p)+                         (return Nothing)++instance (Commute p, MyEq p) => Eq (Non p C(x)) where+    (Non cx x) == (Non cy y) | IsEq <- cx =\/= cy,+                               IsEq <- x =\/= y = True+                             | otherwise = False++-- | 'Non' stores a context with a 'Prim' patch.+data Non p C(x) where+    Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a)++-- | Convenience type for non primitive patches+type NonPatch C(x) = Non Prim C(x)++-- | Return as a list the context followed by the primitive patch.+unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))+unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL)++class Nonable p where+    non :: p C(x y) -> Non p C(x)++addP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x)+addP p n | Just n' <- p >* n = n'+addP p (Non c x) = Non (p:>:c) x++addPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x)+addPs NilRL n = n+addPs (p:<:ps) n = addPs ps $ addP p n++add :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Non p C(x)+add q = addPs (mapRL_RL fromPrim $ effectRL q)++-- remNons really only works right if the relevant nons are conflicting...+remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, ShowPatch p) => [Non p C(x)] -> Non p C(x) -> Non p C(x)+remNons ns (Non c x) = case remNonHelper ns c of+                       NilFL :> c' -> Non c' x+                       _ -> Non c x++remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p) => [Non p C(x)] -> FL p C(x y)+             -> (FL Prim :> FL p) C(x y)+remNonHelper [] x = NilFL :> x+remNonHelper ns (c:>:cs)+    | non c `elem` ns = case remNonHelper (map (addP $ invert c) $ delete (non c) ns) cs of+                        a :> z -> sort_coalesceFL (effect c+>+a) :> z+    | otherwise = case commuteWhatWeCanFL (c :> cs) of+                  b :> c' :> d ->+                      case remNonHelper ns b of+                      a :> b' -> a :> (b'+>+c':>:d)+remNonHelper _ NilFL = NilFL :> NilFL++remP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x) -> Maybe (Non p C(y))+remP p n | Just n' <- n *> p = Just n'+remP p (Non pc x) = do c <- removeFL p pc+                       return (Non c x)++remPs :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x) -> Maybe (Non p C(y))+remPs NilFL n = Just n+remPs (p:>:ps) n = remP p n >>= remPs ps++rem :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(x) -> Maybe (Non p C(y))+rem q = remPs (mapFL_FL fromPrim $ effect q)++remAddP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x)+remAddP p n = maybe (addP p n) id $ remP (invert p) n++remAddPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x)+remAddPs NilRL n = n+remAddPs (x:<:xs) n = remAddPs xs $ remAddP x n++(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y) -> Maybe (Non p C(y))+n *> p = invert p >* n++(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe (Non p C(x))+y >* (Non c x) = case commuteFL (y :> c) of+                    Right (c' :> y') -> do+                      px' :> _ <- commute (y' :> fromPrim x)+                      x' <- toPrim px'+                      return (Non c' x')+                    _ -> Nothing++(*>>) :: (Effect q, Patchy q, Patchy p, ToFromPrim p) => Non p C(x) -> q C(x y) -> Maybe (Non p C(y))+n *>> p = invert p >>* n++(>>*) :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Maybe (Non p C(x))+q >>* nn = adj (effectRL q) nn+    where adj :: (Patchy p, ToFromPrim p) => RL Prim C(x y) -> Non p C(y) -> Maybe (Non p C(x))+          adj NilRL n = Just n+          adj (x:<:xs) n = fromPrim x >* n >>= adj xs++prop_adjust_twice :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe Doc+prop_adjust_twice p n =+    do n' <- p >* n+       case n' *> p of+         Nothing -> Just (redText "prop_adjust_inverse 1")+         Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 2")+         _ -> case n *> invert p of+              Nothing -> Just (redText "prop_adjust_inverse 3")+              Just n'' | n'' /= n' -> Just (redText "prop_adjust_inverse 4")+              _ -> case invert p >* n' of+                   Nothing -> Just (redText "prop_adjust_inverse 5")+                   Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 6")+                   _ -> Nothing+                                   ++instance Nonable Prim where+    non = Non NilFL++instance Show2 p => Show (Non p C(x)) where+    showsPrec = showsPrec1++instance Show2 p => Show1 (Non p) where+    showsPrec1 d (Non cs p) = showParen (d > app_prec) $ showString "Non " .+                              showsPrec2 (app_prec + 1) cs . showString " " .+                              showsPrec (app_prec + 1) p++instance Patchy Prim
+ src/Darcs/Patch/Patchy.hs view
@@ -0,0 +1,230 @@+-- Copyright (C) 2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators, GADTs #-}++#include "gadts.h"++module Darcs.Patch.Patchy ( Patchy,+                            Apply, apply, applyAndTryToFix, applyAndTryToFixFL,+                            mapMaybeSnd,+                            Commute(..), commuteFL, commuteRL, commuteRLFL,+                            mergeFL,+                            ShowPatch(..),+                            ReadPatch, readPatch', bracketedFL, peekfor,+                            Invert(..), invertFL, invertRL ) where++import Control.Monad ( liftM )+import Data.Maybe ( fromJust )+import Data.Word ( Word8 )+import Data.List ( nub )++import Darcs.SlurpDirectory ( Slurpy )+import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 )+import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input )+import Darcs.Ordered+import Printer ( Doc, (<>), text )+import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )+import Darcs.IO ( WriteableDirectory )+import Darcs.Flags ( DarcsFlag )+import English ( plural, Noun(Noun) )++import ByteStringUtils ( ifHeadThenTail, dropSpace )+import qualified Data.ByteString.Char8 as BC (pack, ByteString)++--import Darcs.ColorPrinter ( traceDoc )+--import Printer ( greenText, ($$) )++class (Apply p, Commute p, ShowPatch p, ReadPatch p, Invert p) => Patchy p where+-- instance (ShowPatch p, Invert p) => Patchy p where++class Apply p where+    apply :: WriteableDirectory m => [DarcsFlag] -> p C(x y) -> m ()+    apply _ p = do mp' <- applyAndTryToFix p+                   case mp' of+                     Nothing -> return ()+                     Just (e, _) -> fail $ "Unable to apply a patch: " ++ e+    applyAndTryToFix :: WriteableDirectory m => p C(x y) -> m (Maybe (String, p C(x y)))+    applyAndTryToFix p = do apply [] p; return Nothing+    applyAndTryToFixFL :: WriteableDirectory m => p C(x y) -> m (Maybe (String, FL p C(x y)))+    applyAndTryToFixFL p = mapMaybeSnd (:>:NilFL) `liftM` applyAndTryToFix p++mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)+mapMaybeSnd f (Just (a,b)) = Just (a,f b)+mapMaybeSnd _ Nothing = Nothing++class Commute p where+    commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))+    commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y))+    commute (x :> y) = do x' :< y' <- commutex (y :< x)+                          return (y' :> x')+    commutex (x :< y) = do x' :> y' <- commute (y :> x)+                           return (y' :< x')+    merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)+    list_touched_files :: p C(x y) -> [FilePath]++class Commute p => ShowPatch p where+    showPatch :: p C(x y) -> Doc+    showNicely :: p C(x y) -> Doc+    showNicely = showPatch+    showContextPatch :: Slurpy -> p C(x y) -> Doc+    showContextPatch _ p = showPatch p+    description :: p C(x y) -> Doc+    description = showPatch+    summary :: p C(x y) -> Doc+    summary = showPatch+    writePatch :: FilePath -> p C(x y) -> IO ()+    writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"+    gzWritePatch :: FilePath -> p C(x y) -> IO ()+    gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"+    thing :: p C(x y) -> String+    thing _ = "patch"+    things :: p C(x y) -> String+    things x = plural (Noun $ thing x) ""++class ReadPatch p where+    readPatch'+        :: ParserM m => Bool -> m (Maybe (Sealed (p C(x ))))++class MyEq p => Invert p where+    invert :: p C(x y) -> p C(y x)+    identity :: p C(x x)+    sloppyIdentity :: p C(x y) -> EqCheck C(x y)+    sloppyIdentity p = identity =\/= p++instance Apply p => Apply (FL p) where+    apply _ NilFL = return ()+    apply opts (p:>:ps) = apply opts p >> apply opts ps+    applyAndTryToFix NilFL = return Nothing+    applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p+                                   mps <- applyAndTryToFix ps+                                   return $ case (mp,mps) of+                                            (Nothing, Nothing) -> Nothing+                                            (Just (e,p'),Nothing) -> Just (e,p'+>+ps)+                                            (Nothing, Just (e,ps')) -> Just (e,p:>:ps')+                                            (Just (e,p'), Just (es,ps')) ->+                                                Just (unlines [e,es], p'+>+ps')++instance Commute p => Commute (FL p) where+    commute (NilFL :> x) = Just (x :> NilFL)+    commute (x :> NilFL) = Just (NilFL :> x)+    commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)+                            return $ ys' :> reverseRL rxs'+    merge (NilFL :\/: x) = x :/\: NilFL+    merge (x :\/: NilFL) = NilFL :/\: x+    merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys)+                                             xs' :/\: ys'' <- return $ merge (ys' :\/: xs)+                                             return (ys'' :/\: (x' :>: xs'))+    list_touched_files xs = nub $ concat $ mapFL list_touched_files xs++mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)+mergeFL (p :\/: NilFL) = NilFL :/\: p+mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x)+                                            xs' :/\: p'' <- return $ mergeFL (p' :\/: xs)+                                            return ((x' :>: xs') :/\: p'')++commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))+commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)+commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)+commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)+                                  ys' :> xs'' <- commuteRLFL (xs' :> ys)+                                  return (y' :>: ys' :> xs'')++commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))+commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)+                               w'' :> zs' <- commuteRL (zs :> w')+                               return (w'' :> z' :<: zs')+commuteRL (NilRL :> w) = Just (w :> NilRL)++commuteFL :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))+commuteFL (p :> NilFL) = Right (NilFL :> p)+commuteFL (q :> p :>: ps) = case commute (q :> p) of+                            Just (p' :> q') ->+                               case commuteFL (q' :> ps) of+                               Right (ps' :> q'') -> Right (p' :>: ps' :> q'')+                               Left l -> Left l+                            Nothing -> Left $ seal2 p++instance ReadPatch p => ReadPatch (FL p) where+    readPatch' want_eof = Just `liftM` read_patches+     where read_patches :: ParserM m => m (Sealed (FL p C(x )))+           read_patches = do --tracePeek "starting FL read"+                             mp <- readPatch' False+                             case mp of+                               Just (Sealed p) -> do --tracePeek "found one patch"+                                                     Sealed ps <- read_patches+                                                     return $ Sealed (p:>:ps)+                               Nothing -> if want_eof+                                          then do --tracePeek "no more patches"+                                                  unit' <- lex_eof+                                                  case unit' of+                                                    () -> return $ Sealed NilFL+                                          else do --tracePeek "no more patches"+                                                  return $ Sealed NilFL+--           tracePeek x = do y <- peek_input+--                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()++{-# INLINE bracketedFL #-}+bracketedFL :: (ReadPatch p, ParserM m) =>+               Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x))))+bracketedFL pre post =+    peekforw pre bfl (return Nothing)+        where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x))))+              bfl = peekforw post (return $ Just $ Sealed NilFL)+                                  (do Just (Sealed p) <- readPatch' False+                                      Just (Sealed ps) <- bfl+                                      return $ Just $ Sealed (p:>:ps))++{-# INLINE peekforw #-}+peekforw :: ParserM m => Word8 -> m a -> m a -> m a+peekforw w ifstr ifnot = do s <- peek_input+                            case ifHeadThenTail w $ dropSpace s of+                              Just s' -> alter_input (const s') >> ifstr+                              Nothing -> ifnot++peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a+peekforPS ps ifstr ifnot = do s <- peek_input+                              case ((ps ==) . fst) `fmap` my_lex s of+                                Just True -> work my_lex >> ifstr+                                _ -> ifnot++{-# INLINE peekfor #-}+peekfor :: ParserM m => String -> m a -> m a -> m a+peekfor = peekforPS . BC.pack++instance Apply p => Apply (RL p) where+    apply _ NilRL = return ()+    apply opts (p:<:ps) = apply opts ps >> apply opts p+instance Commute p => Commute (RL p) where+    commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)+                            return (reverseFL fys' :> xs')+    merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of+                       (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'+    list_touched_files = list_touched_files . reverseRL+instance ReadPatch p => ReadPatch (RL p) where+    readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof+                             return $ Just $ Sealed $ reverseFL fl++invertFL :: Invert p => FL p C(x y) -> RL p C(y x)+invertFL NilFL = NilRL+invertFL (x:>:xs) = invert x :<: invertFL xs++invertRL :: Invert p => RL p C(x y) -> FL p C(y x)+invertRL NilRL = NilFL+invertRL (x:<:xs) = invert x :>: invertRL xs
+ src/Darcs/Patch/Permutations.hs view
@@ -0,0 +1,232 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators, PatternGuards #-}++#include "gadts.h"++module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon,+                                  commuteWhatWeCanFL, commuteWhatWeCanRL,+                                  genCommuteWhatWeCanRL,+                                  partitionFL, partitionRL,+                                  head_permutationsFL, head_permutationsRL,+                                  headPermutationsFL,+                                  remove_subsequenceFL, remove_subsequenceRL ) where++import Data.Maybe ( catMaybes )+import Darcs.Patch.Patchy ( Commute, commute, commuteFL, commuteRL, Invert(..), invertFL, invertRL )+import Darcs.Ordered+#include "impossible.h"++-- |split an 'FL' into "left" and "right" lists according to a predicate, using commutation as necessary.+-- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy+-- the predicate, it goes in the "right" list.+partitionFL :: Commute p+            => (FORALL(u v) p C(u v) -> Bool)       -- ^predicate; if true we would like the patch in the "left" list+            -> FL p C(x y)                          -- ^input 'FL'+            -> (FL p :> FL p) C(x y)                -- ^"left" and "right" results++-- optimise by using an accumulating parameter to track all the "right" patches that we've found so far+partitionFL' :: Commute p+             => (FORALL(u v) p C(u v) -> Bool)+             -> RL p C(x z)  -- the "right" patches found so far+             -> FL p C(z y)+             -> (FL p :> FL p) C(x y)++partitionFL keepleft ps = partitionFL' keepleft NilRL ps++partitionFL' _ qs NilFL = NilFL :> reverseRL qs+partitionFL' keepleft qs (p :>: ps)+   | keepleft p,+     Just (p' :> qs') <- commuteRL (qs :> p)+       = case partitionFL' keepleft qs' ps of+         a :> b -> p' :>: a :> b+   | otherwise = partitionFL' keepleft (p :<: qs) ps++-- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary.+-- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy+-- the predicate, it goes in the "left" list.+partitionRL :: Commute p+            => (FORALL(u v) p C(u v) -> Bool)    -- ^predicate; if true we would like the patch in the "right" list+            -> RL p C(x y)                       -- ^input 'RL'+            -> (RL p :> RL p) C(x y)             -- ^"left" and "right" results++-- optimise by using an accumulating parameter to track all the "left" patches that we've found so far+partitionRL' :: Commute p+             => (FORALL(u v) p C(u v) -> Bool)+             -> RL p C(x z)+             -> FL p C(z y)   -- the "left" patches found so far+             -> (RL p :> RL p) C(x y)++partitionRL keepright ps = partitionRL' keepright ps NilFL++partitionRL' _ NilRL qs = reverseFL qs :> NilRL++partitionRL' keepright (p :<: ps) qs+   | keepright p,+     Right (qs' :> p') <- commuteFL (p :> qs)+       = case partitionRL' keepright ps qs' of+         a :> b -> a :> p' :<: b+   | otherwise = partitionRL' keepright ps (p :>: qs)++commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y)+commuteWhatWeCanFL (p :> x :>: xs) =+    case commute (p :> x) of+    Nothing -> case commuteWhatWeCanFL (x :> xs) of+               xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of+                              xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2+    Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of+                       a :> p'' :> c -> x' :>: a :> p'' :> c+commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL++commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)+commuteWhatWeCanRL = genCommuteWhatWeCanRL commute++genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b))))+                      -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)+genCommuteWhatWeCanRL com (x :<: xs :> p) =+    case com (x :> p) of+    Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of+               xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of+                              xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2'+    Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of+                       a :> p'' :> c -> a :> p'' :> x' :<: c+genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL+++removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y)+removeCommon (xs :\/: NilFL) = xs :\/: NilFL+removeCommon (NilFL :\/: xs) = NilFL :\/: xs+removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys)+    where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z)+          rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns)+          rc ms [n:>ns] = ms :\/: n:>:ns+          rc ms (_:nss) = rc ms nss+          rc _ [] = impossible -- because we already checked for NilFL case++-- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head.+--   Otherwise it returns 'Nothing'+removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z))+removeFL x xs = r x $ headPermutationsFL xs+    where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z))+          r _ [] = Nothing+          r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs+                             | otherwise = r z zss++-- | 'removeRL' is like 'removeFL' except with 'RL'+removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y))+removeRL x xs = r x $ head_permutationsRL xs+    where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y))+          r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs+                              | otherwise = r z zss+          r _ _ = Nothing++-- | 'remove_subsequenceFL' @ab abc@ returns @Just c'@ where all the patches in+--   @ab@ have been commuted out of it, if possible.  If this is not possible+--   for any reason (the set of patches @ab@ is not actually a subset of @abc@,+--   or they can't be commuted out) we return 'Nothing'.+remove_subsequenceFL :: (MyEq p, Commute p) => FL p C(a b)+                     -> FL p C(a c) -> Maybe (FL p C(b c))+remove_subsequenceFL a b | lengthFL a > lengthFL b = Nothing+                         | otherwise = rsFL a b+    where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c))+          rsFL NilFL ys = Just ys+          rsFL (x:>:xs) yys = removeFL x yys >>= remove_subsequenceFL xs++-- | 'remove_subsequenceRL' is like @remove_subsequenceFL@ except that it works+--   on 'RL'+remove_subsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc)+                     -> RL p C(a abc) -> Maybe (RL p C(a ab))+remove_subsequenceRL a b | lengthRL a > lengthRL b = Nothing+                         | otherwise = rsRL a b+    where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab))+          rsRL NilRL ys = Just ys+          rsRL (x:<:xs) yys = removeRL x yys >>= remove_subsequenceRL xs++-- | This is a minor variant of 'headPermutationsFL' with each permutation+--   is simply returned as a 'FL'+head_permutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)]+head_permutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps++-- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list+--   in which one element of @ps@ is commuted past @p@+--+--   Suppose we have a sequence of patches+--+--   >  X h a y s-t-c k+--+--   Suppose furthermore that the patch @c@ depends on @t@, which in turn+--   depends on @s@.  This function will return+--+--   > X :> h a y s t c k+--   > h :> X a y s t c k+--   > a :> X h y s t c k+--   > y :> X h a s t c k+--   > s :> X h a y t c k+--   > k :> X h a y s t c+headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)]+headPermutationsFL NilFL = []+headPermutationsFL (p:>:ps) =+    (p:>ps) : catMaybes (map (swapfirstFL.(p:>)) $ headPermutationsFL ps)+        where swapfirstFL (p1:>p2:>xs) = do p2':>p1' <- commute (p1:>p2)+                                            Just $ p2':>p1':>:xs++-- | 'head_permutationsRL' is like 'headPermutationsFL', except that we+--   operate on an 'RL' (in other words, we are pushing things to the end of a+--   patch sequence instead of to the beginning).+head_permutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)]+head_permutationsRL NilRL = []+head_permutationsRL (p:<:ps) =+    (p:<:ps) : catMaybes (map (swapfirstRL.(p:<:)) $ head_permutationsRL ps)+        where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1)+                                              Just $ p2':<:p1':<:xs+              swapfirstRL _ = Nothing++instance (MyEq p, Commute p) => MyEq (FL p) where+    a =\/= b | lengthFL a /= lengthFL b = NotEq+             | otherwise = cmpSameLength a b+             where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z)+                   cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys+                   cmpSameLength NilFL NilFL = IsEq+                   cmpSameLength _ _ = NotEq+    xs =/\= ys = reverseFL xs =/\= reverseFL ys++instance (Invert p, Commute p) => Invert (FL p) where+    invert = reverseRL . invertFL+    identity = NilFL+    sloppyIdentity NilFL = IsEq+    sloppyIdentity (x:>:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs+    sloppyIdentity _ = NotEq++instance (MyEq p, Commute p) => MyEq (RL p) where+    unsafeCompare = bug "Buggy use of unsafeCompare on RL"+    a =/\= b | lengthRL a /= lengthRL b = NotEq+             | otherwise = cmpSameLength a b+             where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w)+                   cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys+                   cmpSameLength NilRL NilRL = IsEq+                   cmpSameLength _ _ = NotEq+    xs =\/= ys = reverseRL xs =\/= reverseRL ys++instance (Commute p, Invert p) => Invert (RL p) where+    invert = reverseFL . invertRL+    identity = NilRL+    sloppyIdentity NilRL = IsEq+    sloppyIdentity (x:<:xs) | IsEq <- sloppyIdentity x = sloppyIdentity xs+    sloppyIdentity _ = NotEq
+ src/Darcs/Patch/Prim.lhs view
@@ -0,0 +1,1130 @@+%  Copyright (C) 2002-2003,2007 David Roundy+%+%  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.++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash, TypeOperators, GADTs, PatternGuards #-}++#include "gadts.h"++module Darcs.Patch.Prim+       ( Prim(..), IsConflictedPrim(IsC), ConflictState(..), showPrim,+         DirPatchType(..), FilePatchType(..),+         CommuteFunction, Perhaps(..),+         null_patch, nullP, is_null_patch,+         is_identity,+         formatFileName, FileNameFormat(..),+         adddir, addfile, binary, changepref,+         hunk, move, rmdir, rmfile, tokreplace,+         is_addfile, is_hunk, is_binary, is_setpref,+         is_similar, is_adddir, is_filepatch,+         canonize, try_to_shrink, modernizePrim,+         subcommutes, sort_coalesceFL, join,+         try_tok_internal,+         try_shrinking_inverse,+         n_fn,+         FromPrim(..), FromPrims(..), ToFromPrim(..),+         Conflict(..), Effect(..), commute_no_conflictsFL, commute_no_conflictsRL+       )+       where++import Prelude hiding ( pi )+import Control.Monad ( MonadPlus, msum, mzero, mplus )+import Data.Maybe ( isNothing )+#ifndef GADT_WITNESSES+import Data.Map ( elems, fromListWith, mapWithKey )+#endif++import ByteStringUtils ( substrPS, fromPS2Hex)+import qualified Data.ByteString as B (ByteString, length, null, head, take, concat, drop)+import qualified Data.ByteString.Char8 as BC (break, pack)++import Darcs.Patch.FileName ( FileName, fn2ps, fn2fp, fp2fn, norm_path,+                              movedirfilename, encode_white )+import Darcs.Ordered+import Darcs.Sealed ( Sealed, unseal )+import Darcs.Patch.Patchy ( Invert(..), Commute(..) )+import Darcs.Patch.Permutations () -- for Invert instance of FL+import Darcs.Show+import Darcs.Utils ( nubsort )+import Lcs ( getChanges )+import RegChars ( regChars )+import Printer ( Doc, vcat, packedString, Color(Cyan,Magenta), lineColor,+                 text, userchunk, invisibleText, invisiblePS, blueText,+                 ($$), (<+>), (<>), prefix, userchunkPS,+               )+import GHC.Base (unsafeCoerce#)+#include "impossible.h"++data Prim C(x y) where+    Move :: !FileName -> !FileName -> Prim C(x y)+    DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y)+    FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y)+    Split :: FL Prim C(x y) -> Prim C(x y)+    Identity :: Prim C(x x)+    ChangePref :: !String -> !String -> !String -> Prim C(x y)++data FilePatchType C(x y) = RmFile | AddFile+                          | Hunk !Int [B.ByteString] [B.ByteString]+                          | TokReplace !String !String !String+                          | Binary B.ByteString B.ByteString+                            deriving (Eq,Ord)++data DirPatchType C(x y) = RmDir | AddDir+                           deriving (Eq,Ord)++instance MyEq FilePatchType where+    unsafeCompare a b = a == unsafeCoerce# b++instance MyEq DirPatchType where+    unsafeCompare a b = a == unsafeCoerce# b++null_patch :: Prim C(x x)+null_patch = Identity++is_null_patch :: Prim C(x y) -> Bool+is_null_patch (FP _ (Binary x y)) = B.null x && B.null y+is_null_patch (FP _ (Hunk _ [] [])) = True+is_null_patch Identity = True+is_null_patch _ = False++nullP :: Prim C(x y) -> EqCheck C(x y)+nullP = sloppyIdentity++is_identity :: Prim C(x y) -> EqCheck C(x y)+is_identity (FP _ (Binary old new)) | old == new = unsafeCoerce# IsEq+is_identity (FP _ (Hunk _ old new)) | old == new = unsafeCoerce# IsEq+is_identity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerce# IsEq+is_identity (Move old new) | old == new = unsafeCoerce# IsEq+is_identity Identity = IsEq+is_identity _ = NotEq++-- FIXME: The following code needs to be moved.++-- | Tells you if two patches are in the same category, human-wise.+-- Currently just returns true if they are filepatches on the same+-- file.+is_similar :: Prim C(x y) -> Prim C(a b) -> Bool+is_similar (FP f _) (FP f' _) = f == f'+is_similar (DP f _) (DP f' _) = f == f'+is_similar _ _ = False++is_addfile :: Prim C(x y) -> Bool+is_addfile (FP _ AddFile) = True+is_addfile _ = False++is_adddir :: Prim C(x y) -> Bool+is_adddir (DP _ AddDir) = True+is_adddir _ = False++is_hunk :: Prim C(x y) -> Bool+is_hunk (FP _ (Hunk _ _ _)) = True+is_hunk _ = False++is_binary :: Prim C(x y) -> Bool+is_binary (FP _ (Binary _ _)) = True+is_binary _ = False++is_setpref :: Prim C(x y) -> Bool+is_setpref (ChangePref _ _ _) = True+is_setpref _ = False++addfile :: FilePath -> Prim C(x y)+rmfile :: FilePath -> Prim C(x y)+adddir :: FilePath -> Prim C(x y)+rmdir :: FilePath -> Prim C(x y)+move :: FilePath -> FilePath -> Prim C(x y)+changepref :: String -> String -> String -> Prim C(x y)+hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> Prim C(x y)+tokreplace :: FilePath -> String -> String -> String -> Prim C(x y)+binary :: FilePath -> B.ByteString -> B.ByteString -> Prim C(x y)++evalargs :: (a -> b -> c) -> a -> b -> c+evalargs f x y = (f $! x) $! y++addfile f = FP (fp2fn $ n_fn f) AddFile+rmfile f = FP (fp2fn $ n_fn f) RmFile+adddir d = DP (fp2fn $ n_fn d) AddDir+rmdir d = DP (fp2fn $ n_fn d) RmDir+move f f' = Move (fp2fn $ n_fn f) (fp2fn $ n_fn f')+changepref p f t = ChangePref p f t+hunk f line old new = evalargs FP (fp2fn $ n_fn f) (Hunk line old new)+tokreplace f tokchars old new =+    evalargs FP (fp2fn $ n_fn f) (TokReplace tokchars old new)+binary f old new = FP (fp2fn $! n_fn f) $ Binary old new++n_fn :: FilePath -> FilePath+n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f)++instance Invert Prim where+    invert Identity = Identity+    invert (FP f RmFile)  = FP f AddFile+    invert (FP f AddFile)  = FP f RmFile+    invert (FP f (Hunk line old new))  = FP f $ Hunk line new old+    invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o+    invert (FP f (Binary o n)) = FP f $ Binary n o+    invert (DP d RmDir) = DP d AddDir+    invert (DP d AddDir) = DP d RmDir+    invert (Move f f') = Move f' f+    invert (ChangePref p f t) = ChangePref p t f+    invert (Split ps) = Split $ invert ps+    identity = Identity+    sloppyIdentity Identity = IsEq+    sloppyIdentity _ = NotEq++instance Show (Prim C(x y)) where+    showsPrec d (Move fn1 fn2) = showParen (d > app_prec) $ showString "Move " .+                                 showsPrec (app_prec + 1) fn1 . showString " " .+                                 showsPrec (app_prec + 1) fn2+    showsPrec d (DP fn dp) = showParen (d > app_prec) $ showString "DP " .+                             showsPrec (app_prec + 1) fn . showString " " .+                             showsPrec (app_prec + 1) dp+    showsPrec d (FP fn fp) = showParen (d > app_prec) $ showString "FP " .+                             showsPrec (app_prec + 1) fn . showString " " .+                             showsPrec (app_prec + 1) fp+    showsPrec d (Split l) = showParen (d > app_prec) $ showString "Split " .+                            showsPrec (app_prec + 1) l+    showsPrec _ Identity = showString "Identity"+    showsPrec d (ChangePref p f t) = showParen (d > app_prec) $ showString "ChangePref " .+                                     showsPrec (app_prec + 1) p . showString " " .+                                     showsPrec (app_prec + 1) f . showString " " .+                                     showsPrec (app_prec + 1) t++instance Show2 Prim where+   showsPrec2 = showsPrec++instance Show (FilePatchType C(x y)) where+    showsPrec _ RmFile = showString "RmFile"+    showsPrec _ AddFile = showString "AddFile"+    showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new+        = showParen (d > app_prec) $ showString "Hunk " .+                                      showsPrec (app_prec + 1) line . showString " " .+                                      showsPrecC old . showString " " .+                                      showsPrecC new+       where showsPrecC [] = showString "[]"+             showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (app_prec + 1) (map B.head ss)+    showsPrec d (Hunk line old new) = showParen (d > app_prec) $ showString "Hunk " .+                                      showsPrec (app_prec + 1) line . showString " " .+                                      showsPrec (app_prec + 1) old . showString " " .+                                      showsPrec (app_prec + 1) new+    showsPrec d (TokReplace t old new) = showParen (d > app_prec) $ showString "TokReplace " .+                                         showsPrec (app_prec + 1) t . showString " " .+                                         showsPrec (app_prec + 1) old . showString " " .+                                         showsPrec (app_prec + 1) new+    -- this case may not work usefully+    showsPrec d (Binary old new) = showParen (d > app_prec) $ showString "Binary " .+                                   showsPrec (app_prec + 1) old . showString " " .+                                   showsPrec (app_prec + 1) new++instance Show (DirPatchType C(x y)) where+    showsPrec _ RmDir = showString "RmDir"+    showsPrec _ AddDir = showString "AddDir"++{-+instance Show (Prim C(x y))  where+    show p = renderString (showPrim p) ++ "\n"+-}++data FileNameFormat = OldFormat | NewFormat+formatFileName :: FileNameFormat -> FileName -> Doc+formatFileName OldFormat = packedString . fn2ps+formatFileName NewFormat = text . encode_white . fn2fp++showPrim :: FileNameFormat -> Prim C(a b) -> Doc+showPrim x (FP f AddFile) = showAddFile x f+showPrim x (FP f RmFile)  = showRmFile x f+showPrim x (FP f (Hunk line old new))  = showHunk x f line old new+showPrim x (FP f (TokReplace t old new))  = showTok x f t old new+showPrim x (FP f (Binary old new))  = showBinary x f old new+showPrim x (DP d AddDir) = showAddDir x d+showPrim x (DP d RmDir)  = showRmDir x d+showPrim x (Move f f') = showMove x f f'+showPrim _ (ChangePref p f t) = showChangePref p f t+showPrim x (Split ps)  = showSplit x ps+showPrim _ Identity = blueText "{}"++\end{code}+++\paragraph{Add file}+Add an empty file to the tree.++\verb!addfile filename!+\begin{code}+showAddFile :: FileNameFormat -> FileName -> Doc+showAddFile x f = blueText "addfile" <+> formatFileName x f+\end{code}++\paragraph{Remove file}+Delete a file from the tree.++\verb!rmfile filename!+\begin{code}+showRmFile :: FileNameFormat -> FileName -> Doc+showRmFile x f = blueText "rmfile" <+> formatFileName x f+\end{code}++\paragraph{Move}+Rename a file or directory.++\verb!move oldname newname!+\begin{code}+showMove :: FileNameFormat -> FileName -> FileName -> Doc+showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d'+\end{code}++\paragraph{Change Pref}+Change one of the preference settings.  Darcs stores a number of simple+string settings.  Among these are the name of the test script and the name+of the script that must be called prior to packing in a make dist.+\begin{verbatim}+changepref prefname+oldval+newval+\end{verbatim}+\begin{code}+showChangePref :: String -> String -> String -> Doc+showChangePref p f t = blueText "changepref" <+> text p+                    $$ userchunk f+                    $$ userchunk t+\end{code}++\paragraph{Add dir}+Add an empty directory to the tree.++\verb!adddir filename!+\begin{code}+showAddDir :: FileNameFormat -> FileName -> Doc+showAddDir x d = blueText "adddir" <+> formatFileName x d+\end{code}++\paragraph{Remove dir}+Delete a directory from the tree.++\verb!rmdir filename!+\begin{code}+showRmDir :: FileNameFormat -> FileName -> Doc+showRmDir x d = blueText "rmdir" <+> formatFileName x d+\end{code}+++\paragraph{Hunk}+Replace a hunk (set of contiguous lines) of text with a new+hunk.+\begin{verbatim}+hunk FILE LINE#+-LINE+...++LINE+...+\end{verbatim}+\begin{code}+showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc+showHunk x f line old new =+           blueText "hunk" <+> formatFileName x f <+> text (show line)+        $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))+        $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS new))+\end{code}++\paragraph{Token replace}++Replace a token with a new token.  Note that this format means that+whitespace must not be allowed within a token.  If you know of a practical+application of whitespace within a token, let me know and I may change+this.+\begin{verbatim}+replace FILENAME [REGEX] OLD NEW+\end{verbatim}+\begin{code}+showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc+showTok x f t o n = blueText "replace" <+> formatFileName x f+                                     <+> text "[" <> userchunk t <> text "]"+                                     <+> userchunk o+                                     <+> userchunk n+\end{code}++\paragraph{Binary file modification}++Modify a binary file+\begin{verbatim}+binary FILENAME+oldhex+*HEXHEXHEX+...+newhex+*HEXHEXHEX+...+\end{verbatim}+\begin{code}+showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc+showBinary x f o n =+    blueText "binary" <+> formatFileName x f+ $$ invisibleText "oldhex"+ $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex o)+ $$ invisibleText "newhex"+ $$ (vcat $ map makeprintable $ break_every 78 $ fromPS2Hex n)+     where makeprintable ps = invisibleText "*" <> invisiblePS ps++break_every :: Int -> B.ByteString -> [B.ByteString]+break_every n ps | B.length ps < n = [ps]+                 | otherwise = B.take n ps : break_every n (B.drop n ps)+\end{code}++\paragraph{Split patch [OBSOLETE!]}+A split patch is similar to a composite patch but rather than being+composed of several patches grouped together, it is created from one+patch that has been split apart, typically through a merge or+commutation.+\begin{verbatim}+(+  <put patches here> (indented two)+)+\end{verbatim}+\begin{code}+showSplit :: FileNameFormat -> FL Prim C(x y) -> Doc+showSplit x ps = blueText "("+            $$ vcat (mapFL (showPrim x) ps)+            $$ blueText ")"++commute_split :: CommuteFunction+commute_split (Split patches :< patch) =+    toPerhaps $ cs (patches :< patch) >>= sc+    where cs :: ((FL Prim) :< Prim) C(x y) -> Maybe ((Prim :< (FL Prim)) C(x y))+          cs (NilFL :< p1) = return (p1 :< NilFL)+          cs (p:>:ps :< p1) = do p1' :< p' <- commutex (p :< p1)+                                 p1'' :< ps' <- cs (ps :< p1')+                                 return (p1'' :< p':>:ps')+          sc :: (Prim :< (FL Prim)) C(x y) -> Maybe ((Prim :< Prim) C(x y))+          sc (p1 :< ps) = scFL $ p1 :< (sort_coalesceFL ps)+            where scFL :: (Prim :< (FL Prim)) C(x y)+                       -> Maybe ((Prim :< Prim) C(x y))+                  scFL (p1' :< (p :>: NilFL)) = return (p1' :< p)+                  scFL (p1' :< ps') = return (p1' :< Split ps')+commute_split _ = Unknown++try_to_shrink :: FL Prim C(x y) -> FL Prim C(x y)+try_to_shrink = mapPrimFL try_harder_to_shrink++mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y))+             -> FL Prim C(w z) -> FL Prim C(w z)+mapPrimFL f x =+#ifdef GADT_WITNESSES+                f x+#else +-- an optimisation; break the list up into independent sublists+-- and apply f to each of them+     case mapM toSimple $ mapFL id x of+     Just sx -> foldr (+>+) NilFL $ elems $+                mapWithKey (\ k p -> f (fromSimples k (p NilFL))) $+                fromListWith (flip (.)) $+                map (\ (a,b) -> (a,(b:>:))) sx+     Nothing -> f x++data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y))+                   | SCP String String String+                   deriving ( Show )++toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y))+toSimple (FP a b) = Just (a, SFP b)+toSimple (DP a AddDir) = Just (a, SDP AddDir)+toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present+toSimple (Move _ _) = Nothing+toSimple (Split _) = Nothing+toSimple Identity = Nothing+toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c)++fromSimple :: FileName -> Simple C(x y) -> Prim C(x y)+fromSimple a (SFP b) = FP a b+fromSimple a (SDP b) = DP a b+fromSimple _ (SCP a b c) = ChangePref a b c++fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y)+fromSimples a bs = mapFL_FL (fromSimple a) bs+#endif++try_harder_to_shrink :: FL Prim C(x y) -> FL Prim C(x y)+try_harder_to_shrink x = try_to_shrink2 $ maybe x id (try_shrinking_inverse x)++try_to_shrink2 :: FL Prim C(x y) -> FL Prim C(x y)+try_to_shrink2 psold =+    let ps = sort_coalesceFL psold+        ps_shrunk = shrink_a_bit ps+                    in+    if lengthFL ps_shrunk < lengthFL ps+    then try_to_shrink2 ps_shrunk+    else ps_shrunk++try_shrinking_inverse :: FL Prim C(x y) -> Maybe (FL Prim C(x y))+try_shrinking_inverse (x:>:y:>:z)+    | IsEq <- invert x =\/= y = Just z+    | otherwise = case try_shrinking_inverse (y:>:z) of+                  Nothing -> Nothing+                  Just yz' -> Just $ case try_shrinking_inverse (x:>:yz') of+                                     Nothing -> x:>:yz'+                                     Just xyz' -> xyz'+try_shrinking_inverse _ = Nothing++shrink_a_bit :: FL Prim C(x y) -> FL Prim C(x y)+shrink_a_bit NilFL = NilFL+shrink_a_bit (p:>:ps) =+    case try_one NilRL p ps of+    Nothing -> p :>: shrink_a_bit ps+    Just ps' -> ps'++try_one :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z)+        -> Maybe (FL Prim C(w z))+try_one _ _ NilFL = Nothing+try_one sofar p (p1:>:ps) =+    case coalesce (p1 :< p) of+    Just p' -> Just (reverseRL sofar +>+ p':>:NilFL +>+ ps)+    Nothing -> case commutex (p1 :< p) of+               Nothing -> Nothing+               Just (p' :< p1') -> try_one (p1':<:sofar) p' ps++-- | 'sort_coalesceFL' @ps@ coalesces as many patches in @ps@ as+--   possible, sorting the results according to the scheme defined+--   in 'comparePrim'+sort_coalesceFL :: FL Prim C(x y) -> FL Prim C(x y)+sort_coalesceFL = mapPrimFL sort_coalesceFL2++-- | The heart of "sort_coalesceFL"+sort_coalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)+sort_coalesceFL2 NilFL = NilFL+sort_coalesceFL2 (x:>:xs) | IsEq <- nullP x = sort_coalesceFL2 xs+sort_coalesceFL2 (x:>:xs) | IsEq <- is_identity x = sort_coalesceFL2 xs+sort_coalesceFL2 (x:>:xs) = either id id $ push_coalesce_patch x $ sort_coalesceFL2 xs++-- | 'push_coalesce_patch' @new ps@ is almost like @new :>: ps@ except+--   as an alternative to consing, we first try to coalesce @new@ with+--   the head of @ps@.  If this fails, we try again, using commutation+--   to push @new@ down the list until we find a place where either+--   (a) @new@ is @LT@ the next member of the list [see 'comparePrim']+--   (b) commutation fails or+--   (c) coalescing succeeds.+--   The basic principle is to coalesce if we can and cons otherwise.+--+--   As an additional optimization, push_coalesce_patch outputs a Left+--   value if it wasn't able to shrink the patch sequence at all, and+--   a Right value if it was indeed able to shrink the patch sequence.+--   This avoids the O(N) calls to lengthFL that were in the older+--   code.+--+--   Also note that push_coalesce_patch is only ever used (and should+--   only ever be used) as an internal function in in+--   sort_coalesceFL2.+push_coalesce_patch :: Prim C(x y) -> FL Prim C(y z)+                    -> Either (FL Prim C(x z)) (FL Prim C(x z))+push_coalesce_patch new NilFL = Left (new:>:NilFL)+push_coalesce_patch new ps@(p:>:ps')+    = case coalesce (p :< new) of+      Just new' | IsEq <- nullP new' -> Right ps'+                | otherwise -> Right $ either id id $ push_coalesce_patch new' ps'+      Nothing -> if comparePrim new p == LT then Left (new:>:ps)+                            else case commutex (p :< new) of+                                 Just (new' :< p') ->+                                     case push_coalesce_patch new' ps' of+                                     Right r -> Right $ either id id $+                                                push_coalesce_patch p' r+                                     Left r -> Left (p' :>: r)+                                 Nothing -> Left (new:>:ps)++is_in_directory :: FileName -> FileName -> Bool+is_in_directory d f = iid (fn2fp d) (fn2fp f)+    where iid (cd:cds) (cf:cfs)+              | cd /= cf = False+              | otherwise = iid cds cfs+          iid [] ('/':_) = True+          iid [] [] = True -- Count directory itself as being in directory...+          iid _ _ = False++data Perhaps a = Unknown | Failed | Succeeded a++instance  Monad Perhaps where+    (Succeeded x) >>= k =  k x+    Failed   >>= _      =  Failed+    Unknown  >>= _      =  Unknown+    Failed   >> _       =  Failed+    (Succeeded _) >> k  =  k+    Unknown  >> k       =  k+    return              =  Succeeded+    fail _              =  Unknown++instance  MonadPlus Perhaps where+    mzero                 = Unknown+    Unknown `mplus` ys    = ys+    Failed  `mplus` _     = Failed+    (Succeeded x) `mplus` _ = Succeeded x++toMaybe :: Perhaps a -> Maybe a+toMaybe (Succeeded x) = Just x+toMaybe _ = Nothing++toPerhaps :: Maybe a -> Perhaps a+toPerhaps (Just x) = Succeeded x+toPerhaps Nothing = Failed++clever_commute :: CommuteFunction -> CommuteFunction+clever_commute c (p1:<p2) =+    case c (p1 :< p2) of+    Succeeded x -> Succeeded x+    Failed -> Failed+    Unknown -> case c (invert p2 :< invert p1) of+               Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')+               Failed -> Failed+               Unknown -> Unknown+--clever_commute c (p1,p2) = c (p1,p2) `mplus`+--    (case c (invert p2,invert p1) of+--     Succeeded (p1', p2') -> Succeeded (invert p2', invert p1')+--     Failed -> Failed+--     Unknown -> Unknown)++speedy_commute :: CommuteFunction+speedy_commute (p1 :< p2) -- Deal with common case quickly!+    | p1_modifies /= Nothing && p2_modifies /= Nothing &&+      p1_modifies /= p2_modifies = Succeeded (unsafeCoerce# p2 :< unsafeCoerce# p1)+    | otherwise = Unknown+    where p1_modifies = is_filepatch p1+          p2_modifies = is_filepatch p2++everything_else_commute :: CommuteFunction+everything_else_commute x = eec x+    where+    eec :: CommuteFunction+    eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerce# p1 :< ChangePref p f t)+    eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerce# p2)+    eec (Identity :< p1) = Succeeded (p1 :< Identity)+    eec (p2 :< Identity) = Succeeded (Identity :< p2)+    eec xx =+        msum [+              clever_commute commute_filedir                xx+             ,clever_commute commute_split                  xx+             ]++{-+Note that it must be true that++commutex (A^-1 A, P) = Just (P, A'^-1 A')++and++if commutex (A, B) == Just (B', A')+then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1)+-}++instance Commute Prim where+    merge (y :\/: z) =+        case elegant_merge (y:\/:z) of+        Just (z' :/\: y') -> z' :/\: y'+        Nothing -> error "Commute Prim merge"+    commutex x = toMaybe $ msum [speedy_commute x,+                                 everything_else_commute x+                                ]+    -- Recurse on everything, these are potentially spoofed patches+    list_touched_files (Move f1 f2) = map fn2fp [f1, f2]+    list_touched_files (Split ps) = nubsort $ concat $ mapFL list_touched_files ps+    list_touched_files (FP f _) = [fn2fp f]+    list_touched_files (DP d _) = [fn2fp d]+    list_touched_files (ChangePref _ _ _) = []+    list_touched_files Identity = []++is_filepatch :: Prim C(x y) -> Maybe FileName+is_filepatch (FP f _) = Just f+is_filepatch _ = Nothing++is_superdir :: FileName -> FileName -> Bool+is_superdir d1 d2 = isd (fn2fp d1) (fn2fp d2)+    where isd s1 s2 =+              length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"++commute_filedir :: CommuteFunction+commute_filedir (FP f1 p1 :< FP f2 p2) =+  if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerce# p2) :< FP f1 (unsafeCoerce# p1) )+  else commuteFP f1 (p1 :< p2)+commute_filedir (DP d1 p1 :< DP d2 p2) =+  if (not $ is_in_directory d1 d2) && (not $ is_in_directory d2 d1) &&+     d1 /= d2+  then Succeeded ( DP d2 (unsafeCoerce# p2) :< DP d1 (unsafeCoerce# p1) )+  else Failed+commute_filedir (DP d dp :< FP f fp) =+    if not $ is_in_directory d f+    then Succeeded (FP f (unsafeCoerce# fp) :< DP d (unsafeCoerce# dp))+    else Failed++commute_filedir (Move d d' :< FP f2 p2)+    | f2 == d' = Failed+    | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed+    | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerce# p2) :< Move d d')+commute_filedir (Move d d' :< DP d2 p2)+    | is_superdir d2 d' || is_superdir d2 d = Failed+    | (p2 == AddDir || p2 == RmDir) && d == d2 = Failed+    | d2 == d' = Failed+    | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerce# p2) :< Move d d')+commute_filedir (Move d d' :< Move f f')+    | f == d' || f' == d = Failed+    | f == d || f' == d' = Failed+    | d `is_superdir` f && f' `is_superdir` d' = Failed+    | otherwise =+        Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :<+                   Move (movedirfilename f' f d) (movedirfilename f' f d'))++commute_filedir _ = Unknown++type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y))+subcommutes :: [(String, CommuteFunction)]+subcommutes =+    [("speedy_commute", speedy_commute),+     ("commute_filedir", clever_commute commute_filedir),+     ("commute_filepatches", clever_commute commute_filepatches),+     ("commutex", toPerhaps . commutex)+    ]++elegant_merge :: (Prim :\/: Prim) C(x y)+              -> Maybe ((Prim :/\: Prim) C(x y))+elegant_merge (p1 :\/: p2) =+    do p1':>ip2' <- commute (invert p2 :> p1)+       -- The following should be a redundant check+       p1o:>_ <- commute (p2 :> p1')+       IsEq <- return $ p1o =\/= p1+       return (invert ip2' :/\: p1')+\end{code}++It can sometimes be handy to have a canonical representation of a given+patch.  We achieve this by defining a canonical form for each patch type,+and a function ``{\tt canonize}'' which takes a patch and puts it into+canonical form.  This routine is used by the diff function to create an+optimal patch (based on an LCS algorithm) from a simple hunk describing the+old and new version of a file.+\begin{code}+canonize :: Prim C(x y) -> FL Prim C(x y)+canonize (Split ps) = sort_coalesceFL ps+canonize p | IsEq <- is_identity p = NilFL+canonize (FP f (Hunk line old new)) = canonizeHunk f line old new+canonize p = p :>: NilFL+\end{code}++A simpler, faster (and more generally useful) cousin of canonize is the+coalescing function.  This takes two sequential patches, and tries to turn+them into one patch.  This function is used to deal with ``split'' patches,+which are created when the commutation of a primitive patch can only be+represented by a composite patch.  In this case the resulting composite+patch must return to the original primitive patch when the commutation is+reversed, which a split patch accomplishes by trying to coalesce its+contents each time it is commuted.++\begin{code}+-- | 'coalesce' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single+--   patch without intermediary changes.  For example, two hunk patches+--   modifying adjacent lines can be coalesced into a bigger hunk patch.+--   Or a patch which moves file A to file B can be coalesced with a+--   patch that moves file B into file C, yielding a patch that moves+--   file A to file C.+coalesce :: (Prim :< Prim) C(x y) -> Maybe (Prim C(x y))+coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing+coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just null_patch+coalesce (FP f1 p1 :< FP _ p2) = coalesceFilePrim f1 (p1 :< p2) -- f1 = f2+coalesce (Identity :< p) = Just p+coalesce (p :< Identity) = Just p+coalesce (Split NilFL :< p) = Just p+coalesce (p :< Split NilFL) = Just p+coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b+coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile+coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir+coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile+coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir+coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1+coalesce _ = Nothing++join :: (Prim :> Prim) C(x y) -> Maybe (Prim C(x y))+join (x :> y) = coalesce (y :< x)+\end{code}++\subsection{File patches}++A file patch is a patch which only modifies a single+file.  There are some rules which can be made about file patches in+general, which makes them a handy class.+For example, commutation of two filepatches is trivial if they modify+different files.  If they happen to+modify the same file, we'll have to check whether or not they commutex.+\begin{code}+commute_filepatches :: CommuteFunction+commute_filepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2)+commute_filepatches _ = Unknown++commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y)+          -> Perhaps ((Prim :< Prim) C(x y))+commuteFP f (Hunk line1 [] [] :< p2) =+    seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] []))+commuteFP f (p2 :< Hunk line1 [] []) =+    seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2))+commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $+  toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)+commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $+    case try_tok_replace t o n old2 of+    Nothing -> Failed+    Just old2' ->+      case try_tok_replace t o n new2 of+      Nothing -> Failed+      Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :<+                               FP f (TokReplace t o n))+commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2)+    | seq f $ t /= t2 = Failed+    | o == o2 = Failed+    | n == o2 = Failed+    | o == n2 = Failed+    | n == n2 = Failed+    | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :<+                             FP f (TokReplace t o n))+commuteFP _ _ = Unknown++coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y)+                  -> Maybe (Prim C(x y))+coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)+    = coalesceHunk f line1 old1 new1 line2 old2 new2+-- Token replace patches operating right after (or before) AddFile (RmFile)+-- is an identity patch, as far as coalescing is concerned.+coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile+coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile+coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2)+    | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1+coalesceFilePrim f (Binary m n :< Binary o m')+    | m == m' = Just $ FP f $ Binary o n+coalesceFilePrim _ _ = Nothing+\end{code}++\subsection{Hunks}++The hunk is the simplest patch that has a commuting pattern in which the+commuted patches differ from the originals (rather than simple success or+failure).  This makes commuting or merging two hunks a tad tedious.+\begin{code}+commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y)+            -> Maybe ((Prim :< Prim) C(x y))+commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1)+  | seq f $ line1 + lengthnew1 < line2 =+      Just (FP f (Hunk line1 old1 new1) :<+            FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2))+  | line2 + lengthold2 < line1 =+      Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1) :<+            FP f (Hunk line2 old2 new2))+  | line1 + lengthnew1 == line2 &&+    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =+      Just (FP f (Hunk line1 old1 new1) :<+            FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2))+  | line2 + lengthold2 == line1 &&+    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =+      Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1) :<+            FP f (Hunk line2 old2 new2))+  | otherwise = seq f Nothing+  where lengthnew1 = length new1+        lengthnew2 = length new2+        lengthold1 = length old1+        lengthold2 = length old2+commuteHunk _ _ = impossible+\end{code}+Hunks, of course, can be coalesced if they have any overlap.  Note that+coalesce code doesn't check if the two patches are conflicting.  If you are+coalescing two conflicting hunks, you've already got a bug somewhere.++\begin{code}+coalesceHunk :: FileName+             -> Int -> [B.ByteString] -> [B.ByteString]+             -> Int -> [B.ByteString] -> [B.ByteString]+             -> Maybe (Prim C(x y))+coalesceHunk f line1 old1 new1 line2 old2 new2+    | line1 == line2 && lengthold1 < lengthnew2 =+        if take lengthold1 new2 /= old1+        then Nothing+        else case drop lengthold1 new2 of+        extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew)))+    | line1 == line2 && lengthold1 > lengthnew2 =+        if take lengthnew2 old1 /= new2+        then Nothing+        else case drop lengthnew2 old1 of+        extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1))+    | line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1))+                       else Nothing+    | line1 < line2 && lengthold1 >= line2 - line1 =+        case take (line2 - line1) old1 of+        extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2)+    | line1 > line2 && lengthnew2 >= line1 - line2 =+        case take (line1 - line2) new2 of+        extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2+    | otherwise = Nothing+    where lengthold1 = length old1+          lengthnew2 = length new2+\end{code}++One of the most important pieces of code is the canonization of a hunk,+which is where the ``diff'' algorithm is performed.  This algorithm begins+with chopping off the identical beginnings and endings of the old and new+hunks.  This isn't strictly necessary, but is a good idea, since this+process is $O(n)$, while the primary diff algorithm is something+considerably more painful than that\ldots\ actually the head would be dealt+with all right, but with more space complexity.  I think it's more+efficient to just chop the head and tail off first.++\begin{code}+canonizeHunk :: FileName -> Int+             -> [B.ByteString] -> [B.ByteString] -> FL Prim C(x y)+canonizeHunk f line old new+    | null old || null new+        = FP f (Hunk line old new) :>: NilFL+canonizeHunk f line old new = make_holey f line $ getChanges old new++make_holey :: FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]+           -> FL Prim C(x y)+make_holey f line changes =+    unsafeMap_l2f (\ (l,o,n) -> FP f (Hunk (l+line) o n)) changes+        +try_tok_replace :: String -> String -> String+                -> [B.ByteString] -> Maybe [B.ByteString]+try_tok_replace t o n mss =+  mapM (fmap B.concat . try_tok_internal t (BC.pack o) (BC.pack n)) mss+++try_tok_internal :: String -> B.ByteString -> B.ByteString+                 -> B.ByteString -> Maybe [B.ByteString]+try_tok_internal _ o n s | isNothing (substrPS o s) &&+                           isNothing (substrPS n s) = Just [s]+try_tok_internal t o n s =+    case BC.break (regChars t) s of+    (before,s') ->+        case BC.break (not . regChars t) s' of+        (tok,after) ->+            case try_tok_internal t o n after of+            Nothing -> Nothing+            Just rest ->+                if tok == o+                then Just $ before : n : rest+                else if tok == n+                     then Nothing+                     else Just $ before : tok : rest++modernizePrim :: Prim C(x y) -> FL Prim C(x y)+modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps+modernizePrim p = p :>: NilFL++instance MyEq Prim where+    unsafeCompare (Move a b) (Move c d) = a == c && b == d+    unsafeCompare (DP d1 p1) (DP d2 p2)+        = d1 == d2 && p1 `unsafeCompare` p2 +    unsafeCompare (FP f1 fp1) (FP f2 fp2)+        = f1 == f2 && fp1 `unsafeCompare` fp2+    unsafeCompare (Split ps1) (Split ps2)+        = eq_FL unsafeCompare ps1 ps2+    unsafeCompare (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)+        = c1 == c2 && b1 == b2 && a1 == a2+    unsafeCompare Identity Identity = True+    unsafeCompare _ _ = False++merge_orders :: Ordering -> Ordering -> Ordering+merge_orders EQ x = x+merge_orders LT _ = LT+merge_orders GT _ = GT++-- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between+--   @p1@ and @p2@.  Basically, identical patches are equal and+--   @Move < DP < FP < Split < Identity < ChangePref@.+--   Everything else is compared in dictionary order of its arguments.+comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering+comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)+comparePrim (Move _ _) _ = LT+comparePrim _ (Move _ _) = GT+comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)+comparePrim (DP _ _) _ = LT+comparePrim _ (DP _ _) = GT+comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2)+comparePrim (FP _ _) _ = LT+comparePrim _ (FP _ _) = GT+comparePrim (Split ps1) (Split ps2) = compare_FL comparePrim ps1 $ unsafeCoerceP ps2+comparePrim (Split _) _ = LT+comparePrim _ (Split _) = GT+comparePrim Identity Identity = EQ+comparePrim Identity _ = LT+comparePrim _ Identity = GT+comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)+ = compare (c1, b1, a1) (c2, b2, a2)++eq_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Bool)+      -> FL a C(x y) -> FL a C(w z) -> Bool+eq_FL _ NilFL NilFL = True+eq_FL f (x:>:xs) (y:>:ys) = f x y && eq_FL f xs ys+eq_FL _ _ _ = False++compare_FL :: (FORALL(b c d e) a C(b c) -> a C(d e) -> Ordering)+           -> FL a C(x y) -> FL a C(w z) -> Ordering+compare_FL _ NilFL NilFL = EQ+compare_FL _ NilFL _     = LT+compare_FL _ _     NilFL = GT+compare_FL f (x:>:xs) (y:>:ys) = f x y `merge_orders` compare_FL f xs ys+                                   ++class FromPrim p where+   fromPrim :: Prim C(x y) -> p C(x y)++class FromPrim p => ToFromPrim p where+    toPrim :: p C(x y) -> Maybe (Prim C(x y))++class FromPrims p where+    fromPrims :: FL Prim C(x y) -> p C(x y)+    joinPatches :: FL p C(x y) -> p C(x y)++instance FromPrim Prim where+    fromPrim = id+instance ToFromPrim Prim where+    toPrim = Just . id++instance FromPrim p => FromPrims (FL p) where+    fromPrims = mapFL_FL fromPrim+    joinPatches = concatFL+instance FromPrim p => FromPrims (RL p) where+    fromPrims = reverseFL . mapFL_FL fromPrim+    joinPatches = concatRL . reverseFL++class (Invert p, Commute p, Effect p) => Conflict p where+    list_conflicted_files :: p C(x y) -> [FilePath]+    list_conflicted_files p =+        nubsort $ concatMap (unseal list_touched_files) $ concat $ resolve_conflicts p+    resolve_conflicts :: p C(x y) -> [[Sealed (FL Prim C(y))]]+    resolve_conflicts _ = []+    -- | If 'commute_no_conflicts' @x :> y@ succeeds, we know that that @x@ commutes+    --   past @y@ without any conflicts.   This function is useful for patch types+    --   for which 'commute' is defined to always succeed; so we need some way to+    --   pick out the specific cases where commutation succeeds without any conflicts.+    --+    --   Consider the commute square with patch names written in capital letters and+    --   repository states written in small letters.+    --+    --   @+    --          X+    --       o-->--a+    --       |     |+    --    Y' v     v Y+    --       |     |+    --       z-->--b+    --          X'+    --   @+    --+    --   The default definition of this function checks that we can mirror the+    --   commutation with patch inverses (written with the negative sign)+    --+    --   @+    --         -X     X+    --       a-->--o-->--a+    --       |     |     |+    --   Y'' v  Y' v     v Y+    --       |     |     |+    --       b-->--z-->--b+    --         (-X)'  X'+    --   @+    --+    --+    --   We check that commuting @X@ and @Y@ succeeds, as does commuting @-X@ and @Y'@.+    --   It also checks that @Y'' == Y@ and that @-(X')@ is the same as @(-X)'@+    commute_no_conflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))+    commute_no_conflicts (x:>y) =+        do y':>x' <- commute (x:>y)+           y'':>ix'' <- commute (invert x :> y')+           IsEq <- return $ y'' =\/= y+           IsEq <- return $ ix'' =\/= invert x'+           return (y':>x')+    conflictedEffect :: p C(x y) -> [IsConflictedPrim]+    conflictedEffect x = case list_conflicted_files x of+                         [] -> mapFL (IsC Okay) $ effect x+                         _ -> mapFL (IsC Conflicted) $ effect x++instance Conflict p => Conflict (FL p) where+    list_conflicted_files = nubsort . concat . mapFL list_conflicted_files+    resolve_conflicts NilFL = []+    resolve_conflicts x = resolve_conflicts $ reverseFL x+    commute_no_conflicts (NilFL :> x) = Just (x :> NilFL)+    commute_no_conflicts (x :> NilFL) = Just (NilFL :> x)+    commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (reverseFL xs :> ys)+                                         return $ ys' :> reverseRL rxs'+    conflictedEffect = concat . mapFL conflictedEffect++instance Conflict p => Conflict (RL p) where+    list_conflicted_files = nubsort . concat . mapRL list_conflicted_files+    resolve_conflicts x = rcs x NilFL+        where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL Prim C(w))]]+              rcs NilRL _ = []+              rcs (p:<:ps) passedby | (_:_) <- resolve_conflicts p =+                  case commute_no_conflictsFL (p:>passedby) of+                    Just (_:> p') -> resolve_conflicts p' ++ rcs ps (p:>:passedby)+                    Nothing -> rcs ps (p:>:passedby)+              rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby)+    commute_no_conflicts (NilRL :> x) = Just (x :> NilRL)+    commute_no_conflicts (x :> NilRL) = Just (NilRL :> x)+    commute_no_conflicts (xs :> ys) = do ys' :> rxs' <- commute_no_conflictsRLFL (xs :> reverseRL ys)+                                         return $ reverseFL ys' :> rxs'+    conflictedEffect = concat . reverse . mapRL conflictedEffect++data IsConflictedPrim where+    IsC :: !ConflictState -> !(Prim C(x y)) -> IsConflictedPrim+data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)++-- | Patches whose concrete effect which can be expressed as a list of+--   primitive patches.+--+--   A minimal definition would be either of @effect@ or @effectRL@.+class Effect p where+    effect :: p C(x y) -> FL Prim C(x y)+    effect = reverseRL . effectRL+    effectRL :: p C(x y) -> RL Prim C(x y)+    effectRL = reverseFL . effect+    isHunk :: p C(x y) -> Maybe (Prim C(x y))+    isHunk _ = Nothing++instance Effect Prim where+    effect p | IsEq <- sloppyIdentity p = NilFL+             | otherwise = p :>: NilFL+    effectRL p | IsEq <- sloppyIdentity p = NilRL+               | otherwise = p :<: NilRL+    isHunk p = if is_hunk p then Just p else Nothing++instance Conflict Prim++instance Effect p => Effect (FL p) where+    effect p = concatFL $ mapFL_FL effect p+    effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p++instance Effect p => Effect (RL p) where+    effect p = concatFL $ mapFL_FL effect $ reverseRL p+    effectRL p = concatRL $ mapRL_RL effectRL p++commute_no_conflictsFL :: Conflict p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))+commute_no_conflictsFL (p :> NilFL) = Just (NilFL :> p)+commute_no_conflictsFL (q :> p :>: ps) = do p' :> q' <- commute_no_conflicts (q :> p)+                                            ps' :> q'' <- commute_no_conflictsFL (q' :> ps)+                                            return (p' :>: ps' :> q'')++commute_no_conflictsRL :: Conflict p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))+commute_no_conflictsRL (NilRL :> p) = Just (p :> NilRL)+commute_no_conflictsRL (p :<: ps :> q) = do q' :> p' <- commute_no_conflicts (p :> q)+                                            q'' :> ps' <- commute_no_conflictsRL (ps :> q')+                                            return (q'' :> p' :<: ps')++commute_no_conflictsRLFL :: Conflict p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))+commute_no_conflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)+commute_no_conflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)+commute_no_conflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commute_no_conflictsRL (xs :> y)+                                               ys' :> xs'' <- commute_no_conflictsRLFL (xs' :> ys)+                                               return (y' :>: ys' :> xs'')++\end{code}
+ src/Darcs/Patch/Properties.lhs view
@@ -0,0 +1,357 @@+%  Copyright (C) 2007 David Roundy+%+%  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.++\documentclass{article}+%\usepackage{color}++\usepackage{verbatim}+\usepackage{html}+\usepackage{fancyvrb}+\newenvironment{code}{\comment}{\endcomment}+% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}++\newcommand{\commutes}{\longleftrightarrow}++\begin{document}++\begin{code}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}++#include "gadts.h"++module Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity,+                                identity_commutes, inverse_doesnt_commute,+                                patch_and_inverse_commute, merge_either_way,+                                show_read,+                                merge_commute, merge_consistent, merge_arguments_consistent,+                                join_inverses, join_commute ) where++import Control.Monad ( msum, mplus )+import Darcs.Show ( Show2(..) )+import Darcs.Patch.Patchy+import Darcs.Patch.Prim+import Darcs.Patch ()+import Darcs.Patch.Read ( readPatch )+import Darcs.Ordered+import Darcs.Sealed ( Sealed(Sealed) )+import Printer ( Doc, renderPS, redText, greenText, ($$) )+--import Darcs.ColorPrinter ( traceDoc )+\end{code}++\section{Patch properties}++Darcs is built on a hierarchy of patch types.  At the lowest level are+``primitive'' patches, and from these building blocks, a whole hierarchy of+patch types are built.  Each of these patch types must support a number of+functions, which must obey a number of laws.++\subsection{Properties of identity}++\newtheorem{prp}{Property}++\begin{prp}[Identity commutes trivially]+  The identity patch must commute with any patch without modifying said patch.+\end{prp}++\begin{code}+identity_commutes :: forall p C(x y). Patchy p => p C(x y) -> Maybe Doc+identity_commutes p = case commute (p :> identity) of+                      Nothing -> Just $ redText "identity_commutes failed:" $$ showPatch p+                      Just (i :> p') | IsEq <- i =\/= identity,+                                       IsEq <- p' =\/= p ->+                              checkRightIdentity $ commute $ identity :> p+                      Just _ -> Just $ greenText "identity_commutes"+  where checkRightIdentity :: Maybe ((p :> p) C(x y)) -> Maybe Doc+        checkRightIdentity Nothing = Just $ redText "identity_commutes failed 2:" $$ showPatch p+        checkRightIdentity (Just (p2 :> i2)) | IsEq <- i2 =\/= identity,+                                               IsEq <- p2 =\/= p = Nothing+        checkRightIdentity (Just _) = Just $ greenText "identity_commutes 2"+\end{code}++\begin{prp}[Inverse doesn't commute]+  A patch and its inverse will always commute, unless that patch is an+  identity patch (or an identity-like patch that has no effect).+\end{prp}++\begin{code}+inverse_doesnt_commute :: Patchy p => p C(a b) -> Maybe Doc+inverse_doesnt_commute p | IsEq <- sloppyIdentity p = Nothing+                         | otherwise = do p' :> _ <- commute (invert p :> p)+                                          Just $ redText "inverse_doesnt_commute" $$ showPatch p'+\end{code}++\subsection{Commute properties}++\begin{prp}[Recommute]+  $AB \commutes B'A'$ if and only if $B'A' \commutes AB$+\end{prp}++\begin{code}+recommute :: Patchy p => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y))))+          -> (p :> p) C(a b) -> Maybe Doc+recommute c (x :> y) =+    case c (x :> y) of+    Nothing -> Nothing+    Just (y' :> x') ->+       case c (y' :> x') of+         Nothing -> Just (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x')+         Just (x'' :> y'') ->+             case y'' =/\= y of+             NotEq -> Just (redText "y'' =/\\= y failed, where x" $$ showPatch x $$+                            redText ":> y" $$ showPatch y $$+                            redText "y'" $$ showPatch y' $$+                            redText ":> x'" $$ showPatch x' $$+                            redText "x''" $$ showPatch x'' $$+                            redText ":> y''" $$ showPatch y'')+             IsEq -> case x'' =/\= x of+                     NotEq -> Just (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'')+                     IsEq -> Nothing+\end{code}++\begin{prp}[Commute inverses]+  $AB \commutes B'A'$ if and only if $B^{-1}A^{-1} \commutes A'^{-1}B'^{-1}$+\end{prp}++\begin{code}+commute_inverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))+                 -> (p :> p) C(a b) -> Maybe Doc+commute_inverses c (x :> y) =+    case c (x :> y) of+    Nothing -> Nothing+    Just (y' :> x') ->+        case c (invert y :> invert x) of+        Nothing -> Just $ redText "second commute failed" $$+                   redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$+                   redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x'+        Just (ix' :> iy') ->+            case invert ix' =/\= x' of+            NotEq -> Just $ redText "invert ix' /= x'" $$+                     redText "x" $$ showPatch x $$+                     redText "y" $$ showPatch y $$+                     redText "y'" $$ showPatch y' $$+                     redText "x'" $$ showPatch x' $$+                     redText "ix'" $$ showPatch ix' $$+                     redText "iy'" $$ showPatch iy' $$+                     redText "invert ix'" $$ showPatch (invert ix') $$+                     redText "invert iy'" $$ showPatch (invert iy')+            IsEq -> case y' =\/= invert iy' of+                    NotEq -> Just $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y'+                    IsEq -> Nothing+\end{code}++\begin{prp}[Patch and inverse]+  If $AB \commutes B'A'$ then $A^{-1}B' \commutes BA'^{-1}$+\end{prp}++This property is only true of primitive patches.++\begin{code}+patch_and_inverse_commute :: Patchy p =>+                             (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))+                          -> (p :> p) C(a b) -> Maybe Doc+patch_and_inverse_commute c (x :> y) =+  do y' :> x' <- c (x :> y)+     case c (invert x :> y') of+       Nothing -> Just (redText "failure in patch_and_inverse_commute")+       Just (y'' :> ix') ->+           case y'' =\/= y of+           NotEq -> Just (redText "y'' /= y" $$+                          redText "x" $$ showPatch x $$+                          redText "y" $$ showPatch y $$+                          redText "x'" $$ showPatch x' $$+                          redText "y'" $$ showPatch y' $$+                          redText "y''" $$ showPatch y'' $$+                          redText ":> x'" $$ showPatch x')+           IsEq -> case x' =\/= invert ix' of+                   NotEq -> Just (redText "x' /= invert ix'" $$+                                  redText "y''" $$ showPatch y'' $$+                                  redText ":> x'" $$ showPatch x' $$+                                  redText "invert x" $$ showPatch (invert x) $$+                                  redText ":> y" $$ showPatch y $$+                                  redText "y'" $$ showPatch y' $$+                                  redText "ix'" $$ showPatch ix')+                   IsEq -> Nothing+\end{code}++\begin{prp}[Permutivity]+  (to be added...)+\end{prp}++\begin{code}+permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))+            -> (p :> p :> p) C(a b) -> Maybe Doc+permutivity c (x:>y:>z) =+  do y1 :> x1 <- c (x :> y)+     z2 :> y2 <- --traceDoc (greenText "first commuted") $+                 c (y :> z)+     z3 :> x3 <- --traceDoc (greenText "second commuted") $+                 c (x :> z2)+     case c (x1 :> z) of+       Nothing -> Just $ redText "permutivity1"+       Just (z4 :> x4) ->+         --traceDoc (greenText "third commuted" $$+         --          greenText "about to commute" $$+         --          greenText "y1" $$ showPatch y1 $$+         --          greenText "z4" $$ showPatch z4) $+         case c (y1 :> z4) of+         Nothing -> Just $ redText "permutivity2"+         Just (z3_ :> y4)+             | IsEq <- z3_ =\/= z3 ->+                  --traceDoc (greenText "passed z3") $ error "foobar test" $+                  case c (y4 :> x4) of+                  Nothing -> Just $ redText "permutivity5: input was" $$+                             redText "x" $$ showPatch x $$+                             redText "y" $$ showPatch y $$+                             redText "z" $$ showPatch z $$+                             redText "z3" $$ showPatch z3 $$+                             redText "failed commute of" $$+                             redText "y4" $$ showPatch y4 $$+                             redText "x4" $$ showPatch x4 $$+                             redText "whereas commute of x and y give" $$+                             redText "y1" $$ showPatch y1 $$+                             redText "x1" $$ showPatch x1+                  Just (x3_ :> y2_)+                       | NotEq <- x3_ =\/= x3 -> Just $ redText "permutivity6"+                       | NotEq <- y2_ =/\= y2 -> Just $ redText "permutivity7"+                       | otherwise -> Nothing+             | otherwise ->+                 Just $ redText "permutivity failed" $$+                        redText "z3" $$ showPatch z3 $$+                        redText "z3_" $$ showPatch z3_++partial_permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))+                    -> (p :> p :> p) C(a b) -> Maybe Doc+partial_permutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) `mplus` pp (invert zz:>invert yy:>invert xx)+    where pp (x:>y:>z) = do z1 :> y1 <- c (y :> z)+                            _ :> x1 <- c (x :> z1)+                            case c (x :> y) of+                              Just _ -> Nothing -- this is covered by full permutivity test above+                              Nothing ->+                                  case c (x1 :> y1) of+                                  Nothing -> Nothing+                                  Just _ -> Just $ greenText "partial_permutivity error" $$+                                            greenText "x" $$ showPatch x $$+                                            greenText "y" $$ showPatch y $$+                                            greenText "z" $$ showPatch z++merge_arguments_consistent :: Patchy p =>+                              (FORALL(x y) p C(x y) -> Maybe Doc)+                           -> (p :\/: p) C(a b) -> Maybe Doc+merge_arguments_consistent is_consistent (x :\/: y) =+    msum [(\z -> redText "merge_arguments_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x,+          (\z -> redText "merge_arguments_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y]++merge_consistent :: Patchy p =>+                           (FORALL(x y) p C(x y) -> Maybe Doc)+                        -> (p :\/: p) C(a b) -> Maybe Doc+merge_consistent is_consistent (x :\/: y) =+    case merge (x :\/: y) of+    y' :/\: x' ->+        msum [(\z -> redText "merge_consistent x" $$ showPatch x $$ z) `fmap` is_consistent x,+              (\z -> redText "merge_consistent y" $$ showPatch y $$ z) `fmap` is_consistent y,+              (\z -> redText "merge_consistent x'" $$ showPatch x' $$ z $$+                     redText "where x' comes from x" $$ showPatch x $$+                     redText "and y" $$ showPatch y) `fmap` is_consistent x',+              (\z -> redText "merge_consistent y'" $$ showPatch y' $$ z) `fmap` is_consistent y']++merge_either_way :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc+merge_either_way (x :\/: y) =+    case merge (x :\/: y) of+    y' :/\: x' -> case merge (y :\/: x) of+                  x'' :/\: y'' | IsEq <- x'' =\/= x',+                                 IsEq <- y'' =\/= y' -> Nothing+                               | otherwise -> Just $ redText "merge_either_way bug"++merge_commute :: Patchy p => (p :\/: p) C(x y) -> Maybe Doc+merge_commute (x :\/: y) =+    case merge (x :\/: y) of+    y' :/\: x' ->+        case commute (x :> y') of+        Nothing -> Just $ redText "merge_commute 1" $$+                   redText "x" $$ showPatch x $$+                   redText "y" $$ showPatch y $$+                   redText "x'" $$ showPatch x' $$+                   redText "y'" $$ showPatch y'+        Just (y_ :> x'_)+            | IsEq <- y_ =\/= y,+              IsEq <- x'_ =\/= x' ->+                      case commute (y :> x') of+                      Nothing -> Just $ redText "merge_commute 2 failed" $$+                                 redText "x" $$ showPatch x $$+                                 redText "y" $$ showPatch y $$+                                 redText "x'" $$ showPatch x' $$+                                 redText "y'" $$ showPatch y'+                      Just (x_ :> y'_)+                           | IsEq <- x_ =\/= x,+                             IsEq <- y'_ =\/= y' -> Nothing+                           | otherwise -> Just $ redText "merge_commute 3" $$+                                          redText "x" $$ showPatch x $$+                                          redText "y" $$ showPatch y $$+                                          redText "x'" $$ showPatch x' $$+                                          redText "y'" $$ showPatch y' $$+                                          redText "x_" $$ showPatch x_ $$+                                          redText "y'_" $$ showPatch y'_+            | otherwise -> Just $ redText "merge_commute 4" $$+                           redText "x" $$ showPatch x $$+                           redText "y" $$ showPatch y $$+                           redText "x'" $$ showPatch x' $$+                           redText "y'" $$ showPatch y' $$+                           redText "x'_" $$ showPatch x'_ $$+                           redText "y_" $$ showPatch y_++join_inverses :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y)))+              -> Prim C(a b) -> Maybe Doc+join_inverses j p = case j (invert p :> p) of+                    Just Identity -> Nothing+                    Just p' -> Just $ redText "join_inverses gave just" $$ showPatch p'+                    Nothing -> Just $ redText "join_inverses failed"++join_commute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (Prim C(x y)))+             -> (Prim :> Prim :> Prim) C(a b) -> Maybe Doc+join_commute j (a :> b :> c) =+    do x <- j (b :> c)+       case commuteFL (a :> b :>: c :>: NilFL) of+        Right (b' :>: c' :>: NilFL :> a') ->+           case commute (a :> x) of+             Nothing -> Just $ greenText "join_commute 1"+             Just (x' :> a'') ->+                 case a'' =/\= a' of+                 NotEq -> Just $ greenText "join_commute 3"+                 IsEq -> case j (b' :> c') of+                         Nothing -> Just $ greenText "join_commute 4"+                         Just x'' -> case x' =\/= x'' of+                                     NotEq -> Just $ greenText "join_commute 5"+                                     IsEq -> Nothing+        _ -> Nothing++show_read :: (Show2 p, Patchy p) => p C(a b) -> Maybe Doc+show_read p = let ps = renderPS (showPatch p)+              in case readPatch ps of+                 Nothing -> Just (redText "unable to read " $$ showPatch p)+                 Just (Sealed p',_) | IsEq <- p' =\/= p -> Nothing+                                    | otherwise -> Just $ redText "trouble reading patch p" $$+                                                          showPatch p $$+                                                          redText "reads as p'" $$+                                                          showPatch p' $$+                                                          redText "aka" $$+                                                          greenText (show2 p) $$+                                                          redText "and" $$+                                                          greenText (show2 p')+\end{code}++\end{document}
+ src/Darcs/Patch/Read.hs view
@@ -0,0 +1,255 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++module Darcs.Patch.Read ( readPrim, readPatch )+             where++import Prelude hiding ( pi )+import Control.Monad ( liftM )++#include "gadts.h"++import ByteStringUtils ( breakFirstPS, fromHex2PS, readIntPS, dropSpace )+import qualified Data.ByteString.Char8 as BC (head, unpack, dropWhile, break)+import qualified Data.ByteString       as B  (ByteString, null, init, tail, empty, concat)++import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, ps2fn, decode_white )+import Darcs.Patch.Core ( Patch(..), Named(..) )+import Darcs.Patch.Prim ( Prim(..), FileNameFormat(..),+                          DirPatchType(..), FilePatchType(..),+                          hunk, binary )+#ifndef GADT_WITNESSES+import Darcs.Patch.Commute ( merger )+import Darcs.Patch.Patchy ( invert )+#endif+import Darcs.Patch.Info ( PatchInfo, readPatchInfo )+import Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,+                               parse_strictly, peek_input, lex_string, lex_eof, my_lex)+#include "impossible.h"+import Darcs.Patch.Patchy ( ReadPatch, readPatch', bracketedFL )+import Darcs.Ordered ( FL(..) )+import Darcs.Sealed ( Sealed(..), seal, mapSeal )++readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)+readPatch ps = case parse_strictly (readPatch' False) ps of+                   Just (Just p, ps') -> Just (p, ps')+                   _ -> Nothing++instance ReadPatch p => ReadPatch (Named p) where+ readPatch' want_eof+   = do s <- peek_input+        case liftM (BC.unpack . fst) $ my_lex s of+          Just ('[':_) ->      liftM Just $ readNamed want_eof -- ]+          _ -> return Nothing++instance ReadPatch Prim where+ readPatch' w = readPrim OldFormat w++readPrim :: ParserM m => FileNameFormat -> Bool -> m (Maybe (Sealed (Prim C(x ))))+readPrim x _+   = do s <- peek_input+        case liftM (BC.unpack . fst) $ my_lex s of+          Just "{}" ->         do work my_lex+                                  return $ Just $ seal Identity+          Just "(" ->          liftM Just $ readSplit x -- )+          Just "hunk" ->       liftM (Just . seal) $ readHunk x+          Just "replace" ->    liftM (Just . seal) $ readTok x+          Just "binary" ->     liftM (Just . seal) $ readBinary x+          Just "addfile" ->    liftM (Just . seal) $ readAddFile x+          Just "adddir" ->     liftM (Just . seal) $ readAddDir x+          Just "rmfile" ->     liftM (Just . seal) $ readRmFile x+          Just "rmdir" ->      liftM (Just . seal) $ readRmDir x+          Just "move" ->       liftM (Just . seal) $ readMove x+          Just "changepref" -> liftM (Just . seal) $ readChangePref+          _ -> return Nothing++instance ReadPatch Patch where+ readPatch' want_eof+   = do mps <- bracketedFL (fromIntegral $ fromEnum '{') (fromIntegral $ fromEnum '}')+        case mps of+          Just (Sealed ps) -> return $ Just $ Sealed $ ComP ps+          Nothing -> do s <- peek_input+                        case liftM (BC.unpack . fst) $ my_lex s of+#ifndef GADT_WITNESSES+                          Just "merger" ->     liftM (Just . seal) $ readMerger True+                          Just "regrem" ->     liftM (Just . seal) $ readMerger False+#endif+                          _ -> liftM (fmap (mapSeal PP)) $ readPatch' want_eof++read_patches :: ParserM m => FileNameFormat -> String -> Bool -> m (Sealed (FL Prim C(x )))+read_patches x str want_eof+ = do mp <- readPrim x False+      case mp of+          Nothing -> do unit <- lex_string str+                        case unit of+                            () -> if want_eof then do unit' <- lex_eof+                                                      case unit' of+                                                          () -> return $ seal NilFL+                                              else return $ seal NilFL+          Just (Sealed p) -> do Sealed ps <- read_patches x str want_eof+                                return $ seal (p:>:ps)++readSplit :: ParserM m => FileNameFormat -> m (Sealed (Prim C(x )))+readSplit x = do+  work my_lex+  ps <- read_patches x ")" False+  return $ Split `mapSeal` ps++readFileName :: FileNameFormat -> B.ByteString -> FileName+readFileName OldFormat = ps2fn+readFileName NewFormat = fp2fn . decode_white . BC.unpack++readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))+readHunk x = do+  work my_lex+  fi <- work my_lex+  l <- work readIntPS+  have_nl <- skip_newline+  if have_nl+     then do work $ lines_starting_with ' ' -- skipping context+             old <- work $ lines_starting_with '-'+             new <- work $ lines_starting_with '+'+             work $ lines_starting_with ' ' -- skipping context+             return $ hunk (fn2fp $ readFileName x fi) l old new+     else return $ hunk (fn2fp $ readFileName x fi) l [] []++skip_newline :: ParserM m => m Bool+skip_newline = do s <- peek_input+                  if B.null s+                    then return False+                    else if BC.head s /= '\n'+                         then return False+                         else alter_input B.tail >> return True++readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))+readTok x = do+  work my_lex+  f <- work my_lex+  regstr <- work my_lex+  o <- work my_lex+  n <- work my_lex+  return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr))+                          (BC.unpack o) (BC.unpack n)+    where drop_brackets = B.init . B.tail+++-- * Binary file modification+--+-- | Modify a binary file+--+-- > binary FILENAME+-- > oldhex+-- > *HEXHEXHEX+-- > ...+-- > newhex+-- > *HEXHEXHEX+-- > ...+readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y))+readBinary x = do+  work my_lex+  fi <- work my_lex+  work my_lex+  alter_input dropSpace+  old <- work $ lines_starting_with '*'+  work my_lex+  alter_input dropSpace+  new <- work $ lines_starting_with '*'+  return $ binary (fn2fp $ readFileName x fi)+                  (fromHex2PS $ B.concat old)+                  (fromHex2PS $ B.concat new)++readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))+readAddFile x = do work my_lex+                   f <- work my_lex+                   return $ FP (readFileName x f) AddFile++readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))+readRmFile x = do work my_lex+                  f <- work my_lex+                  return $ FP (readFileName x f) RmFile++readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))+readMove x = do work my_lex+                d <- work my_lex+                d' <- work my_lex+                return $ Move (readFileName x d) (readFileName x d')++readChangePref :: ParserM m => m (Prim C(x y))+readChangePref+ = do work my_lex+      p <- work my_lex+      f <- work (Just . BC.break ((==)'\n') . B.tail . BC.dropWhile (== ' '))+      t <- work (Just . BC.break ((==)'\n') . B.tail)+      return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t)++readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))+readAddDir x = do work my_lex+                  f <- work my_lex+                  return $ DP (readFileName x f) AddDir++readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))+readRmDir x = do work my_lex+                 f <- work my_lex+                 return $ DP (readFileName x f) RmDir++#ifndef GADT_WITNESSES+readMerger :: ParserM m => Bool -> m (Patch C(x y))+readMerger b = do work my_lex+                  g <- work my_lex+                  lex_string "("+                  Just (Sealed p1) <- readPatch' False+                  Just (Sealed p2) <- readPatch' False+                  lex_string ")"+                  let m = merger (BC.unpack g) p1 p2+                  return $ if b then m else invert m+#endif++readNamed :: (ReadPatch p, ParserM m) => Bool -> m (Sealed (Named p C(x )))+readNamed want_eof+          = do mn <- maybe_work readPatchInfo+               case mn of+                   Nothing -> bug "readNamed 1"+                   Just n ->+                       do d <- read_depends+                          Just p <- readPatch' want_eof+                          return $ (NamedP n d) `mapSeal` p+read_depends :: ParserM m => m [PatchInfo]+read_depends = do s <- peek_input+                  case my_lex s of+                      Just (xs, _) | BC.unpack xs == "<" ->+                          do work my_lex+                             read_pis+                      _ -> return []+read_pis :: ParserM m => m [PatchInfo]+read_pis = do mpi <- maybe_work readPatchInfo+              case mpi of+                  Just pi -> do pis <- read_pis+                                return (pi:pis)+                  Nothing -> do alter_input (B.tail . BC.dropWhile (/= '>'))+                                return []++lines_starting_with :: Char -> B.ByteString -> Maybe ([B.ByteString], B.ByteString)+lines_starting_with c thes =+    Just (lsw [] thes)+    where lsw acc s | B.null s || BC.head s /= c = (reverse acc, s)+          lsw acc s = let s' = B.tail s+                  in case breakFirstPS '\n' s' of+                     Just (l, r) -> lsw (l:acc) r+                     Nothing -> (reverse (s':acc), B.empty)
+ src/Darcs/Patch/ReadMonads.hs view
@@ -0,0 +1,91 @@++module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,+                        parse_strictly, parse_lazily,+                        peek_input,+                        lex_char, lex_string, lex_strings, lex_eof,+                        my_lex) where++import ByteStringUtils ( dropSpace, breakSpace )+import qualified Data.ByteString as B (null, empty, ByteString)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++lex_char :: ParserM m => Char -> m ()+lex_char c = lex_string [c]++lex_string :: ParserM m => String -> m ()+lex_string str = work+           $ \s -> case my_lex s of+                       Just (xs, ys) | xs == BC.pack str -> Just ((), ys)+                       _ -> Nothing++lex_eof :: ParserM m => m ()+lex_eof = work+        $ \s -> if B.null (dropSpace s)+                then Just ((), B.empty)+                else Nothing++lex_strings :: ParserM m => [String] -> m String+lex_strings str =+    work $ \s ->+    case my_lex s of+    Just (xs, ys) | xs' `elem` str -> Just (xs', ys)+        where xs' = BC.unpack xs+    _ -> Nothing++my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString)+my_lex s = let s' = dropSpace s+           in if B.null s'+              then Nothing+              else Just $ breakSpace s'++alter_input :: ParserM m+            => (B.ByteString -> B.ByteString) -> m ()+alter_input f = work (\s -> Just ((), f s))++class Monad m => ParserM m where+    work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a+    maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a)+    peek_input :: m B.ByteString++----- Strict Monad -----+parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)+parse_strictly (SM f) s = f s++newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString))+instance Monad SM where+    SM m >>= k = SM $ \s -> case m s of+                                Nothing -> Nothing+                                Just (x, s') ->+                                    case k x of+                                        SM y -> y s'+    return x         = SM (\s -> Just (x,s))+    fail _           = SM (\_ -> Nothing)++instance ParserM SM where+    work f = SM f+    maybe_work f = SM $ \s -> case f s of+                                  Just (x, s') -> Just (Just x, s')+                                  Nothing -> Just (Nothing, s)+    peek_input = SM $ \s -> Just (s, s)++----- Lazy Monad -----+parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString)+parse_lazily (LM f) s = f s++newtype LM a = LM (B.ByteString -> (a, B.ByteString))+instance Monad LM where+    LM m >>= k = LM $ \s -> let (x, s') = m s+                                LM y = k x+                            in y s'+    return x = LM (\s -> (x,s))+    fail s = error s++instance ParserM LM where+    work f = LM $ \s -> case f s of+                            Nothing -> error "parser error"+                            Just x -> x+    maybe_work f = LM $ \s -> case f s of+                                  Nothing -> (Nothing, s)+                                  Just (x, s') -> (Just x, s')+    peek_input = LM $ \s -> (s, s)+
+ src/Darcs/Patch/Real.hs view
@@ -0,0 +1,777 @@+-- Copyright (C) 2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+-- , TypeOperators, GADTs, PatternGuards #-}++#include "gadts.h"++-- | Conflictor patches+module Darcs.Patch.Real+       ( RealPatch(..), prim2real, is_consistent, is_forward, is_duplicate,+         pullCommon, mergeUnravelled ) where++import Control.Monad ( mplus, liftM )+import Data.List ( partition, nub )+import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Conflict(..), Effect(..),+                          showPrim, FileNameFormat(NewFormat),+                          IsConflictedPrim(..), ConflictState(..) )+import Darcs.Patch.Read ( readPrim )+import Darcs.Patch.Patchy+import Darcs.Ordered+--import Darcs.Patch.Read ()+--import Darcs.Patch.Viewing ()+--import Darcs.Patch.Apply ()+import Darcs.Patch.Commute ( mangle_unravelled )+import Darcs.Patch.Non ( Non(..), Nonable(..), unNon,+                         showNons, showNon, readNons, readNon,+                         add, addP, addPs, remP, remPs, remNons,+                         (*>), (>*), (*>>), (>>*) )+import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,+                                  genCommuteWhatWeCanRL,+                                  removeRL, removeFL, remove_subsequenceFL )+import qualified Data.ByteString.Char8 as BC ( unpack )+import Darcs.Patch.ReadMonads (work, peek_input, my_lex )+import Darcs.Utils ( nubsort )+import Darcs.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )+import Darcs.Show+import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )+import Darcs.ColorPrinter ( errorDoc, assertDoc )+--import Printer ( greenText )+--import Darcs.ColorPrinter ( traceDoc )+#include "impossible.h"++-- |+-- @Duplicate x@: This patch has no effect since @x@ is already present in the repository+--+-- @Etacilpud x: invert (Duplicate x)@+--+-- @Normal prim@: A primitive patch+--+-- @Conflictor ix xx x@:+-- @ix@ is the set of patches:+--+--   * that conflict with @x@ and also conflict with another patch in the repository+--+--   * that conflict with a patch that conflict with @x@+--+-- @xx@ is the sequence of patches that conflict *only* with @x@+--+-- @x@ is the current patch+--+-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary+--  context to uniquely define the patch that is referred to.+--+-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@+data RealPatch C(x y) where+    Duplicate :: Non RealPatch C(x) -> RealPatch C(x x)+    Etacilpud :: Non RealPatch C(x) -> RealPatch C(x x)+    Normal :: Prim C(x y) -> RealPatch C(x y)+    Conflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(y x)+    InvConflictor :: [Non RealPatch C(x)] -> FL Prim C(x y) -> Non RealPatch C(x) -> RealPatch C(x y)++-- | 'is_duplicate' @p@ is ' @True@ if @p@ is either a  'Duplicate' or 'Etacilpud' patch+is_duplicate :: RealPatch C(s y) -> Bool+is_duplicate (Duplicate _) = True+is_duplicate (Etacilpud _) = True+is_duplicate _ = False++-- | This is only used for unit testing+is_forward :: RealPatch C(s y) -> Maybe Doc+is_forward p@(InvConflictor _ _ _) =+    Just $ redText "An inverse conflictor" $$ showPatch p+is_forward p@(Etacilpud _) =+    Just $ redText "An inverse duplicate" $$ showPatch p+is_forward _ = Nothing++mergeUnravelled :: [Sealed ((FL Prim) C(x))] -> Maybe (FlippedSeal RealPatch C(x))+mergeUnravelled [] = Nothing+mergeUnravelled [_] = Nothing+mergeUnravelled ws = case mergeUnravelled_private ws of+                     Nothing -> Nothing+                     Just NilRL -> bug "found no patches in mergeUnravelled"+                     Just (z:<:_) -> Just $ FlippedSeal z+    where notNullS :: Sealed ((FL Prim) C(x)) -> Bool+          notNullS (Sealed NilFL) = False+          notNullS _ = True+          mergeUnravelled_private :: [Sealed (FL Prim C(x))] -> Maybe (RL RealPatch C(x x))+          mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons+                                                        (map sealed2non $ filter notNullS xs)++-- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.+--   @xs@ must be non-empty since we split this list at the last patch+sealed2non :: Sealed ((FL Prim) C(x)) -> Non RealPatch C(x)+sealed2non (Sealed xs) = case reverseFL xs of+                         y:<:ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y+                         NilRL -> bug "NilFL encountered in sealed2non"++mergeConflictingNons :: [Non RealPatch C(x)] -> Maybe (FL RealPatch C(x x))+mergeConflictingNons ns = mcn $ map unNon ns+    where mcn :: [Sealed (FL RealPatch C(x))] -> Maybe (FL RealPatch C(x x))+          mcn [] = Just NilFL+          mcn [Sealed p] = case join_effects p of -- this is just a safety check, and could+                           NilFL -> Just p                 -- be removed when we're sure of the code.+                           _ -> Nothing+          mcn (Sealed p1:Sealed p2:zs) = case pullCommon p1 p2 of+                                         Common c ps qs ->+                                             case merge (ps :\/: qs) of+                                             qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)++join_effects :: Effect p => p C(x y) -> FL Prim C(x y)+join_effects = join_inverses . effect+    where join_inverses :: FL Prim C(x y) -> FL Prim C(x y)+          join_inverses NilFL = NilFL+          join_inverses (p:>:ps) = case removeFL (invert p) ps' of+                                   Just ps'' -> ps''+                                   Nothing -> p :>: ps'+              where ps' = join_inverses ps++assertConsistent :: RealPatch C(x y) -> RealPatch C(x y)+assertConsistent x = assertDoc (do e <- is_consistent x+                                   Just (redText "Inconsistent patch:" $$ showPatch x $$ e)) x++-- | @mergeAfterConflicting@ takes as input a sequence of conflicting+-- patches @xxx@ (which therefore have no effect) and a sequence of+-- primitive patches @yyy@ that follow said sequence of conflicting+-- patches, and may depend upon some of the conflicting patches (as a+-- resolution).++-- The output is two sequences of patches the first consisting of a+-- set of mutually-conflicting patches, and the second having the same+-- effect as the original primitive patch sequence in the input.++-- So far as I can tell, the second output is always identical to+-- @mapFL Normal yyy@++-- The first output is the set of patches from @xxx@ that are depended+-- upon by @yyy@.++mergeAfterConflicting :: FL RealPatch C(x x) -> FL Prim C(x y)+                      -> Maybe (FL RealPatch C(x x), FL RealPatch C(x y))+mergeAfterConflicting xxx yyy = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$+                                --          greenText "and yyy" $$ showPatch yyy) $+                                mac (reverseFL xxx) yyy NilFL+    where mac :: RL RealPatch C(x y) -> FL Prim C(y z) -> FL RealPatch C(z a)+              -> Maybe (FL RealPatch C(x x), FL RealPatch C(x a))+          mac NilRL xs goneby = case join_effects goneby of+                                NilFL -> Just (NilFL, mapFL_FL Normal xs)+                                _z -> --traceDoc (greenText "mac1 z" $$ showPatch _z) $+                                      Nothing+          mac (p:<:ps) xs goneby = --traceDoc (greenText "mac ps" $$ showPatch ps $$+                                   --          greenText "p" $$ showPatch p $$+                                   --          greenText "xs" $$ showPatch xs $$+                                   --          greenText "goneby" $$ showPatch goneby) $+                                   case commuteFL (p :> mapFL_FL Normal xs) of+                                   Left _  -> case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of+                                              a:>p':>b ->+                                                  do (b',xs') <- mac b xs goneby+                                                     let pa = join_effects $ p':<:a+                                                     --traceDoc (greenText "foo1" $$+                                                     --          showPatch pa) $ Just ()+                                                     NilFL <- return pa+                                                     return (reverseRL (p':<:a)+>+b', xs')+                                                   `mplus` do NilFL <- return goneby+                                                              NilFL <- return $ join_effects (p:<:ps)+                                                              return (reverseRL (p:<:ps),+                                                                      mapFL_FL Normal xs)+                                   Right (l:>p'') ->+                                       case allNormal l of+                                       Just xs'' -> mac ps xs'' (p'':>:goneby)+                                       Nothing ->+                                              case genCommuteWhatWeCanRL commute_no_conflicts (ps :> p) of+                                              a:>p':>b ->+                                                  do (b',xs') <- mac b xs goneby+                                                     let pa = join_effects $ p':<:a+                                                     --traceDoc (greenText "foo2" $$+                                                     --          showPatch pa) $ Just ()+                                                     NilFL <- return pa+                                                     return $ (reverseRL (p':<:a)+>+b', xs')++geteff :: [Non RealPatch C(x)] -> FL Prim C(x y) -> ([Non RealPatch C(x)], FL RealPatch C(x y))+geteff _ NilFL = ([],NilFL)+geteff ix (x:>:xs) | Just ix' <- mapM (remP (Normal x)) ix+                               = --traceDoc (greenText "I got rid of x" $$ showPatch x) $+                                 case geteff ix' xs of+                                 (ns,xs') -> (non (Normal x) : map (addP (Normal x)) ns,+                                              Normal x :>: xs')+geteff ix xx = case mergeConflictingNons ix of+               Nothing -> errorDoc $ redText "mergeConflictingNons failed in geteff with ix" $$+                          showNons ix $$ redText "xx" $$ showPatch xx+               Just rix -> case mergeAfterConflicting rix xx of+                           Just (a,x) -> (map (addPs (reverseFL a)) $ toNons x,+                                          a +>+ x)+                           Nothing -> errorDoc $ redText "mergeAfterConflicting failed in geteff"$$+                                      redText "where ix" $$ showNons ix $$+                                      redText "and xx" $$ showPatch xx $$+                                      redText "and rix" $$ showPatch rix++xx2nons :: [Non RealPatch C(x)] -> FL Prim C(x y) -> [Non RealPatch C(x)]+xx2nons ix xx = fst $ geteff ix xx++xx2patches :: [Non RealPatch C(x)] -> FL Prim C(x y) -> FL RealPatch C(x y)+xx2patches ix xx = snd $ geteff ix xx++-- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns+--   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).+--   Otherwise, it returns 'Nothing'.+allNormal :: FL RealPatch C(x y) -> Maybe (FL Prim C(x y))+allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs+allNormal NilFL = Just NilFL+allNormal _ = Nothing++-- | This is used for unit-testing and for internal sanity checks+is_consistent :: RealPatch C(x y) -> Maybe Doc+is_consistent (Normal _) = Nothing+is_consistent (Duplicate _) = Nothing+is_consistent (Etacilpud _) = Nothing+is_consistent (Conflictor im mm m@(Non deps _))+    | not $ everyone_conflicts im = Just $ redText "Someone doesn't conflict in im in is_consistent"+    | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in is_consistent"+    | any (\x -> any (x `conflicts_with`) nmm) im+        = Just $ redText "mm conflicts with im in is_consistent where nmm is" $$+                 showNons nmm+    | Nothing <- (nmm ++ im) `minus` toNons deps = Just $ redText "dependencies not in conflict:" $$+                                                   showNons (toNons deps) $$+                                                   redText "compared with deps itself:" $$+                                                   showPatch deps+    | otherwise = case all_conflicts_with m im of+                  (im1,[]) | im1 `eqSet` im -> Nothing+                  (_,imnc) -> Just $ redText "m doesn't conflict with im in is_consistent.  unconflicting:"+                              $$ showNons imnc+    where (nmm, rmm) = geteff im mm+is_consistent c@(InvConflictor _ _ _) = is_consistent (invert c)++everyone_conflicts :: [Non RealPatch C(x)] -> Bool+everyone_conflicts [] = True+everyone_conflicts (x:xs) = case all_conflicts_with x xs of+                            ([],_) -> False+                            (_,xs') -> everyone_conflicts xs'++prim2real :: Prim C(x y) -> RealPatch C(x y)+prim2real = Normal++instance Patchy RealPatch++instance MyEq p => Eq (Sealed (p C(x))) where+    (Sealed x) == (Sealed y) | IsEq <- x =\/= y = True+                             | otherwise = False++merge_with :: Non RealPatch C(x) -> [Non RealPatch C(x)] -> Sealed (FL Prim C(x))+merge_with p [] = effect `mapSeal` unNon p+merge_with p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $+                  filter (\x -> not (p `depends_upon` x) && not (p `conflicts_with` x)) xs+    where mergeall :: [Sealed (FL RealPatch C(x))] -> Sealed (FL Prim C(x))+          mergeall [Sealed x] = Sealed $ effect x+          mergeall [] = Sealed NilFL+          mergeall (Sealed x:Sealed y:rest) = case merge (x :\/: y) of+                                              y' :/\: _ -> mergeall (Sealed (x+>+y'):rest)+          unconflicting_of [] = []+          unconflicting_of (q:qs) = case all_conflicts_with q qs of+                                    ([],_) -> q:qs+                                    (_,nc) -> unconflicting_of nc++instance Conflict RealPatch where+    conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]+    conflictedEffect (Etacilpud _) = impossible+    conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]+    conflictedEffect (InvConflictor _ _ _) = impossible+    conflictedEffect (Normal x) = [IsC Okay x]+    resolve_conflicts (Conflictor ix xx x) = [mangle_unravelled unravelled : unravelled]+            where unravelled = nub $ filter isn $ map (`merge_with` (x:ix++nonxx)) (x:ix++nonxx)+                  nonxx = nonxx_ (nonxx_aux ix xx)+                  nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)+                  nonxx_aux a b = reverseFL $ xx2patches a b+                  nonxx_ :: RL RealPatch C(x y) -> [Non RealPatch C(x)]+                  nonxx_ NilRL = []+                  nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q]+                  nonxx_ _ = []+                  isn :: Sealed (FL p C(x)) -> Bool+                  isn (Sealed NilFL) = False+                  isn _ = True+    resolve_conflicts _ = []++    -- cA+    commute_no_conflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)+    commute_no_conflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x)+    commute_no_conflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x)+    commute_no_conflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x)+    -- cB+    commute_no_conflicts (x :> Duplicate d) = if d == addP (invert x) (non x)+                                              then Just (x :> Duplicate d)+                                              else do d' <- remP (invert x) d+                                                      return (Duplicate d' :> x)+    commute_no_conflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d'))+    commute_no_conflicts c@(Etacilpud _ :> _) = invertCommuteNC c+    commute_no_conflicts c@(_ :> Etacilpud _) = invertCommuteNC c+    -- cE+    commute_no_conflicts (Normal x :> Normal y) = do y' :> x' <- commute (x :> y)+                                                     return (Normal y' :> Normal x')+    -- cF -- involves a conflict+    -- cG+    commute_no_conflicts (Normal x :> Conflictor iy yy y) =+        case commuteFL (x :> invert yy) of+        Right (iyy' :> x') -> do+           y':iy' <- mapM (Normal x' >*) (y:iy)+           return (Conflictor iy' (invert iyy') y' :> Normal x')+        _ -> Nothing+    -- cFi+cGi  -- handle with previous two pattern matches+    commute_no_conflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c+    -- icG FIXME: where is icF?+    commute_no_conflicts (Conflictor iy' yy' y' :> Normal x') =+        do x :> iyy <- commuteRL (invertFL yy' :> x')+           y:iy <- mapM (*> Normal x') (y':iy')+           return (Normal x :> Conflictor iy (invertRL iyy) y)+    -- icGi      -- handle with previous pattern match+    commute_no_conflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c+    -- cH -- this involves a conflict commute+    -- cI+    commute_no_conflicts (Conflictor ix xx x :> Conflictor iy yy y) =+        do xx' :> yy' <- commute (yy :> xx)+           x':ix' <- mapM (yy >>*) (x:ix)+           y':iy' <- mapM (*>> xx') (y:iy)+           False <- return $ any (conflicts_with y) (x':ix')+           False <- return $ any (conflicts_with x') iy+           return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')+    -- cHi+cIi            uses previous two matches+    commute_no_conflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c+    -- cJ+    commute_no_conflicts (InvConflictor ix xx x :> Conflictor iy yy y) =+        do iyy' :> xx' <- commute (xx :> invert yy)+           y':iy' <- mapM (xx' >>*) (y:iy)+           x':ix' <- mapM (invertFL iyy' >>*) (x:ix)+           False <- return $ any (conflicts_with y') (x':ix')+           False <- return $ any (conflicts_with x') iy'+           return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')+    -- icJ+    commute_no_conflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') =+        do xx :> iyy <- commute (invert yy' :> xx')+           y:iy <- mapM (*>> xx') (y':iy')+           x:ix <- mapM (*>> yy') (x':ix')+           False <- return $ any (conflicts_with y') (x':ix')+           False <- return $ any (conflicts_with x') iy'+           return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)++instance FromPrim RealPatch where+    fromPrim = prim2real+instance ToFromPrim RealPatch where+    toPrim (Normal p) = Just p+    toPrim _ = Nothing++instance MyEq RealPatch where+    (Duplicate x) =\/= (Duplicate y) | x == y = IsEq+    (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq+    (Normal x) =\/= (Normal y) = x =\/= y+    (Conflictor cx xx x) =\/= (Conflictor cy yy y)+        | map (add $ invertFL xx) cx `eqSet`+          map (add $ invertFL yy) cy &&+          add (invert xx) x == add (invert yy) y = xx =/\= yy+    (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)+        | cx `eqSet` cy && x == y = xx =\/= yy+    _ =\/= _ = NotEq++eqSet :: Eq a => [a] -> [a] -> Bool+eqSet [] [] = True+eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys+eqSet _ _ = False++remove1 :: Eq a => a -> [a] -> Maybe [a]+remove1 x (y:ys) | x == y = Just ys+                 | otherwise = (y :) `fmap` remove1 x ys+remove1 _ [] = Nothing++minus :: Eq a => [a] -> [a] -> Maybe [a]+minus xs [] = Just xs+minus xs (y:ys) = do xs' <- remove1 y xs+                     xs' `minus` ys++invertNon :: Non RealPatch C(x) -> Non RealPatch C(x)+invertNon (Non c x)+    | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)+    | otherwise = addPs (Normal x :<: reverseFL c) $ non nix+    where nix = Normal $ invert x++nonTouches :: Non RealPatch C(x) -> [FilePath]+nonTouches (Non c x) = list_touched_files (c +>+ fromPrim x :>: NilFL)++toNons :: (Conflict p, Patchy p, ToFromPrim p, Nonable p) => FL p C(x y) -> [Non p C(x)]+toNons xs = map lastNon $ initsFL xs+    where lastNon :: (Conflict p, Patchy p, Nonable p) => Sealed ((p :> FL p) C(x)) -> Non p C(x)+          lastNon (Sealed xxx) = case lastNon_aux xxx of+                                 deps :> p :> _ -> case non p of+                                                   Non NilFL pp -> Non (reverseRL deps) pp+                                                   Non ds pp -> errorDoc $ redText "Weird case in toNons" $$+                                                                redText "please report this bug!" $$+                                                                (case xxx of+                                                                 z:>zs -> showPatch (z:>:zs)) $$+                                                                redText "ds are" $$ showPatch ds $$+                                                                redText "pp is" $$ showPatch pp+          reverseFoo :: (p :> FL p) C(x y) -> (RL p :> p) C(x y)+          reverseFoo (p :> ps) = rf NilRL p ps+              where rf :: RL p C(a b) -> p C(b c) -> FL p C(c d) -> (RL p :> p) C(a d)+                    rf rs l NilFL = rs :> l+                    rf rs x (y:>:ys) = rf (x:<:rs) y ys+          lastNon_aux :: Commute p => (p :> FL p) C(x y) -> (RL p :> p :> RL p) C(x y)+          lastNon_aux = commuteWhatWeCanRL . reverseFoo++initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]+initsFL NilFL = []+initsFL (x:>:xs) = Sealed (x:>NilFL) : map (\ (Sealed (y:>xs')) -> Sealed (x:>y:>:xs')) (initsFL xs)++fromNons :: [Non RealPatch C(x)] -> Maybe (Sealed (FL Prim C(x)))+fromNons [] = Just $ Sealed $ NilFL+fromNons ns = do (Sealed p, ns') <- pullInContext ns+                 ns'' <- mapM (remP $ fromPrim p) ns'+                 Sealed ps <- fromNons ns''+                 return $ Sealed $ p :>: ps++pullInContext :: [Non RealPatch C(x)] -> Maybe (Sealed (Prim C(x)), [Non RealPatch C(x)])+pullInContext (Non NilFL p:ns) = Just (Sealed p, ns)+pullInContext (n:ns) = do (sp,ns') <- pullInContext ns+                          return (sp, n:ns')+pullInContext [] = Nothing++filterConflictsFL :: Non RealPatch C(x) -> FL Prim C(x y) -> (FL Prim :> FL Prim) C(x y)+filterConflictsFL _ NilFL = NilFL :> NilFL+filterConflictsFL n (p:>:ps)+    | Just n' <- remP (fromPrim p) n = case filterConflictsFL n' ps of+                                       p1 :> p2 -> p:>:p1 :> p2+    | otherwise = case commuteWhatWeCanFL (p :> ps) of+                  p1 :> p' :> p2 -> case filterConflictsFL n p1 of+                                    p1a :> p1b -> p1a :> p1b +>+ p' :>: p2++instance Invert RealPatch where+    invert (Duplicate d) = Etacilpud d+    invert (Etacilpud d) = Duplicate d+    invert (Normal p) = Normal (invert p)+    invert (Conflictor x c p) = InvConflictor x c p+    invert (InvConflictor x c p) = Conflictor x c p+    identity = Normal identity++instance Commute RealPatch where+--    commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$+--                                 greenText "with y" $$ showPatch y) False = undefined+    commute (x :> y) | Just (y' :> x') <- commute_no_conflicts (assertConsistent x :> assertConsistent y) = Just (y' :> x')+    -- cF+    commute (Normal x :> Conflictor a1'nop2 n1'x p1') -- these patches conflicted+        | Just rn1' <- removeRL x (reverseFL n1'x) =+                      do let p2:n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x:<:rn1')+                             a2 = p1':a1'nop2++n1nons+                         case (a1'nop2, reverseRL rn1', p1') of+                           ([], NilFL, Non c y) | NilFL <- join_effects c ->+                                    Just (Normal y :> Conflictor a1'nop2 (y:>:NilFL) p2)+                           (a1,n1,_) -> Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)+    -- cFi  -- handle with previous pattern match+    commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c+    -- cH+    commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)+        | Just a2_minus_p1 <- remove1 p1' a2,+          not (p2 `depends_upon` p1') =+              do let n1nons = map (add n2) $ xx2nons a1 n1+                     n2nons = xx2nons a2 n2+                     Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons+                     n2n1 = n2 +>+ n1+                     a1' = map (add n2) a1+                     p2ooo = remNons a1' p2+                 n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1+                 let n1'n2'nons = xx2nons a2_minus_p1n1 (n1'+>+n2')+                     n1'nons = take (lengthFL n1') n1'n2'nons+                     n2'nons = drop (lengthFL n1') n1'n2'nons+                     Just a1'nop2 = (a2++n2nons) `minus` (p1':n1'nons)+                     Just a2'o = --traceDoc (greenText "\n\nConflictor a1 n1 p1 is" $$+                                 --          showPatch (assertConsistent $ Conflictor a1 n1 p1) $$+                                 --          greenText "and Conflictor a2 n2 p2 is" $$+                                 --          showPatch (assertConsistent $ Conflictor a2 n2 p2) $$+                                 --          greenText "where n2'nons is" $$ showNons n2'nons $$+                                 --          greenText "and others are" $$+                                 --          showNons (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) $$+                                 --          greenText "These came from" $$+                                 --          showNons (a2_minus_p1++n2nons) $$+                                 --          greenText "n1'n2'nons" $$ showNons n1'n2'nons $$+                                 --          greenText "from n1' :> n2'" $$+                                 --          showPatch n1' $$ greenText ":>" $$ showPatch n2' $$+                                 --          greenText "p2" $$ showNon p2 $$+                                 --          greenText "p2 fixed" $$ showNon p2ooo $$+                                 --          -- greenText "pren1" $$ showPatch pren1 $$+                                 --          greenText "n1'" $$ showPatch n1' $$+                                 --          greenText "p2" $$ showNon p2 +                                 --         ) +                                 (fst $ all_conflicts_with p2 $ a2_minus_p1++n2nons) `minus` n2'nons+                     Just a2' = mapM (remPs (xx2patches a1'nop2 n1')) $+                                a2'o+                     Just p2' = remPs (xx2patches a1'nop2 n1') p2+                 case (a2', n2', p2') of+                   ([], NilFL, Non c x) | NilFL <- join_effects c ->+                                          Just (Normal x :> Conflictor a1'nop2 (n1'+>+x:>:NilFL) p1')+                                        | otherwise -> impossible+                   _ -> Just (Conflictor a2' n2' p2' :> Conflictor (p2:a1'nop2) n1' p1')+        where (_,rpn2) = geteff a2 n2+              p1' = addPs (reverseFL rpn2) p1+    -- cHi         -- uses previous match+    commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c+    commute _ = Nothing++    merge (InvConflictor _ _ _ :\/: _) = impossible+    merge (_ :\/: InvConflictor _ _ _) = impossible+    merge (Etacilpud _ :\/: _) = impossible+    merge (_ :\/: Etacilpud _) = impossible+--    merge (x :\/: y) | traceDoc (greenText "merging x" $$ showPatch x $$+--                                 greenText "with y" $$ showPatch y) False = impossible+    -- mA+    merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a+    -- mB+    merge (Duplicate a :\/: b) = b :/\: Duplicate (addP (invert b) a) -- FIXME ???+    -- smB+    merge m@(_ :\/: Duplicate _) = swapMerge m+    -- mC+--    merge _ | traceDoc (greenText "about to look for conflictingness") False = impossible+    merge (x :\/: y) | Just (y' :> ix') <- commute (invert (assertConsistent x) :> assertConsistent y),+                       Just (y'' :> _) <- commute (x :> y'),+                       IsEq <- y'' =\/= y = --traceDoc (greenText "These didn't conflict") $+                                            assertConsistent y' :/\: invert (assertConsistent ix')+                     | IsEq <- x =\/= y,+                       n <- addP (invert x) $ non x =+                                 --traceDoc (greenText "Found duplicate") $+                                 Duplicate n :/\: Duplicate n+--    merge (x :\/: y) | traceDoc (greenText "trying to merging x" $$ showPatch x $$+--                                 greenText "which conflicts with y" $$ showPatch y) False = impossible+    -- mD+    merge (Normal x :\/: Normal y) =+        Conflictor [] (x:>:NilFL) (non $ Normal y) :/\: Conflictor [] (y:>:NilFL) (non $ Normal x)+    -- mG+    merge (Normal x :\/: Conflictor iy yy y) =+          --traceDoc (greenText "merging Normal x" $$ showPatch x $$+          --          greenText "and Conflictor iy yy y" $$ showPatch (Conflictor iy yy y)) $+          Conflictor iy yyx y :/\: Conflictor (y:iy++nyy) NilFL x'+              where yyx = yy +>+ x:>:NilFL+                    (x':nyy) = reverse $ xx2nons iy yyx+    -- smE+smG+    merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m+--    merge (x :\/: y) | traceDoc (greenText "still trying to merge x" $$ showPatch x $$+--                                 greenText "with y" $$ showPatch y) False = impossible+    -- mH see also cH+    merge (Conflictor ix xx x :\/: Conflictor iy yy y) =+        case pullCommonRL (reverseFL xx) (reverseFL yy) of+        CommonRL rxx1 ryy1 c ->+            case commuteRLFL (ryy1 :> invertRL rxx1) of+            Just (ixx' :> ryy') ->+                let xx' = invert ixx'+                    yy' = reverseRL ryy'+                    y':iy' = map (add $ invertFL ixx') (y:iy)+                    x':ix' = map (add ryy') (x:ix)+                    nyy' = xx2nons iy' yy'+                    nxx' = xx2nons ix' xx'+                    icx = drop (lengthRL rxx1) $ xx2nons ix (reverseRL $ c+<+rxx1)+                    ic' = map (add ryy') icx+                    ixy' = ic' ++ (iy'+++ix')+                    -- +++ above is a more efficient version of nub+                    -- (iy'++ix') given that we know each element shows up+                    -- only once in either list.+                in --traceDoc (greenText "here I am! and so is ixy'" $$ showNons ixy' $$+                   --          greenText "and iy" $$ showNons iy $$ greenText (show $ length iy) $$+                   --          greenText "and ix" $$ showNons ix $$+                   --          greenText "and iy'" $$ showNons iy' $$+                   --          greenText "and ix'" $$ showNons ix' $$+                   --          greenText "and ic'" $$ showNons ic'+                   --         ) $+                Conflictor (x':ixy'++nxx') yy' y' :/\: Conflictor (y':ixy'++nyy') xx' x'+            Nothing -> impossible pullInContext fromNons+--    merge _ = error "haven't finished fixing merge"++    list_touched_files (Duplicate p) = nonTouches p+    list_touched_files (Etacilpud p) = nonTouches p+    list_touched_files (Normal p) = list_touched_files p+    list_touched_files (Conflictor x c p) =+        nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p+    list_touched_files (InvConflictor x c p) =+        nubsort $ concatMap nonTouches x ++ list_touched_files c ++ nonTouches p++{-+all_conflicts_withFL :: FL Prim C(x y) -> [Non RealPatch C(x)]+                     -> ([Non RealPatch C(x)], [Non RealPatch C(x)])+all_conflicts_withFL xx ns = case partition f ns of+                             ([],nc) -> ([],nc)+                             (c,nc) -> case acw c nc of+                                       (c',nc') -> (c++c',nc')+    where acw (y:ys) zs = case all_conflicts_with y zs of+                          (c,nc) -> case acw ys nc of+                                    (c',nc') -> (c++c',nc')+          acw [] zs = ([],zs)+          f (Non c p) = case commuteRLFL (invertFL c :> mapFL_FL Normal xx) of+                        Nothing -> True+                        Just (xx' :> _) -> case commuteFL (Normal (invert p) :> xx') of+                                           Nothing -> True+                                           Just _ -> False+-}+all_conflicts_with :: Non RealPatch C(x) -> [Non RealPatch C(x)]+                   -> ([Non RealPatch C(x)], [Non RealPatch C(x)])+all_conflicts_with x ys = acw $ partition (conflicts_with x) ys+    where acw ([],nc) = ([],nc)+          acw (c:cs, nc) = case all_conflicts_with c nc of+                           (c1,nc1) -> case acw (cs, nc1) of+                                       (xs',nc') -> (c:c1++xs',nc')++conflicts_with :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool+conflicts_with x y | x `depends_upon` y || y `depends_upon` x = False+conflicts_with x (Non cy y) =+    case remPs cy x of+    Just (Non cx' x') -> case commuteFL (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of+                         Right _ -> False+                         Left _ -> True+    Nothing -> True++depends_upon :: Non RealPatch C(x) -> Non RealPatch C(x) -> Bool+depends_upon (Non xs _) (Non ys y) =+    case remove_subsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of+    Just _ -> True+    Nothing -> False++(+++) :: Eq a => [a] -> [a] -> [a]+[] +++ x = x+x +++ [] = x+(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)+               | otherwise = x : (xs +++ xys)++swapMerge :: (RealPatch :\/: RealPatch) C(x y) -> (RealPatch :/\: RealPatch) C(x y)+swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'++invertCommute :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))+invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)+                            return (invert iy' :> invert ix')++invertCommuteNC :: (RealPatch :> RealPatch) C(x y) -> Maybe ((RealPatch :> RealPatch) C(x y))+invertCommuteNC (x :> y) = do ix' :> iy' <- commute_no_conflicts (invert y :> invert x)+                              return (invert iy' :> invert ix')++-- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted+--   out of both @xs@ and @ys@ along with the remnants of both lists+pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)+pullCommon NilFL ys = Common NilFL NilFL ys+pullCommon xs NilFL = Common NilFL xs NilFL+pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of+                                                      Common c xs' ys' -> Common (x:>:c) xs' ys'+pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of+                         xs1:>x':>xs2 -> case pullCommon xs1 ys of+                                         Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys'++-- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in common,+--   in other words @cs +>+ xs@ and @cs +>+ ys@+data Common p C(o x y) where+    Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)++-- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted+--   out of both @xs@ and @ys@ along with the remnants of both lists+pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)+pullCommonRL NilRL ys = CommonRL NilRL ys NilRL+pullCommonRL xs NilRL = CommonRL xs NilRL NilRL+pullCommonRL (x:<:xs) xys+    | Just ys <- removeRL x xys = case pullCommonRL xs ys of+                                  CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c)+pullCommonRL (x:<:xs) ys =+    case commuteWhatWeCanRL (xs :> x) of+    xs1:>x':>xs2 -> case pullCommonRL xs2 ys of+                    CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c++-- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ in common,+--   in other words @xs +<+ cs@ and @ys +<+ cs@+data CommonRL p C(x y f) where+    CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)++instance Apply RealPatch where+    apply opts p = apply opts (effect p)+    applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p+    applyAndTryToFixFL x = do apply [] x; return Nothing++instance ShowPatch RealPatch where+    showPatch (Duplicate d) = blueText "duplicate" $$ showNon d+    showPatch (Etacilpud d) = blueText "etacilpud" $$ showNon d+    showPatch (Normal p) = showPrim NewFormat p+    showPatch (Conflictor i NilFL p) =+        blueText "conflictor" <+> showNons i <+> blueText "[]" $$ showNon p+    showPatch (Conflictor i cs p) =+        blueText "conflictor" <+> showNons i <+> blueText "[" $$+        showPatch cs $$+        blueText "]" $$+        showNon p+    showPatch (InvConflictor i NilFL p) =+        blueText "rotcilfnoc" <+> showNons i <+> blueText "[]" $$ showNon p+    showPatch (InvConflictor i cs p) =+        blueText "rotcilfnoc" <+> showNons i <+> blueText "[" $$+        showPatch cs $$+        blueText "]" $$+        showNon p+    showContextPatch s (Normal p) = showContextPatch s p+    showContextPatch _ c = showPatch c++instance ReadPatch RealPatch where+ readPatch' want_eof =+     do s <- peek_input+        case fmap (BC.unpack . fst) $ my_lex s of+          Just "duplicate" ->+              do work my_lex+                 p <- readNon+                 return $ (Sealed . Duplicate) `fmap` p+          Just "etacilpud" ->+              do work my_lex+                 p <- readNon+                 return $ (Sealed . Etacilpud) `fmap` p+          Just "conflictor" ->+              do work my_lex+                 --let tracePeek x = do y <- peek_input+                 --                     traceDoc (greenText x $$ greenText (show $ BC.unpack y)) return ()+                 i <- readNons+                 Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')++                 Just p <- readNon+                 return $ Just $ Sealed $ Conflictor i (unsafeCoerceP ps) p+          Just "rotcilfnoc" ->+              do work my_lex+                 i <- readNons+                 Just (Sealed ps) <- bracketedFL (fromIntegral $ fromEnum '[') (fromIntegral $ fromEnum ']')+                 Just p <- readNon+                 return $ Just $ Sealed $ InvConflictor i ps p+          _ -> do mp <- readPrim NewFormat want_eof+                  case mp of+                    Just p -> return $ Just $ Normal `mapSeal` p+                    Nothing -> return Nothing++instance Show (RealPatch C(x y)) where+    show p = renderString $ showPatch p++instance Show2 RealPatch where+    show2 = show++instance Nonable RealPatch where+    non (Duplicate d) = d+    non (Etacilpud d) = invertNon d -- FIXME !!! ???+    non (Normal p) = Non NilFL p+    non (Conflictor _ xx x) = add (invertFL xx) x+    non (InvConflictor _ _ n) = invertNon n++instance Effect RealPatch where+    effect (Duplicate _) = NilFL+    effect (Etacilpud _) = NilFL+    effect (Normal p) = effect p+    effect (Conflictor _ e _) = invert e+    effect (InvConflictor _ e _) = e+    effectRL (Duplicate _) = NilRL+    effectRL (Etacilpud _) = NilRL+    effectRL (Normal p) = effectRL p+    effectRL (Conflictor _ e _) = invertFL e+    effectRL (InvConflictor _ e _) = reverseFL e+    isHunk rp = do Normal p <- return rp+                   isHunk p
+ src/Darcs/Patch/Set.hs view
@@ -0,0 +1,50 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Set ( PatchSet, SealedPatchSet ) where++import Darcs.Hopefully ( PatchInfoAnd )+import Darcs.Ordered ( RL )+import Darcs.Sealed ( Sealed )++-- | A PatchSet is in reverse order, plus has information about which+-- tags are clean, meaning all patches applied prior to them are in+-- the tag itself, so we can stop reading at that point.  Just to+-- clarify, the first patch in a PatchSet is the one most recently+-- applied to the repo.+--+-- 'PatchSet's have the property that if+-- @+-- (info $ last $ head a) == (info $ last $ head b)+-- @+-- then @(tail a)@ and @(tail b)@ are identical repositories+--+-- Questions:+--+-- Does this mean that in a patch set such as @[[a b t1 c d e t2][f g+-- t3] [h i]]@, t1, t2 and t3 are tags, and t2 and t3 are clean?+--+-- Can we have PatchSet with length at least 3?+-- Florent+type PatchSet p C(x) = RL (RL (PatchInfoAnd p)) C(() x)++type SealedPatchSet p = Sealed (RL (RL (PatchInfoAnd p)) C(()))
+ src/Darcs/Patch/Show.lhs view
@@ -0,0 +1,89 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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.+++\begin{code}+{-# OPTIONS_GHC -cpp -fno-warn-orphans -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++module Darcs.Patch.Show ( showPatch_, showNamedPrefix )+             where++import Prelude hiding ( pi )++import Printer ( Doc, renderString, vcat,+                 text, blueText,+                 ($$), (<+>) )+import Darcs.Patch.Core ( Patch(..) )+import Darcs.Patch.Prim ( showPrim, FileNameFormat(..) )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo )+import Darcs.Ordered ( FL(NilFL), mapFL )+#include "gadts.h"+\end{code}++\section{Patch string formatting}++Of course, in order to store our patches in a file, we'll have to save them+as some sort of strings.  The convention is that each patch string will end+with a newline, but on parsing we skip any amount of whitespace between+patches.+\begin{code}+instance Show (Patch C(x y))  where+    show p = renderString (showPatch_ p) ++ "\n"++showPatch_ :: Patch C(a b) -> Doc+showPatch_ (PP p) = showPrim OldFormat p+showPatch_ (ComP NilFL) = blueText "{" $$ blueText "}"+showPatch_ (ComP ps)  = blueText "{"+                        $$ vcat (mapFL showPatch_ ps)+                        $$ blueText "}"+showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2+showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2+\end{code}++\paragraph{Merger patches}+Merge two patches.  The MERGERVERSION is included to allow some degree of+backwards compatibility if the merger algorithm needs to be changed.+\begin{verbatim}+merger MERGERVERSION+<first patch>+<second patch>+\end{verbatim}+\begin{code}+showMerger :: String -> Patch C(a b) -> Patch C(d e) -> Doc+showMerger merger_name p1 p2 =+    blueText merger_name <+> text "0.0" <+> blueText "("+                           $$ showPatch_ p1+                           $$ showPatch_ p2+                           $$ blueText ")"+\end{code}++\paragraph{Named patches}++Named patches are displayed as a ``patch id'' which is in square brackets,+followed by a patch.  Optionally, after the patch id (but before the patch+itself) can come a list of dependencies surrounded by angle brackets.  Each+dependency consists of a patch id.++\begin{code}+showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc+showNamedPrefix n d = showPatchInfo n+                   $$ blueText "<"+                   $$ vcat (map showPatchInfo d)+                   $$ blueText ">"++\end{code}
+ src/Darcs/Patch/TouchesFiles.hs view
@@ -0,0 +1,90 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.TouchesFiles ( look_touch, choose_touching,+                      select_touching,+                      deselect_not_touching, select_not_touching,+                    ) where+import Data.List ( sort )++import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,+                             patch_choices, tag, get_choices,+                      force_firsts, force_lasts, tp_patch,+                    )+import Darcs.Patch ( Patchy, apply_to_filepaths, list_touched_files )+import Darcs.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )+import Darcs.Sealed ( Sealed, seal )++select_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+select_touching [] pc = pc+select_touching files pc = force_firsts xs pc+    where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]+          ct _ NilFL = []+          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+                             (True, fs') -> tag tp:ct fs' tps+                             (False, fs') -> ct fs' tps+          xs = case get_choices pc of+               _ :> mc :> lc -> ct (map fix files) (mc +>+ lc)++deselect_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+deselect_not_touching [] pc = pc+deselect_not_touching files pc = force_lasts xs pc+    where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]+          ct _ NilFL = []+          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+                             (True, fs') -> ct fs' tps+                             (False, fs') -> tag tp:ct fs' tps+          xs = case get_choices pc of+               fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)++select_not_touching :: Patchy p => [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+select_not_touching [] pc = pc+select_not_touching files pc = force_firsts xs pc+    where ct :: Patchy p => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]+          ct _ NilFL = []+          ct fs (tp:>:tps) = case look_touch fs (tp_patch tp) of+                             (True, fs') -> ct fs' tps+                             (False, fs') -> tag tp:ct fs' tps+          xs = case get_choices pc of+               fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)++fix :: FilePath -> FilePath+fix f | take 1 (reverse f) == "/" = fix $ reverse $ drop 1 $ reverse f+fix "" = "."+fix "." = "."+fix f = "./" ++ f++choose_touching :: Patchy p => [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))+choose_touching [] p = seal p+choose_touching files p = case get_choices $ select_touching files $ patch_choices p of+                          fc :> _ :> _ -> seal $ mapFL_FL tp_patch fc++look_touch :: Patchy p => [FilePath] -> p C(x y) -> (Bool, [FilePath])+look_touch fs p = (any (\tf -> any (affects tf) fs) (list_touched_files p)+                   || fs' /= fs, fs')+    where affects touched f | touched == f = True+          affects t f = case splitAt (length f) t of+                        (t', '/':_) -> t' == f+                        _ -> case splitAt (length t) f of+                             (f', '/':_) -> f' == t+                             _ -> False+          fs' = sort $ apply_to_filepaths p fs
+ src/Darcs/Patch/Viewing.hs view
@@ -0,0 +1,333 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++module Darcs.Patch.Viewing ( xml_summary, summarize )+             where++import Prelude hiding ( pi )+import Control.Monad ( liftM )+import Data.List ( sort )++import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents )+import ByteStringUtils (linesPS )+import qualified Data.ByteString as B (null)+import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp )+import Printer ( Doc, empty, vcat,+                 text, blueText, Color(Cyan,Magenta), lineColor,+                 minus, plus, ($$), (<+>), (<>),+                 prefix, renderString,+                 userchunkPS,+               )+import Darcs.Patch.Core ( Patch(..), Named(..),+                          patchcontents )+import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..),+                          Effect, IsConflictedPrim(IsC), ConflictState(..),+                          DirPatchType(..), FilePatchType(..) )+import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity )+import Darcs.Patch.Show ( showPatch_, showNamedPrefix )+import Darcs.Patch.Info ( showPatchInfo, human_friendly )+import Darcs.Patch.Apply ( apply_to_slurpy )+#include "impossible.h"+#include "gadts.h"+import Darcs.Ordered ( RL(..), FL(..),+                             mapFL, mapFL_FL, reverseRL )++instance ShowPatch Prim where+    showPatch = showPrim OldFormat+    showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p)+    showContextPatch s (Split ps) =+        blueText "(" $$ showContextSeries s (mapFL_FL PP ps)+                     <> blueText ")"+    showContextPatch _ p = showPatch p+    summary = gen_summary False . (:[]) . IsC Okay+    thing _ = "change"++summarize :: (Conflict e, Effect e) => e C(x y) -> Doc+summarize = gen_summary False . conflictedEffect++instance ShowPatch Patch where+    showPatch = showPatch_+    showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x)+    showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}"+    showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps+                                   $$ blueText "}"+    showContextPatch _ p = showPatch p+    summary = summarize+    thing _ = "change"++showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc+showContextSeries slur patches = scs slur identity patches+    where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc+          scs s pold (p:>:ps) =+              case isHunk p of+              Nothing -> showContextPatch s p $$ scs s' identity ps+              Just hp ->+                  case ps of+                  NilFL -> coolContextHunk s pold hp identity+                  (p2:>:_) ->+                      case isHunk p2 of+                      Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps+                      Just hp2 -> coolContextHunk s pold hp hp2 $$+                                  scs s' hp ps+              where s' =+                        fromJust $ apply_to_slurpy p s+          scs _ _ NilFL = empty++showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc+showContextHunk s p = case isHunk p of+                        Just h -> coolContextHunk s identity h identity+                        Nothing -> showPatch p++coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c)+                -> Prim C(c d) -> Doc+coolContextHunk s prev p@(FP f (Hunk l o n)) next =+    case (linesPS . get_filecontents) `liftM` get_slurp f s of+    Nothing -> showPatch p -- This is a weird error...+    Just ls ->+        let numpre = case prev of+                     (FP f' (Hunk lprev _ nprev))+                         | f' == f &&+                           l - (lprev + length nprev + 3) < 3 &&+                           lprev < l ->+                             max 0 $ l - (lprev + length nprev + 3)+                     _ -> if l >= 4 then 3 else l - 1+            pre = take numpre $ drop (l - numpre - 1) ls+            numpost = case next of+                      (FP f' (Hunk lnext _ _))+                          | f' == f && lnext < l+length n+4 &&+                            lnext > l ->+                              lnext - (l+length n)+                      _ -> 3+            cleanedls = case reverse ls of+                        (x:xs) | B.null x -> reverse xs+                        _ -> ls+            post = take numpost $ drop (max 0 $ l+length o-1) cleanedls+            in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)+            $$ prefix " " (vcat $ map userchunkPS pre)+            $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))+            $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS n))+            $$ prefix " " (vcat $ map userchunkPS post)+coolContextHunk _ _ _ _ = impossible++xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc+xml_summary p = text "<summary>"+             $$ gen_summary True (conflictedEffect $ patchcontents p)+             $$ text "</summary>"++-- Yuck duplicated code below...+escapeXML :: String -> Doc+escapeXML = text . strReplace '\'' "&apos;" . strReplace '"' "&quot;" .+  strReplace '>' "&gt;" . strReplace '<' "&lt;" . strReplace '&' "&amp;"++strReplace :: Char -> String -> String -> String+strReplace _ _ [] = []+strReplace x y (z:zs)+  | x == z    = y ++ (strReplace x y zs)+  | otherwise = z : (strReplace x y zs)+-- end yuck duplicated code.++gen_summary :: Bool -> [IsConflictedPrim] -> Doc+gen_summary use_xml p+    = vcat themoves+   $$ vcat themods+    where themods = map summ $ combine $ sort $ concatMap s2 p+          s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)]+          s2 (IsC c x) = map (append56 c) $ s x+          s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)]+          s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)]+          s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)]+          s (FP f AddFile) = [(f, -1, 0, 0, False)]+          s (FP f RmFile) = [(f, 0, -1, 0, False)]+          s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)]+          s (DP d AddDir) = [(d, -1, 0, 0, True)]+          s (DP d RmDir) = [(d, 0, -1, 0, True)]+          s (Split xs) = concat $ mapFL s xs+          s (Move _ _) = [(fp2fn "", 0, 0, 0, False)]+          s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)]+          s Identity = [(fp2fn "", 0, 0, 0, False)]+          append56 f (a,b,c,d,e) = (a,b,c,d,e,f)+          (-1) .+ _ = -1+          _ .+ (-1) = -1+          a .+ b = a + b+          combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss)+              -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs+              -- allows a single patch to add and remove the same file, see issue 185+              | f == f' && (a /= -1 || b' /= -1) && (a' /= -1 || b /= -1) =+                  combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss)+          combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss+          combine [] = []+          combineConflitStates Conflicted _ = Conflicted+          combineConflitStates _ Conflicted = Conflicted+          combineConflitStates Duplicated _ = Duplicated+          combineConflitStates _ Duplicated = Duplicated+          combineConflitStates Okay Okay = Okay++          summ (f,_,-1,_,False,Okay)+              = if use_xml then text "<remove_file>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_file>"+                           else text "R" <+> text (fn2fp f)+          summ (f,_,-1,_,False,Conflicted)+              = if use_xml then text "<remove_file conflict='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_file>"+                           else text "R!" <+> text (fn2fp f)+          summ (f,_,-1,_,False,Duplicated)+              = if use_xml then text "<remove_file duplicate='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_file>"+                           else text "R" <+> text (fn2fp f) <+> text "(duplicate)"+          summ (f,-1,_,_,False,Okay)+              = if use_xml then text "<add_file>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_file>"+                           else text "A" <+> text (fn2fp f)+          summ (f,-1,_,_,False,Conflicted)+              = if use_xml then text "<add_file conflict='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_file>"+                           else text "A!" <+> text (fn2fp f)+          summ (f,-1,_,_,False,Duplicated)+              = if use_xml then text "<add_file duplicate='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_file>"+                           else text "A" <+> text (fn2fp f) <+> text "(duplicate)"+          summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty+          summ (f,0,0,0,False,Conflicted) | f == fp2fn ""+              = if use_xml then empty -- don't know what to do here...+                           else text "!" <+> text (fn2fp f)+          summ (f,0,0,0,False,Duplicated) | f == fp2fn ""+              = if use_xml then empty -- don't know what to do here...+                           else text (fn2fp f) <+> text "(duplicate)"+          summ (f,a,b,r,False,Okay)+              = if use_xml then text "<modify_file>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                                    <> xrm a <> xad b <> xrp r+                             $$ text "</modify_file>"+                           else text "M" <+> text (fn2fp f)+                                         <+> rm a <+> ad b <+> rp r+          summ (f,a,b,r,False,Conflicted)+              = if use_xml then text "<modify_file conflict='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                                    <> xrm a <> xad b <> xrp r+                             $$ text "</modify_file>"+                           else text "M!" <+> text (fn2fp f)+                                    <+> rm a <+> ad b <+> rp r+          summ (f,a,b,r,False,Duplicated)+              = if use_xml then text "<modify_file duplicate='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                                    <> xrm a <> xad b <> xrp r+                             $$ text "</modify_file>"+                           else text "M" <+> text (fn2fp f)+                                    <+> rm a <+> ad b <+> rp r <+> text "(duplicate)"+          summ (f,_,-1,_,True,Okay)+              = if use_xml then text "<remove_directory>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_directory>"+                           else text "R" <+> text (fn2fp f) <> text "/"+          summ (f,_,-1,_,True,Conflicted)+              = if use_xml then text "<remove_directory conflict='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_directory>"+                           else text "R!" <+> text (fn2fp f) <> text "/"+          summ (f,_,-1,_,True,Duplicated)+              = if use_xml then text "<remove_directory duplicate='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</remove_directory>"+                           else text "R" <+> text (fn2fp f) <> text "/ (duplicate)"+          summ (f,-1,_,_,True,Okay)+              = if use_xml then text "<add_directory>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_directory>"+                           else text "A" <+> text (fn2fp f) <> text "/"+          summ (f,-1,_,_,True,Conflicted)+              = if use_xml then text "<add_directory conflict='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_directory>"+                           else text "A!" <+> text (fn2fp f) <> text "/"+          summ (f,-1,_,_,True,Duplicated)+              = if use_xml then text "<add_directory duplicate='true'>"+                             $$ escapeXML (drop_dotslash $ fn2fp f)+                             $$ text "</add_directory>"+                           else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)"+          summ _ = empty+          ad 0 = empty+          ad a = plus <> text (show a)+          xad 0 = empty+          xad a = text "<added_lines num='" <> text (show a) <> text "'/>"+          rm 0 = empty+          rm a = minus <> text (show a)+          xrm 0 = empty+          xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>"+          rp 0 = empty+          rp a = text "r" <> text (show a)+          xrp 0 = empty+          xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>"+          drop_dotslash ('.':'/':str) = drop_dotslash str+          drop_dotslash str = str+          themoves :: [Doc]+          themoves = map showmoves p+          showmoves :: IsConflictedPrim -> Doc+          showmoves (IsC _ (Move a b))+              = if use_xml+                then text "<move from=\""+                  <> escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\""+                  <> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>"+                else text " "    <> text (fn2fp a)+                  <> text " -> " <> text (fn2fp b)+          showmoves _ = empty++instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where+    showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p+    showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p+    showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p+    showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p+    description (NamedP n _ _) = human_friendly n+    summary p = description p $$ text "" $$+                prefix "    " (summarize p) -- this isn't summary because summary does the+                                            -- wrong thing with (Named (FL p)) so that it can+                                            -- get the summary of a sequence of named patches+                                            -- right.+    showNicely p@(NamedP _ _ pt) = description p $$+                                   prefix "    " (showNicely pt)++instance (Conflict p, ShowPatch p) => Show (Named p C(x y)) where+    show = renderString . showPatch++instance (Conflict p, Apply p, Effect p, ShowPatch p) => ShowPatch (FL p) where+    showPatch xs = vcat (mapFL showPatch xs)+    showContextPatch = showContextSeries+    description = vcat . mapFL description+    summary = vcat . mapFL summary+    thing x = thing (helperx x) ++ "s"+        where helperx :: FL a C(x y) -> a C(x y)+              helperx _ = undefined+    things = thing++instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where+    showPatch = showPatch . reverseRL+    showContextPatch s = showContextPatch s . reverseRL+    description = description . reverseRL+    summary = summary . reverseRL+    thing = thing . reverseRL+    things = things . reverseRL++instance (Conflict p, Patchy p) => Patchy (FL p)+instance (Conflict p, Patchy p) => Patchy (RL p)
+ src/Darcs/Population.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++--   Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy+--+--   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.++#include "gadts.h"++module Darcs.Population ( Population, patchChanges, applyToPop,+                    getPopFrom,+                    setPopState,+                    DirMark(..),+                    getRepoPop, getRepoPopVersion,+                    modified_to_xml,+                    lookup_pop, lookup_creation_pop,+                  ) where++import qualified Data.ByteString.Char8 as BC ( unpack, singleton, pack )+import Data.Maybe ( catMaybes )+import Darcs.Utils ( withCurrentDirectory )++import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path )+import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges,+                     Effect, effect )+import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL )+import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml )+import Darcs.Patch.Set ( PatchSet )+import Darcs.Sealed ( Sealed(..), seal, unseal )+import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo )+import Darcs.Repository.Pristine ( identifyPristine, getPristinePop )+import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..),+                        setPopState, getPopFrom )+import Printer ( empty, text, ($$), (<>), Doc )+import Control.Monad ( liftM )++#include "impossible.h"++-- | population of an empty repository+initPop :: Population+initPop = Pop idpatchinfo (PopDir i [])+ where i = Info {nameI          = BC.singleton '.',+                 modifiedByI    = idpatchinfo,+                 modifiedHowI   = DullDir,+                 createdByI     = Nothing,+                 creationNameI  = Just (BC.singleton '.')}++-- | apply a patchset to a population+applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population+applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop++-- | apply Patches to a population+applyPatchesPop :: Effect p => FL (PatchInfoAnd p) C(x y) -> Population -> Population+applyPatchesPop NilFL = id+applyPatchesPop (hp:>:hps) = applyPatchesPop hps .+                             applyToPop (info hp) (effect $ patchcontents $ hopefully hp)+-- | get the pristine population from a repo+getRepoPop :: FilePath -> IO Population+getRepoPop repobasedir+ = withRepositoryDirectory [] repobasedir $- \repository -> do+      pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository+      -- pinfo is the latest patchinfo+      mp <- withCurrentDirectory repobasedir $+                identifyPristine >>= getPristinePop pinfo+      case mp of+          (Just pop) -> return pop+          (Nothing) -> getRepoPopVersion repobasedir pinfo++getRepoPopVersion :: FilePath -> PatchInfo -> IO Population+getRepoPopVersion repobasedir pinfo = withRepositoryDirectory [] repobasedir $- \repository ->+   do pips <- concatRL `liftM` read_repo repository+      return $ (unseal applyPatchSetPop) (mkPatchSet $ dropWhileRL ((/=pinfo).info) pips) initPop+             where mkPatchSet (Sealed xs) = seal $ xs :<: NilRL+                   dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r))+                   dropWhileRL _ NilRL = seal NilRL+                   dropWhileRL p xs@(x:<:xs')+                               | p x       = dropWhileRL p xs'+                               | otherwise = seal xs++-- Routines for pulling data conveniently out of a Population++lookup_pop :: FilePath -> Population -> Maybe Population+lookup_pop f p = lookup_pop' (BC.unpack $ fn2ps $ fp2fn f) p++lookup_pop' :: String -> Population -> Maybe Population+lookup_pop' f p@(Pop _ (PopFile i))+    | BC.unpack (nameI i) == f = Just p+    | otherwise = Nothing+lookup_pop' d p@(Pop pinfo (PopDir i c))+    | BC.unpack (nameI i) == "." =+        case catMaybes $ map (lookup_pop' (dropDS d).(Pop pinfo)) c of+        [apop] -> Just apop+        [] -> Nothing+        _ -> impossible+    | BC.unpack (nameI i) == takeWhile (/='/') d =+        case dropWhile (=='/') $ dropWhile (/='/') d of+        "" -> Just p+        d' -> case catMaybes $ map (lookup_pop' d'.(Pop pinfo)) c of+              [apop] -> Just apop+              [] -> Nothing+              _ -> impossible+    | otherwise = Nothing+    where dropDS ('.':'/':f) = dropDS f+          dropDS f = f++lookup_creation_pop :: PatchInfo -> FilePath -> Population -> Maybe Population+lookup_creation_pop pinfo f p = lookup_creation_pop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p++lookup_creation_pop' :: PatchInfo -> String -> Population -> Maybe Population+lookup_creation_pop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp+    where lcp p@(PopFile i)+              | fixname `fmap` creationNameI i == f && createdByI i == who = Just p+              | otherwise = Nothing+          lcp p@(PopDir i c)+              | fixname `fmap` creationNameI i == f && createdByI i == who = Just p+              | otherwise = case catMaybes $ map lcp c of+                            [apop] -> Just apop+                            _ -> Nothing+          fixname = BC.pack . fn2fp . norm_path . fp2fn . BC.unpack+          f = Just $ BC.pack $ fn2fp $ norm_path $ fp2fn a+          who = Just b++modified_to_xml :: Info -> Doc+modified_to_xml i | modifiedHowI i == DullDir = empty+                  | modifiedHowI i == DullFile = empty+modified_to_xml i = text "<modified>"+                 $$ text "<modified_how>" <> text (show (modifiedHowI i)) <>+                    text "</modified_how>"+                 $$ to_xml (modifiedByI i)+                 $$ text "</modified>"
+ src/Darcs/PopulationData.hs view
@@ -0,0 +1,123 @@+--   Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy+--+--   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.++module Darcs.PopulationData ( Population(..), PopTree(..), Info(..),+                        setPopState, notModified, setState,+                        DirMark(..), getPopFrom+                      ) where+import Darcs.Patch.Info+import Darcs.Utils ( withCurrentDirectory )+import System.Directory ( doesDirectoryExist, getDirectoryContents )+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString       as B (ByteString)++-- | the population of a darcs repository (simpler Slurpy)+data Population = Pop { popState :: PatchInfo -- ^ the state when last modified+                      , popTree  :: PopTree   -- ^ the directory listing+                      }+ deriving (Show, Eq)++setPopState :: PatchInfo -> Population -> Population+setPopState i (Pop _ tr) = Pop i tr++-- | directory listing+data PopTree = PopDir !Info ![PopTree]+             | PopFile !Info+ deriving ( Ord, Eq )++-- | info of a directory member+data DirMark = AddedFile | RemovedFile | MovedFile String+             | ModifiedFile | DullFile+             | AddedDir | RemovedDir | MovedDir !String | DullDir+               deriving ( Ord, Eq )+data Info = Info {nameI :: !B.ByteString, -- ^ name of the element+                  modifiedByI :: !PatchInfo, -- ^ last patch modifying this element+                  modifiedHowI :: !DirMark, -- ^ how was it modified+                  createdByI :: !(Maybe PatchInfo), -- ^ this can be unknown when restored backwards!+                  creationNameI :: !(Maybe B.ByteString) -- ^ the original name of the element+                 }+ deriving ( Ord, Eq )++-- | was an Info record not modified?+notModified :: Info -> Bool+notModified i = (modifiedHowI i == DullFile) || (modifiedHowI i == DullDir)++-- | set the modifier for an Info record+setState :: Info -> PatchInfo -> Info+setState i pinfo = i { modifiedByI = pinfo }++instance Show PopTree where+ show s = showPop "" s++showPop :: String -> PopTree -> String+showPop indent (PopDir i fs)+ = indent ++ show i ++ "\n" +++   unlines (map (showPop (' ':indent)) fs)+showPop indent (PopFile i)+ = indent ++ show i++instance Show Info where+ show i = show (nameI i) ++ " " ++ show (modifiedHowI i) +++          " at state " ++ show (modifiedByI i)++instance Show DirMark where+ show AddedFile = "File added"+ show RemovedFile = "File removed"+ show (MovedFile s) = "File moved to " ++ s+ show ModifiedFile = "File modified"+ show DullFile = "File old"+ show AddedDir = "Dir added"+ show RemovedDir = "Dir removed"+ show (MovedDir s) = "Dir moved from " ++ s+ show DullDir = "Dir old"++-- | read the population from a given directory @dirname@+--   all folders and documents get the given time @t@+--+--  This needs to be here in order to avoid a circular dependency+--  between Population and Pristine.+getPopFrom :: FilePath -> PatchInfo -> IO Population+getPopFrom the_directory pinfo =+    withCurrentDirectory the_directory $+       do popT <- getPopFrom_helper "."+          return (Pop pinfo popT)+ where getPopFrom_helper :: FilePath -> IO PopTree+       getPopFrom_helper dirname = do+        isdir <- doesDirectoryExist dirname+        let n = BC.pack dirname+        if isdir+          then do+           fnames <- getDirectoryContents dirname+           sl <- withCurrentDirectory dirname+                 (sequence $ map getPopFrom_helper $ filter not_hidden fnames)+           let i = Info {nameI = n,+                         modifiedByI = pinfo,+                         modifiedHowI = DullDir,+                         createdByI = Just pinfo,+                         creationNameI = Just n}+           return $ PopDir i sl+          else do let i = Info {nameI = n,+                                modifiedByI = pinfo,+                                modifiedHowI = DullFile,+                                createdByI = Just pinfo,+                                creationNameI = Just n}+                  return $ PopFile i++not_hidden :: FilePath -> Bool+not_hidden ('.':_) = False+not_hidden ('_':_) = False+not_hidden _ = True
+ src/Darcs/PrintPatch.hs view
@@ -0,0 +1,50 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.PrintPatch ( printPatch, contextualPrintPatch,+                          printPatchPager, printFriendly ) where++import Darcs.Patch ( Patchy, showContextPatch, showPatch )+import Darcs.SlurpDirectory ( Slurpy )+import Darcs.Arguments ( DarcsFlag, showFriendly )+import Printer ( putDocLnWith )+import Darcs.ColorPrinter ( fancyPrinters )+import Darcs.External ( viewDocWith )++-- | @'printFriendly' opts patch@ prints @patch@ in accordance with the+-- flags in opts, ie, whether @--verbose@ or @--summary@ were passed at+-- the command-line.+printFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> IO ()+printFriendly opts p = putDocLnWith fancyPrinters $ showFriendly opts p++-- | 'printPatch' prints a patch on standard output.+printPatch :: Patchy p => p C(x y) -> IO ()+printPatch p = putDocLnWith fancyPrinters $ showPatch p++-- | 'printPatchPager' runs '$PAGER' and shows a patch in it.+printPatchPager :: Patchy p => p C(x y) -> IO ()+printPatchPager p = viewDocWith fancyPrinters $ showPatch p++-- | 'contextualPrintPatch' prints a patch, together with its context,+-- on standard output.+contextualPrintPatch :: Patchy p => Slurpy -> p C(x y) -> IO ()+contextualPrintPatch s p = putDocLnWith fancyPrinters $ showContextPatch s p
+ src/Darcs/ProgressPatches.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}++#include "gadts.h"+module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags)+where+import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL )+import Darcs.Hopefully (PatchInfoAnd,info)+import System.IO.Unsafe ( unsafePerformIO )+import Progress (minlist, beginTedious,+                 endTedious, progress, progressKeepLatest,+                 tediousSize, finishedOne)+import Darcs.Patch.Info (just_name, is_tag)+++-- | Evaluate an 'FL' list and report progress.+progressFL :: String -> FL a C(x y) -> FL a C(x y)+progressFL _ NilFL = NilFL+progressFL k (x:>:xs) = if l < minlist then x:>:xs+                                       else startit x :>: pl xs+    where l = lengthFL (x:>:xs)+          startit y = unsafePerformIO $ do beginTedious k+                                           tediousSize k l+                                           return y+          pl :: FL a C(x y) -> FL a C(x y)+          pl NilFL = NilFL+          pl (y:>:NilFL) = unsafePerformIO $ do endTedious k+                                                return (y:>:NilFL)+          pl (y:>:ys) = progress k y :>: pl ys++-- | Evaluate an 'RL' list and report progress.+progressRL :: String -> RL a C(x y) -> RL a C(x y)+progressRL _ NilRL = NilRL+progressRL k (x:<:xs) = if l < minlist then x:<:xs+                                       else startit x :<: pl xs+    where l = lengthRL (x:<:xs)+          startit y = unsafePerformIO $ do beginTedious k+                                           tediousSize k l+                                           return y+          pl :: RL a C(x y) -> RL a C(x y)+          pl NilRL = NilRL+          pl (y:<:NilRL) = unsafePerformIO $ do endTedious k+                                                return (y:<:NilRL)+          pl (y:<:ys) = progress k y :<: pl ys++-- | Evaluate an 'RL' list and report progress. In addition to printing+-- the number of patches we got, show the name of the last tag we got.+progressRLShowTags :: String -> RL (PatchInfoAnd p) C(x y)+                   -> RL (PatchInfoAnd p) C(x y)+progressRLShowTags _ NilRL = NilRL+progressRLShowTags k (x:<:xs) = if l < minlist then x:<:xs+                                       else startit x :<: pl xs+    where l = lengthRL (x:<:xs)+          startit y = unsafePerformIO $ do beginTedious k+                                           tediousSize k l+                                           return y+          pl :: RL (PatchInfoAnd p) C(x y) -> RL (PatchInfoAnd p) C(x y)+          pl NilRL = NilRL+          pl (y:<:NilRL) = unsafePerformIO $ do endTedious k+                                                return (y:<:NilRL)+          pl (y:<:ys) =+              if is_tag iy +              then finishedOne k ("back to "++ just_name iy) y :<: pl ys+              else progressKeepLatest k y :<: pl ys+                  where+                    iy = info y
+ src/Darcs/RemoteApply.hs view
@@ -0,0 +1,58 @@+-- | This module is used by the push and put commands to apply the a bundle to a+-- remote repository. By remote I do not necessarily mean a repository on another+-- machine, it is just not the repository we're located in.+module Darcs.RemoteApply ( remote_apply, apply_as ) where++import System.Exit ( ExitCode )++import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ) )+import Darcs.Utils ( breakCommand )+import Darcs.URL ( is_url, is_ssh )+import Darcs.External+import Printer++remote_apply :: [DarcsFlag] -> String -> Doc -> IO ExitCode+remote_apply opts repodir bundle +    = case apply_as opts of+        Nothing -> if is_ssh repodir+                   then apply_via_ssh opts repodir bundle+                   else if is_url repodir+                        then apply_via_url opts repodir bundle+                        else apply_via_local opts repodir bundle+        Just un -> if is_ssh repodir+                   then apply_via_ssh_and_sudo repodir un bundle+                   else apply_via_sudo un repodir bundle++apply_as :: [DarcsFlag] -> Maybe String+apply_as (ApplyAs user:_) = Just user+apply_as (_:fs) = apply_as fs+apply_as [] = Nothing+apply_via_sudo :: String -> String -> Doc -> IO ExitCode+apply_via_sudo user repo bundle =+    pipeDoc "sudo" ["-u",user,"darcs","apply","--all","--repodir",repo] bundle+apply_via_local :: [DarcsFlag] -> String -> Doc -> IO ExitCode+apply_via_local opts repo bundle =+    pipeDoc "darcs" ("apply":"--all":"--repodir":repo:applyopts opts) bundle++apply_via_url :: [DarcsFlag] -> String -> Doc -> IO ExitCode+apply_via_url opts repo bundle =+    do maybeapply <- maybeURLCmd "APPLY" repo+       case maybeapply of+         Nothing -> apply_via_local opts repo bundle+         Just apply ->+           do let (cmd, args) = breakCommand apply+              pipeDoc cmd (args ++ [repo]) bundle++apply_via_ssh :: [DarcsFlag] -> String -> Doc -> IO ExitCode+apply_via_ssh opts repo bundle =+    pipeDocSSH addr ["darcs apply --all "++unwords (applyopts opts)++" --repodir '"++path++"'"] bundle+        where (addr,':':path) = break (==':') repo++apply_via_ssh_and_sudo :: String -> String -> Doc -> IO ExitCode+apply_via_ssh_and_sudo repo username bundle =+    pipeDocSSH addr ["sudo -u "++username+++                         " darcs apply --all --repodir '"++path++"'"] bundle+        where (addr,':':path) = break (==':') repo++applyopts :: [DarcsFlag] -> [String]+applyopts opts = if Debug `elem` opts then ["--debug"] else []
+ src/Darcs/RepoPath.hs view
@@ -0,0 +1,251 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++-- Copyright (C) 2007 Eric Kow+--+-- 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.++-- | Various abstractions for dealing with paths.+module Darcs.RepoPath (+  -- * AbsolutePath+  AbsolutePath,+  makeAbsolute,+  ioAbsolute,+  rootDirectory,+  -- * AbsolutePathOrStd+  AbsolutePathOrStd,+  makeAbsoluteOrStd,+  ioAbsoluteOrStd,+  useAbsoluteOrStd,+  -- * AbsoluteOrRemotePath+  AbsoluteOrRemotePath,+  ioAbsoluteOrRemote,+  isRemote,+  -- * SubPath+  SubPath,+  makeSubPathOf,+  simpleSubPath,+  -- * Miscellaneous+  sp2fn,+  FilePathOrURL(..),+  FilePathLike(toFilePath),+  getCurrentDirectory,+  setCurrentDirectory+) where++import Data.List ( isPrefixOf, isSuffixOf )+import Control.Exception ( bracket )++import Darcs.URL ( is_absolute, is_relative, is_ssh_nopath )+import qualified Workaround ( getCurrentDirectory )+import qualified System.Directory ( setCurrentDirectory )+import System.Directory ( doesDirectoryExist )+import qualified System.FilePath.Posix as FilePath ( normalise )+import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )+import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )+#include "impossible.h"++class FilePathOrURL a where+ {-# INLINE toPath #-}+ toPath :: a -> String++class FilePathOrURL a => FilePathLike a where+ {-# INLINE toFilePath #-}+ toFilePath :: a -> FilePath++-- | Paths which are relative to the local darcs repository and normalized.+-- Note: These are understood not to have the dot in front.+newtype SubPath      = SubPath FilePath deriving (Eq, Ord)++newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)++-- | This is for situations where a string (e.g. a command line argument)+-- may take the value \"-\" to mean stdin or stdout (which one depends on+-- context) instead of a normal file path.+data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)+data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)++instance FilePathOrURL AbsolutePath where+ toPath (AbsolutePath x) = x+instance FilePathOrURL SubPath where+ toPath (SubPath x) = x+instance CharLike c => FilePathOrURL [c] where+ toPath = toFilePath++instance FilePathOrURL AbsoluteOrRemotePath where+ toPath (AbsP a) = toPath a+ toPath (RmtP r) = r++instance FilePathOrURL PatchFileName.FileName where+    toPath = PatchFileName.fn2fp+instance FilePathLike PatchFileName.FileName where+    toFilePath = PatchFileName.fn2fp++instance FilePathLike AbsolutePath where+ toFilePath (AbsolutePath x) = x+instance FilePathLike SubPath where+ toFilePath (SubPath x) = x++class CharLike c where+    toChar :: c -> Char+    fromChar :: Char -> c+instance CharLike Char where+    toChar = id+    fromChar = id++instance CharLike c => FilePathLike [c] where+    toFilePath = map toChar++-- | Make the second path relative to the first, if possible+makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath+makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =+ -- The slash prevents "foobar" from being treated as relative to "foo"+ if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2+    then Just $ SubPath $ drop (length p1 + 1) p2+    else Nothing++simpleSubPath :: FilePath -> Maybe SubPath+simpleSubPath x | null x = bug "simpleSubPath called with empty path"+                | is_relative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x+                | otherwise = Nothing++-- | Interpret a possibly relative path wrt the current working directory.+ioAbsolute :: FilePath -> IO AbsolutePath+ioAbsolute dir =+    do isdir <- doesDirectoryExist dir+       here <- getCurrentDirectory+       if isdir+         then bracket (setCurrentDirectory dir)+                      (const $ setCurrentDirectory $ toFilePath here)+                      (const getCurrentDirectory)+         else let super_dir = case NativeFilePath.takeDirectory dir of+                                "" ->  "."+                                d  -> d+                  file = NativeFilePath.takeFileName dir+              in do abs_dir <- if dir == super_dir+                               then return $ AbsolutePath dir+                               else ioAbsolute super_dir+                    return $ makeAbsolute abs_dir file++-- | Take an absolute path and a string representing a (possibly relative)+-- path and combine them into an absolute path. If the second argument is+-- already absolute, then the first argument gets ignored. This function also+-- takes care that the result is converted to Posix convention and+-- normalized. Also, parent directories (\"..\") at the front of the string+-- argument get canceled out against trailing directory parts of the+-- absolute path argument.+--+-- Regarding the last point, someone more familiar with how these functions+-- are used should verify that this is indeed necessary or at least useful.+makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath+makeAbsolute a dir = if not (null dir) && is_absolute dir+                     then AbsolutePath (norm_slashes dir')+                     else ma a dir'+  where+    dir' = FilePath.normalise $ pathToPosix dir+    -- Why do we care to reduce ".." here?+    -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?+    ma here ('.':'.':'/':r) = ma (takeDirectory here) r+    ma here ".." = takeDirectory here+    ma here "." = here+    ma here "" = here+    ma here r = here /- ('/':r)++(/-) :: AbsolutePath -> String -> AbsolutePath+x /- ('/':r) = x /- r+(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)+(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)++-- | Convert to posix, remove trailing slashes, and (under Posix)+-- reduce multiple leading slashes to one.+simpleClean :: String -> String+simpleClean = norm_slashes . reverse . dropWhile (=='/') . reverse . pathToPosix++-- | The root directory as an absolute path.+rootDirectory :: AbsolutePath+rootDirectory = AbsolutePath "/"++makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd+makeAbsoluteOrStd _ "-" = APStd+makeAbsoluteOrStd a p = AP $ makeAbsolute a p++ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd+ioAbsoluteOrStd "-" = return APStd+ioAbsoluteOrStd p = AP `fmap` ioAbsolute p++-- | Execute either the first or the second argument action, depending on+-- whether the given path is an 'AbsolutePath' or stdin/stdout.+useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a+useAbsoluteOrStd _ f APStd = f+useAbsoluteOrStd f _ (AP x) = f x++ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath+ioAbsoluteOrRemote p = do+  isdir <- doesDirectoryExist p+  if not isdir+     then return $ RmtP $+          case () of _ | is_ssh_nopath p    -> p++"."+                       | "/" `isSuffixOf` p -> init p+                       | otherwise          -> p+     else AbsP `fmap` ioAbsolute p++isRemote :: AbsoluteOrRemotePath -> Bool+isRemote (RmtP _) = True+isRemote _ = False++takeDirectory :: AbsolutePath -> AbsolutePath+takeDirectory (AbsolutePath x) =+    case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of+    "" -> AbsolutePath "/"+    x' -> AbsolutePath x'++instance Show AbsolutePath where+ show = show . toFilePath+instance Show SubPath where+ show = show . toFilePath+instance Show AbsolutePathOrStd where+    show (AP a) = show a+    show APStd = "standard input/output"+instance Show AbsoluteOrRemotePath where+    show (AbsP a) = show a+    show (RmtP r) = show r++-- | Normalize the path separator to Posix style (slash, not backslash).+-- This only affects Windows systems.+pathToPosix :: FilePath -> FilePath+pathToPosix = map convert where+#ifdef WIN32+  convert '\\' = '/'+#endif+  convert c = c++-- | Reduce multiple leading slashes to one. This only affects Posix systems.+norm_slashes :: FilePath -> FilePath+#ifndef WIN32+-- multiple slashes in front are ignored under Posix+norm_slashes ('/':p) = '/' : dropWhile (== '/') p+#endif+norm_slashes p = p++getCurrentDirectory :: IO AbsolutePath+getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory++setCurrentDirectory :: FilePathLike p => p -> IO ()+setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath++{-# INLINE sp2fn #-}+sp2fn :: SubPath -> PatchFileName.FileName+sp2fn = PatchFileName.fp2fn . toFilePath
+ src/Darcs/Repository.hs view
@@ -0,0 +1,302 @@+-- Copyright (C) 2002-2004 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-}++#include "gadts.h"++module Darcs.Repository ( Repository, ($-), maybeIdentifyRepository,+                          identifyRepositoryFor,+                          withRepoLock, withRepoReadLock,+                          withRepository, withRepositoryDirectory, withGutsOf,+                          makePatchLazy, writePatchSet,+                    findRepository, amInRepository, amNotInRepository,+                    slurp_pending, replacePristineFromSlurpy,+                    slurp_recorded, slurp_recorded_and_unrecorded,+                    withRecorded,+                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,+                    read_repo, sync_repo,+                    prefsUrl,+                    add_to_pending,+                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,+                    tentativelyReplacePatches,+                    tentativelyMergePatches, considerMergeToWorking,+                    revertRepositoryChanges, finalizeRepositoryChanges,+                          createRepository, copyRepository, copy_oldrepo_patches,+                    patchSetToRepository,+                    unrevertUrl,+                    applyToWorking, patchSetToPatches,+                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,+                    optimizeInventory, cleanRepository,+                    checkPristineAgainstSlurpy, getMarkedupFile,+                    PatchSet, SealedPatchSet, PatchInfoAnd,+                    setScriptsExecutable,+                    checkUnrelatedRepos,+                    testTentative, testRecorded+                  ) where++import System.Exit ( ExitCode(..), exitWith )++import Darcs.Repository.Internal+    (Repository(..), RepoType(..), ($-), pristineFromWorking,+     maybeIdentifyRepository, identifyRepositoryFor,+     findRepository, amInRepository, amNotInRepository,+     makePatchLazy,+     slurp_pending, replacePristineFromSlurpy,+     slurp_recorded, slurp_recorded_and_unrecorded,+     withRecorded,+     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+     get_unrecorded_in_files, get_unrecorded_in_files_unsorted,+     read_repo, sync_repo,+     prefsUrl, checkPristineAgainstSlurpy,+     add_to_pending,+     withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,+     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,+     tentativelyReplacePatches,+     tentativelyMergePatches, considerMergeToWorking,+     revertRepositoryChanges, finalizeRepositoryChanges,+     unrevertUrl,+     applyToWorking, patchSetToPatches,+     createPristineDirectoryTree, createPartialsPristineDirectoryTree,+     optimizeInventory, cleanRepository,+     getMarkedupFile,+     setScriptsExecutable,+     testTentative, testRecorded+    )+import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache, HashedDir(..) )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )++import Control.Monad ( unless, when )+import Data.Either(Either(..))+import System.Directory ( createDirectory )+import System.IO.Error ( isAlreadyExistsError )++import qualified Darcs.Repository.DarcsRepo as DarcsRepo+import qualified Darcs.Repository.HashedRepo as HashedRepo++import Darcs.Hopefully ( PatchInfoAnd, info, extractHash )+import Darcs.Repository.Checkpoint ( identify_checkpoint, write_checkpoint_patch, get_checkpoint )+import Darcs.Repository.ApplyPatches ( apply_patches )+import Darcs.Repository.HashedRepo ( apply_to_tentative_pristine )+import Darcs.Patch ( RepoPatch, Named, Patch, patch2patchinfo, apply )+import Darcs.Ordered ( RL(..), bunchFL, mapFL, mapRL, mapRL_RL, concatFL, reverseRL,+                       concatRL, lengthRL, isShorterThanRL )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Repository.Format ( RepoProperty ( HashedInventory ),+                                 create_repo_format, format_has, writeRepoFormat )+import Darcs.Repository.Prefs ( write_default_prefs )+import Darcs.Repository.Pristine ( createPristine, flagsToPristine )+import Darcs.Patch.Depends ( get_patches_beyond_tag )+import Darcs.SlurpDirectory ( empty_slurpy )+import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn, prettyError )+import Darcs.External ( copyFileOrUrl, Cachable(..) )+import Progress ( debugMessage, tediousSize,+                        beginTedious, endTedious, progress )+import Darcs.ProgressPatches (progressRLShowTags, progressFL)+import Darcs.Lock ( writeBinFile )+import Darcs.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, mapFlipped )++import Darcs.Flags ( DarcsFlag( Quiet, Partial, Lazy, Ephemeral,+                                AllowUnrelatedRepos+                              ),+                     compression )+import Darcs.Global ( darcsdir )+#include "impossible.h"++createRepository :: [DarcsFlag] -> IO ()+createRepository opts = do+  createDirectory darcsdir `catch`+      (\e-> if isAlreadyExistsError e+            then fail "Tree has already been initialized!"+            else fail $ "Error creating directory `"++darcsdir++"'.")+  let rf = create_repo_format opts+  createPristine $ flagsToPristine opts rf+  createDirectory $ darcsdir ++ "/patches"+  createDirectory $ darcsdir ++ "/prefs"+  write_default_prefs+  writeRepoFormat rf (darcsdir++"/format")+  if format_has HashedInventory rf+      then writeBinFile (darcsdir++"/hashed_inventory") ""+      else DarcsRepo.write_inventory "." ((NilRL:<:NilRL) :: PatchSet Patch C(())) -- YUCK!++copyRepository :: RepoPatch p => Repository p C(r u t) -> IO ()+copyRepository fromrepository@(Repo _ opts rf _)+    | Partial `elem` opts && not (format_has HashedInventory rf) =+        do isPartial <- copyPartialRepository fromrepository+           unless (isPartial == IsPartial) $ copyFullRepository fromrepository+    | otherwise = copyFullRepository fromrepository++data PorNP = NotPartial | IsPartial+             deriving ( Eq )++data RepoSort = Hashed | Old++copyInventory :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()+copyInventory fromrepo@(Repo fromdir opts rf (DarcsRepository _ cremote)) = do+  repo@(Repo todir xx rf2 (DarcsRepository yy c)) <- identifyRepositoryFor fromrepo "."+  let newrepo :: Repository p C(r u t)+      newrepo = Repo todir xx rf2 (DarcsRepository yy (c `unionCaches` cremote))+      copyHashedHashed = HashedRepo.copy_repo newrepo opts fromdir+      copyAnythingToOld r = withCurrentDirectory todir $ read_repo r >>=+                            DarcsRepo.write_inventory_and_patches opts+      repoSort rfx | format_has HashedInventory rfx = Hashed+                   | otherwise = Old+  case repoSort rf2 of+    Hashed ->+        if format_has HashedInventory rf+        then copyHashedHashed+        else withCurrentDirectory todir $+             do HashedRepo.revert_tentative_changes+                patches <- read_repo fromrepo+                let k = "Copying patch"+                beginTedious k+                tediousSize k (lengthRL $ concatRL patches)+                let patches' = mapRL_RL (mapRL_RL (progress k)) patches+                HashedRepo.write_tentative_inventory c (compression opts) patches'+                endTedious k+                HashedRepo.finalize_tentative_changes repo (compression opts)+    Old -> case repoSort rf of+           Hashed -> copyAnythingToOld fromrepo+           _ -> copy_oldrepo_patches opts fromrepo todir++copy_oldrepo_patches :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> FilePath -> IO ()+copy_oldrepo_patches opts repository@(Repo dir _ _ _) out = do+  Sealed patches <- DarcsRepo.read_repo opts "." :: IO (SealedPatchSet Patch)+  mpi <- if Partial `elem` opts+         -- FIXME this should get last pinfo *before*+         -- desired tag...+         then identify_checkpoint repository+         else return Nothing+  FlippedSeal scp <- return $ since_checkpoint mpi $ concatRL patches+  DarcsRepo.copy_patches opts dir out $ mapRL info $ scp+      where since_checkpoint :: Maybe PatchInfo+                             -> RL (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (PatchInfoAnd p)) C(y)+            since_checkpoint Nothing ps = flipSeal ps+            since_checkpoint (Just ch) (hp:<:ps)+                | ch == info hp = flipSeal $ hp :<: NilRL+                | otherwise = (hp :<:) `mapFlipped` since_checkpoint (Just ch) ps+            since_checkpoint _ NilRL = flipSeal NilRL++copyPartialRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO PorNP+copyPartialRepository fromrepository@(Repo _ opts _ _) = do+  mch <- get_checkpoint fromrepository :: IO (Maybe (Sealed (Named p C(x))))+  case mch of+    Nothing -> do putStrLn "No checkpoint."+                  return NotPartial+    Just (Sealed ch) ->+      do copyInventory fromrepository+         withRepoLock opts $- \torepository -> do+           write_checkpoint_patch ch+           local_patches <- read_repo torepository+           let pi_ch = patch2patchinfo ch+           FlippedSeal ps <- return $ get_patches_beyond_tag pi_ch local_patches+           let needed_patches = reverseRL $ concatRL ps+           apply opts ch `catch`+                             \e -> fail ("Bad checkpoint!\n" ++ prettyError e)+           apply_patches opts needed_patches+           debugMessage "Writing the pristine"+           pristineFromWorking torepository+           return IsPartial++copyFullRepository :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> IO ()+copyFullRepository fromrepository@(Repo fromdir opts rffrom _) = do+  copyInventory fromrepository+  debugMessage "Copying prefs"+  copyFileOrUrl opts (fromdir++"/"++darcsdir++"/prefs/prefs") (darcsdir++"/prefs/prefs") (MaxAge 600)+                     `catchall` return ()+  debugMessage "Grabbing lock in new repository..."+  withRepoLock opts $- \torepository@(Repo _ _ rfto (DarcsRepository _ c)) ->+      if format_has HashedInventory rffrom && format_has HashedInventory rfto+      then do debugMessage "Writing working directory contents..."+              createPristineDirectoryTree torepository "."+              fetch_patches_if_necessary opts torepository+              when (Partial `elem` opts) $ putStrLn $+                       "--partial: hashed or darcs-2 repository detected, using --lazy instead"+      else if format_has HashedInventory rfto+           then do local_patches <- read_repo torepository+                   replacePristineFromSlurpy torepository empty_slurpy+                   let patchesToApply = progressFL "Applying patch" $ concatFL $ reverseRL $+                                        mapRL_RL reverseRL local_patches+                   sequence_ $ mapFL (apply_to_tentative_pristine c opts) $ bunchFL 100 patchesToApply+                   finalizeRepositoryChanges torepository+                   debugMessage "Writing working directory contents..."+                   createPristineDirectoryTree torepository "."+           else do read_repo torepository >>= (apply_patches opts . reverseRL . concatRL)+                   debugMessage "Writing the pristine"+                   pristineFromWorking torepository++-- | writePatchSet is like patchSetToRepository, except that it doesn't+-- touch the working directory or pristine cache.+writePatchSet :: RepoPatch p => PatchSet p C(x) -> [DarcsFlag] -> IO (Repository p C(r u t))+writePatchSet patchset opts = do+    maybeRepo <- maybeIdentifyRepository opts "."+    let repo@(Repo _ _ rf2 (DarcsRepository _ c)) = +          case maybeRepo of+            Right r -> r+            Left e  -> bug ("Current directory not repository in writePatchSet: " ++ e)+    debugMessage "Writing inventory"+    if format_has HashedInventory rf2+       then do HashedRepo.write_tentative_inventory c (compression opts) patchset+               HashedRepo.finalize_tentative_changes repo (compression opts)+       else DarcsRepo.write_inventory_and_patches opts patchset+    return repo++-- | patchSetToRepository takes a patch set, and writes a new repository in the current directory+--   that contains all the patches in the patch set. This function is used when 'darcs get'ing a+--   repository with the --to-match flag and the new repository is not in hashed format.+--   This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell +--   darcs to create a hashed repository, this function will call @error@.+patchSetToRepository :: RepoPatch p => Repository p C(r1 u1 r1) -> PatchSet p C(x)+                     -> [DarcsFlag] -> IO (Repository p C(r u t))+patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do+    when (format_has HashedInventory rf) $ -- set up sources and all that+       do writeFile "_darcs/tentative_pristine" "" -- this is hokey+          repox <- writePatchSet patchset opts+          HashedRepo.copy_repo repox opts fromrepo+    repo <- writePatchSet patchset opts+    read_repo repo >>= (apply_patches opts . reverseRL . concatRL)+    debugMessage "Writing the pristine"+    pristineFromWorking repo+    return repo++checkUnrelatedRepos :: [DarcsFlag] -> [PatchInfo] -> PatchSet p C(x) -> PatchSet p C(x) -> IO ()+checkUnrelatedRepos opts common us them+    | AllowUnrelatedRepos `elem` opts || not (null common)+       || concatRL us `isShorterThanRL` 5 || concatRL them `isShorterThanRL` 5+        = return ()+    | otherwise+        = do yorn <- promptYorn ("Repositories seem to be unrelated. Proceed?")+             when (yorn /= 'y') $ do putStrLn "Cancelled."+                                     exitWith ExitSuccess++-- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,+--   --partial or --ephemeral), this function fetches all patches that the given repository has +--   with fetchFileUsingCache. This is used as a helper in copyFullRepository.+fetch_patches_if_necessary :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t) -> IO ()+fetch_patches_if_necessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) = +    unless (Partial `elem` opts || Lazy `elem` opts || Ephemeral `elem` opts) $+             do putInfo "Copying patches, to get lazy repository hit ctrl-C..."+                r <- read_repo torepository+                let peekaboo :: PatchInfoAnd p C(x y) -> IO ()+                    peekaboo x = case extractHash x of+                                 Left _ -> return ()+                                 Right h -> fetchFileUsingCache c HashedPatchesDir h >> return ()+                sequence_ $ mapRL peekaboo $ progressRLShowTags "Copying patches" $ concatRL r+  where putInfo = when (not $ Quiet `elem` opts) . putStrLn
+ src/Darcs/Repository/ApplyPatches.hs view
@@ -0,0 +1,50 @@+-- Copyright (C) 2002-2005,2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.ApplyPatches ( apply_patches, apply_patches_with_feedback ) where++import Darcs.Patch ( Patchy, apply )+import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import Darcs.Patch.Info ( human_friendly )+import Darcs.Ordered ( FL(..), lengthFL, mapFL )+import Darcs.Flags ( DarcsFlag )+import Darcs.Utils ( putDocLnError )+import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )+import Printer ( text )++apply_patches_with_feedback :: Patchy p => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO ()+apply_patches_with_feedback _ _ NilFL = return ()+apply_patches_with_feedback opts k patches =+    do beginTedious k+       tediousSize k (lengthFL patches)+       sequence_ $ mapFL apply_cautiously patches+       endTedious k+    where apply_cautiously :: Patchy p => PatchInfoAnd p C(a b) -> IO ()+          apply_cautiously hp =+             do finishedOneIO k (show $ human_friendly $ info hp)+                apply opts (hopefully hp) `catch` \e ->+                  do putDocLnError $ text "Unapplicable patch:"+                     putDocLnError $ human_friendly (info hp)+                     ioError e++apply_patches :: Patchy p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()+apply_patches opts ps = apply_patches_with_feedback opts "Applying patch" ps
+ src/Darcs/Repository/Cache.hs view
@@ -0,0 +1,276 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.Cache (+                   cacheHash, okayHash, takeHash,+                   Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..),+                   HashedDir(..), hashedDir,+                   unionCaches, cleanCaches, cleanCachesWithHint,+                   fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,+                   findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache,+                   repo2cache,+                   writable, hashedFilePath, allHashedDirs+                 ) where++import Control.Monad ( liftM, when, guard )+import Data.List ( nub )+import Data.Maybe ( listToMaybe )+import System.Directory ( removeFile, doesFileExist, getDirectoryContents )+import System.Posix ( setFileTimes )+import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus )+import System.Posix.Types ( EpochTime )+import System.IO ( hPutStrLn, stderr )++import Crypt.SHA256 ( sha256sum )++import ByteStringUtils ( gzWriteFilePS, linesPS )+import qualified Data.ByteString as B (length, drop, ByteString )+import qualified Data.ByteString.Char8 as BC (unpack)++import SHA1 ( sha1PS )+import System.Posix.Files ( createLink )+import System.Directory ( createDirectoryIfMissing )++import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,+                        Cachable( Cachable ) )+import Darcs.Flags ( Compression( .. ) )+import Darcs.Global ( darcsdir )+import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS )+import Progress ( progressList, debugMessage, debugFail )+import Darcs.SlurpDirectory ( undefined_time )+import Darcs.URL ( is_file )+import Darcs.Utils ( withCurrentDirectory, catchall )++data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir+hashedDir :: HashedDir -> String+hashedDir HashedPristineDir = "pristine.hashed"+hashedDir HashedPatchesDir = "patches"+hashedDir HashedInventoriesDir = "inventories"++allHashedDirs :: [HashedDir]+allHashedDirs = [HashedPristineDir, HashedPatchesDir, HashedInventoriesDir]++data WritableOrNot = Writable | NotWritable deriving ( Show )+data CacheType = Repo | Directory deriving ( Eq, Show )+data CacheLoc = Cache !CacheType !WritableOrNot !String+newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache++instance Eq CacheLoc where+    (Cache Repo _ a) == (Cache Repo _ b) = a == b+    (Cache Directory _ a) == (Cache Directory _ b) = a == b+    _ == _ = False+instance Show CacheLoc where+    show (Cache Repo Writable a) = "thisrepo:" ++ a+    show (Cache Repo NotWritable a) = "repo:" ++ a+    show (Cache Directory Writable a) = "cache:" ++ a+    show (Cache Directory NotWritable a) = "readonly:" ++ a+instance Show Cache where+    show (Ca cs) = unlines $ map show cs++unionCaches :: Cache -> Cache -> Cache+unionCaches (Ca a) (Ca b) = Ca (nub (a++b))++repo2cache :: String -> Cache+repo2cache r = Ca [Cache Repo NotWritable r]++-- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string.+cacheHash :: B.ByteString -> String+cacheHash ps = case show (B.length ps) of+                 x | l > 10 -> sha256sum ps+                   | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps+                                        where l = length x++okayHash :: String -> Bool+okayHash s = length s == 40 || length s == 64 || length s == 75++takeHash :: B.ByteString -> Maybe (String, B.ByteString)+takeHash ps = do h <- listToMaybe $ linesPS ps+                 let v = BC.unpack h+                 guard $ okayHash v+                 Just (v, B.drop (B.length h) ps)++checkHash :: String -> B.ByteString -> Bool+checkHash h s | length h == 40 = sha1PS s == h+              | length h == 64 = sha256sum s == h+              | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h+              | otherwise = False+++findFileMtimeUsingCache :: Cache -> HashedDir -> String -> IO EpochTime+findFileMtimeUsingCache (Ca cache) subdir f = mt cache+    where mt [] = return undefined_time+          mt (Cache Repo Writable r:_) = (modificationTime `fmap`+                                          getSymbolicLinkStatus (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f))+                                         `catchall` return undefined_time+          mt (_:cs) = mt cs++setFileMtimeUsingCache :: Cache -> HashedDir -> String -> EpochTime -> IO ()+setFileMtimeUsingCache (Ca cache) subdir f t = st cache+    where st [] = return ()+          st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++(hashedDir subdir)++"/"++f) t t+                                         `catchall` return ()+          st (_:cs) = st cs++fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString)+fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere++writable :: CacheLoc -> Bool+writable (Cache _ NotWritable _) = False+writable (Cache _ Writable _) = True++-- | @hashedFilePath cachelocation subdir hash@ returns the physical filename of+-- hash @hash@ in the @subdir@ section of @cachelocation@.+hashedFilePath :: CacheLoc -> HashedDir -> String -> String+hashedFilePath (Cache Directory _ d) s f = d ++ "/" ++ (hashedDir s) ++ "/" ++ f+hashedFilePath (Cache Repo _ r) s f =+    r ++ "/"++darcsdir++"/" ++ (hashedDir s) ++ "/" ++ f++-- | @peekInCache cache subdir hash@ tells whether @cache@ and+-- contains an object with hash @hash@ in a writable position.+-- Florent: why do we want it to be in a writable position?+peekInCache :: Cache -> HashedDir -> String -> IO Bool+peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False+    where cacheHasIt [] = return False+          cacheHasIt (c:cs) | not $ writable c = cacheHasIt cs+                            | otherwise = do ex <- doesFileExist $ fn c+                                             if ex then return True+                                                   else cacheHasIt cs+          fn c = hashedFilePath c subdir f++-- | @speculateFileUsingCache cache subdirectory name@ takes note that+-- the file @name@ is likely to be useful soon: pipelined downloads+-- will add it to the (low-priority) queue, for the rest it is a noop.+speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()+speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h+                                    copyFileUsingCache OnlySpeculate c sd h++data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )++copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()+copyFileUsingCache oos (Ca cache) subdir f =+    do debugMessage $ "I'm doing copyFileUsingCache on "++(hashedDir subdir)++"/"++f+       Just stickItHere <- cacheLoc cache+       createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)+       sfuc cache stickItHere+    `catchall` return ()+    where cacheLoc [] = return Nothing+          cacheLoc (c:cs) | not $ writable c = cacheLoc cs+                          | otherwise =+              do ex <- doesFileExist $ fn c+                 if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"+                       else do othercache <- cacheLoc cs+                               case othercache of Just x -> return $ Just x+                                                  Nothing -> return $ Just (fn c)+          sfuc [] _ = return ()+          sfuc (c:cs) out | not $ writable c =+              if oos == OnlySpeculate+                 then speculateFileOrUrl (fn c) out+                 else copyFileOrUrl [] (fn c) out Cachable+                          | otherwise = sfuc cs out+          fn c = hashedFilePath c subdir f+++data FromWhere = LocalOnly | Anywhere deriving ( Eq )++fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String -> IO (String, B.ByteString)+fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =+    do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f+       ffuc cache+    `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++(hashedDir subdir)+++                          " from sources:\n\n"++show (Ca cache))+    where ffuc (c:cs)+           | not (writable c) && (Anywhere == fromWhere || is_file (fn c)) =+              do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"+                 debugMessage $ "    getting "++f+                 debugMessage $ "    from " ++ fn c+                 x <- gzFetchFilePS (fn c) Cachable+                 if not $ checkHash f x+                    then do x' <- fetchFilePS (fn c) Cachable+                            when (not $ checkHash f x') $+                                 do hPutStrLn stderr $ "Hash failure in " ++ fn c+                                    fail $ "Hash failure in " ++ fn c+                            return (fn c, x')+                    else return (fn c, x) -- FIXME: create links in caches+              `catchall` ffuc cs++           | writable c =+              do x1 <- gzFetchFilePS (fn c) Cachable+                 x <- if not $ checkHash f x1+                      then do x2 <- fetchFilePS (fn c) Cachable+                              when (not $ checkHash f x2) $+                                 do hPutStrLn stderr $ "Hash failure in " ++ fn c+                                    removeFile $ fn c+                                    fail $ "Hash failure in " ++ fn c+                              return x2+                      else return x1+                 mapM_ (tryLinking (fn c)) cs+                 return (fn c, x)+              `catchall` do (fname,x) <- ffuc cs+                            do createCache c subdir+                               createLink fname (fn c)+                               return (fn c, x)+                             `catchall`+                             do gzWriteFilePS (fn c) x `catchall` return ()+                                return (fname,x)+           | otherwise = ffuc cs++          ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)++          tryLinking ff c@(Cache Directory Writable d) =+              do createDirectoryIfMissing False (d++"/"++(hashedDir subdir))+                 createLink ff (fn c)+              `catchall` return ()+          tryLinking _ _ = return ()+          fn c = hashedFilePath c subdir f++createCache :: CacheLoc -> HashedDir -> IO ()+createCache (Cache Directory _ d) subdir =+    createDirectoryIfMissing True (d ++ "/" ++ (hashedDir subdir))+createCache _ _ = return ()++-- | @write compression filename content@ writes @content@ to the file @filename@ according+-- to the policy given by @compression@.+write :: Compression -> String -> B.ByteString -> IO ()+write NoCompression = writeAtomicFilePS+write GzipCompression = gzWriteAtomicFilePS++-- | @writeFileUsingCache cache compression subdir contents@ write the string @contents@ to+-- the directory subdir, except if it is already in the cache, in which case it is a noop.+-- Warning (?) this means that in case of a hash collision, writing using writeFileUsingCache is+-- a noop. The returned value is the filename that was given to the string.+writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString -> IO String+writeFileUsingCache (Ca cache) compr subdir ps =+    (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`+    wfuc cache `catchall`+         debugFail ("Couldn't write `"++hash++"'\nin subdir "++(hashedDir subdir)++" to sources:\n\n"+++                    show (Ca cache))+    where hash = cacheHash ps+          wfuc (c:cs) | not $ writable c = wfuc cs+                      | otherwise = do createCache c subdir+                                       write compr (fn c) ps -- FIXME: create links in caches+                                       return hash+          wfuc [] = debugFail $ "No location to write file `" ++ (hashedDir subdir) ++"/"++hash ++ "'"+          fn c = hashedFilePath c subdir hash++cleanCaches :: Cache -> HashedDir -> IO ()+cleanCaches c d = cleanCachesWithHint' c d Nothing++cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()+cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)++cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()+cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs+    where cleanCache (Cache Directory Writable d) =+             (withCurrentDirectory (d++"/"++(hashedDir subdir)) $+              do fs' <- getDirectoryContents "."+                 let fs = case hint of+                            Just h -> h+                            Nothing -> fs'+                 mapM_ clean $ progressList ("Cleaning cache "++d++"/"++(hashedDir subdir)) $+                       filter okayHash fs) `catchall` return ()+          cleanCache _ = return ()+          clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f+                       when (lc < 2) $ removeFile f+                    `catchall` return ()
+ src/Darcs/Repository/Checkpoint.hs view
@@ -0,0 +1,174 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.Checkpoint ( get_checkpoint, get_checkpoint_by_default,+                                     identify_checkpoint,+                                     write_checkpoint, write_recorded_checkpoint,+                                     write_checkpoint_patch,+                                   ) where++import System.Directory ( setCurrentDirectory, createDirectoryIfMissing )+import Workaround ( getCurrentDirectory )+import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.Maybe ( listToMaybe, catMaybes )+import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )+import qualified Data.ByteString as B ( null, empty, ByteString )++import Darcs.Lock ( withTempDir, writeDocBinFile )+import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, mmap_slurp, )+import Darcs.Patch ( RepoPatch, Patch, Named, Prim, invertRL, patch2patchinfo,+                     apply_to_slurpy, patchcontents,+                     effect, fromPrims,+                     is_setpref, infopatch,+                     readPatch,+                     gzWritePatch+                   )+import Darcs.Ordered ( RL(..), FL(..), EqCheck(IsEq,NotEq),+                             (+>+), filterFL, unsafeCoerceP,+                             mapRL, mapFL_FL, mapRL_RL, reverseRL, concatRL, concatFL )+import Darcs.Repository.Internal ( Repository(..), read_repo, slurp_recorded, withRecorded )+import Darcs.Repository.ApplyPatches ( apply_patches )+import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,+                          showPatchInfo+                        )+import Darcs.Diff ( unsafeDiff )+import Darcs.External ( gzFetchFilePS, fetchFilePS, Cachable(..) )+import Darcs.Flags ( DarcsFlag(LookForAdds, Partial, Complete ) )+import Darcs.Patch.Depends ( get_patches_beyond_tag, get_patches_in_tag )+import Darcs.Repository.Prefs ( filetype_function )+import Darcs.Utils ( catchall )+import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Darcs.Global ( darcsdir )+import Printer ( Doc, ($$), empty )+#include "impossible.h"+import Darcs.Sealed ( Sealed(Sealed), FlippedSeal(..), Sealed2(Sealed2), seal, seal2 )+import Control.Monad ( liftM )++read_patch_ids :: B.ByteString -> [PatchInfo]+read_patch_ids inv | B.null inv = []+read_patch_ids inv = case readPatchInfo inv of+                     Just (pinfo,r) -> pinfo : read_patch_ids r+                     Nothing -> []++read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]+read_checkpoints d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable+           `catchall` return B.empty+  pis <- return $ reverse $ read_patch_ids pistr+  slurpies <- sequence $ map (fetch_checkpoint realdir) pis+  return $ zip pis slurpies+      where fetch_checkpoint r pinfo =+                unsafeInterleaveIO $ do+                pstr <- gzFetchFilePS+                    (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable+                case fst `fmap` (readPatch pstr :: Maybe (Sealed (Named Patch C(x)), B.ByteString)) of+                  Nothing -> return Nothing+                  Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy++get_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))+get_checkpoint repository@(Repo _ opts _ _) = if Partial `elem` opts+                                              then get_check_internal repository+                                              else return Nothing++get_checkpoint_by_default :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))+get_checkpoint_by_default repository@(Repo _ opts _ _) = if Complete `elem` opts+                                                         then return Nothing+                                                         else get_check_internal repository++identify_checkpoint :: RepoPatch p => Repository p C(r u t) -> IO (Maybe PatchInfo)+identify_checkpoint repository@(Repo r _ _ _) = do+  pis <- (map sp2i . catMaybes . mapRL lastRL) `liftM` read_repo repository+  pistr <- fetchFilePS (r++"/"++darcsdir++"/checkpoints/inventory") Uncachable+           `catchall` return B.empty+  return $ listToMaybe $ filter (`elem` pis) $ reverse $ read_patch_ids pistr+    where lastRL :: RL a C(x y) -> Maybe (Sealed2 a)+          lastRL as = do Sealed ps <- headFL (reverseRL as)+                         return $ seal2 ps+          headFL :: FL a C(x y) -> Maybe (Sealed (a C(x)))+          headFL (x:>:_) = Just $ seal x+          headFL NilFL = Nothing+          sp2i :: Sealed2 (PatchInfoAnd p) -> PatchInfo+          sp2i (Sealed2 p) = info p++get_check_internal :: RepoPatch p => Repository p C(r u t) -> IO (Maybe (Sealed (Named p C(x))))+get_check_internal repository@(Repo r _ _ _) = do+  mc <- identify_checkpoint repository+  case mc of+    Nothing -> return Nothing+    Just pinfo ->  do ps <- gzFetchFilePS+                            (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable+                      return $ case readPatch ps of+                               Just (p, _) -> Just p+                               Nothing -> Nothing++format_inv :: [PatchInfo] -> Doc+format_inv [] = empty+format_inv (pinfo:ps) = showPatchInfo pinfo+                     $$ format_inv ps++write_recorded_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()+write_recorded_checkpoint r@(Repo _ _ _ _) pinfo = do+    Sealed ps <- (seal . mapFL_FL hopefully.reverseRL.concatRL) `liftM` read_repo r+    ftf <- filetype_function+    s <- slurp_recorded r+    write_checkpoint_patch $ infopatch pinfo+        (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))+    where changeps = filterFL is_setprefFL .+                     effect . patchcontents+          changepps = concatFL . mapFL_FL changeps++is_setprefFL :: Prim C(x y) -> EqCheck C(x y)+is_setprefFL p | is_setpref p = NotEq+               | otherwise = unsafeCoerceP IsEq++write_checkpoint :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> IO ()+write_checkpoint repo@(Repo _ _ _ _) pinfo = do+    repodir <- getCurrentDirectory+    Sealed pit <- get_patches_in_tag pinfo `liftM` read_repo repo+    let ps = (reverseRL.mapRL_RL hopefully.concatRL) pit+    ftf <- filetype_function+    with_tag repo pinfo $ do+      s <- mmap_slurp "."+      setCurrentDirectory repodir+      write_checkpoint_patch $ infopatch pinfo $+          (fromPrims $ changepps ps +>+ unsafeDiff [LookForAdds] ftf empty_slurpy s :: Patch C(() y))+    where changeps = filterFL is_setprefFL .+                     effect . patchcontents+          changepps = concatFL . mapFL_FL changeps++write_checkpoint_patch :: RepoPatch p => Named p C(x y) -> IO ()+write_checkpoint_patch p =+ do createDirectoryIfMissing False (darcsdir++"/checkpoints")+    gzWritePatch (darcsdir++"/checkpoints/"++make_filename (patch2patchinfo p)) p+    cpi <- (map fst) `fmap` read_checkpoints "."+    writeDocBinFile (darcsdir++"/checkpoints/inventory")+        $ format_inv $ reverse $ patch2patchinfo p:cpi++with_tag :: RepoPatch p  => Repository p C(r u t) -> PatchInfo -> (IO ()) -> IO ()+with_tag r pinfo job = do+    ps <- read_repo r+    case get_patches_beyond_tag pinfo ps of+        FlippedSeal (extras :<: NilRL) -> withRecorded r (withTempDir "checkpoint") $ \_ -> do+                                            apply_patches [] $ invertRL extras+                                            job+        _ -> bug "with_tag"
+ src/Darcs/Repository/DarcsRepo.lhs view
@@ -0,0 +1,344 @@+%  Copyright (C) 2002-2005,2007-2008 David Roundy+%+%  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.++\chapter{DarcsRepo format}++A repository consists of a working directory, which has within it a+directory called \verb!_darcs!. There must also be a subdirectory within+\verb!_darcs! named \verb!patches!.  The \verb!patches! directory contains+the actual patches which are in the repository.  There must also be a+\emph{pristine tree}, which may either be a directory containing a cache of+the version of the tree which has been recorded, or a stub, and may be+named either ``current'' or ``pristine''.++\emph{WARNING!} Viewing files in the pristine cache is perfectly+acceptable, but if you view them with an editor (e.g.\ vi or Emacs), that+editor may create temporary files in the pristine tree+(\verb|_darcs/pristine/| or \verb|_darcs/current/|), which will temporarily+cause your repository to be inconsistent.  So \emph{don't record any+patches while viewing files in \_darcs/current with an editor!}  A better+plan would be to restrict yourself to viewing these files with a pager such+as more or less.++Also within \verb!_darcs! is the \verb!inventory! file, which lists all the+patches that are in the repository. Moreover, it also gives the order of the+representation of the patches as they are stored. Given a source of patches,+i.e.\ any other set of repositories which have between them all the patches+contained in a given repository, that repository can be reproduced based on only the+information in the \verb!inventory! file. Under those circumstances, the+order of the patches specified in the \verb!inventory! file would be+unimportant, as this order is only needed to provide context for the+interpretation of the stored patches in this repository.++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-}++#include "gadts.h"++module Darcs.Repository.DarcsRepo ( write_inventory, write_inventory_and_patches,+                                    add_to_inventory, add_to_tentative_pristine,+                                    add_to_tentative_inventory, remove_from_tentative_inventory,+                                    finalize_tentative_changes, finalize_pristine_changes,+                                    revert_tentative_changes,+                                    read_repo, read_tentative_repo, write_and_read_patch,+                                    copy_patches+                                  ) where++import System.Directory ( doesDirectoryExist, createDirectoryIfMissing )+import Workaround ( renameFile )+import Darcs.Utils ( clarify_errors )+import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )+import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import System.IO ( hPutStrLn, stderr )+import System.IO.Unsafe ( unsafeInterleaveIO )+import Control.Monad ( liftM, when, unless )+import Darcs.Hopefully ( Hopefully, PatchInfoAnd,+                         patchInfoAndPatch, info,+                         actually, hopefully, unavailable, n2pia )+import Darcs.SignalHandler ( withSignalsBlocked )++import ByteStringUtils ( gzReadFilePS )+import qualified Data.ByteString as B (ByteString, null, readFile, empty)+import qualified Data.ByteString.Char8 as BC (break, pack)++import Darcs.SlurpDirectory ( Slurpy, empty_slurpy )+import Darcs.Patch ( RepoPatch, Effect, Prim, Named, Patch, invert,+                     effect,+                     patch2patchinfo,+                     apply_to_slurpy,+                     readPatch,+                     writePatch, gzWritePatch, showPatch )+import Darcs.Ordered ( FL(..), RL(..), (:<)(..),+                             reverseFL, mapFL, unsafeCoerceP,+                             reverseRL, concatRL, mapRL, mapRL_RL )+import Darcs.Patch.Info ( PatchInfo, make_filename, readPatchInfo,+                          showPatchInfo, is_tag+                 )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..),+                        cloneFile )+import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile )+import Darcs.Flags ( DarcsFlag( NoCompress ) )+import Darcs.Patch.Depends ( slightly_optimize_patchset, commute_to_end, deep_optimize_patchset )+import Darcs.Repository.Pristine ( identifyPristine, applyPristine )+import Darcs.Global ( darcsdir )+import Darcs.Utils ( catchall )+import Darcs.ProgressPatches ( progressFL )+import Printer ( text, (<>), Doc, ($$), empty )+import Darcs.Sealed ( Sealed(Sealed), seal, unseal )+\end{code}++There is a very special patch which may be stored in \verb!patches! which+is called `pending'.  This patch describes any changes which have not yet+been recorded, and cannot be determined by a simple diff.  For example, file+additions or renames are placed in pending until they are recorded.+Similarly, token replaces are stored in pending until they are recorded.++\begin{code}+write_patch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath+write_patch opts p =+       do let writeFun = if NoCompress `elem` opts+                         then writePatch+                         else gzWritePatch+              pname = darcsdir++"/patches/"++make_filename (patch2patchinfo p)+          writeFun pname p+          return pname++write_and_read_patch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y)+                     -> IO (PatchInfoAnd p C(x y))+write_and_read_patch opts p = do fn <- write_patch opts $ hopefully p+                                 unsafeInterleaveIO $ parse fn+    where parse fn = do debugMessage ("Reading patch file: "++ fn)+                        ps <- gzReadFilePS fn+                        Sealed pp <- case readPatch ps of+                                    Just (x,_) -> return x+                                    Nothing -> fail ("Couldn't parse patch file "++fn)+                        return $ n2pia $ unsafeCoerceP pp++--format_inventory is not exported for use outside of the DarcsRepo module+--itself.+format_inventory :: [PatchInfo] -> Doc+format_inventory [] = empty+format_inventory (pinfo:ps) = showPatchInfo pinfo $$ format_inventory ps++write_inventory :: RepoPatch p => FilePath -> PatchSet p C(x) -> IO ()+-- Note that write_inventory optimizes the inventory it writes out by+-- checking on tag dependencies.+-- FIXME: There is also a problem that write_inventory always writes+-- out the entire inventory, including the parts that you haven't+-- changed...+write_inventory dir ps = withSignalsBlocked $ do+    createDirectoryIfMissing False (dir++"/"++darcsdir++"/inventories")+    simply_write_inventory "inventory" dir $ slightly_optimize_patchset ps++simply_write_inventory :: RepoPatch p => String -> FilePath -> PatchSet p C(x) -> IO ()+simply_write_inventory name dir NilRL =+    writeBinFile (dir++"/"++darcsdir++"/"++name) ""+simply_write_inventory name dir (ps:<:NilRL) = do+    writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ format_inventory $ mapFL info $ reverseRL ps+simply_write_inventory _ _ (NilRL:<:_) =+    fail $ "Bug in simply_write_inventory, please report!"+simply_write_inventory name dir (ps:<:pss) = do+    tagname <- return $ make_filename $ last $ mapRL info ps+    simply_write_inventory ("inventories/"++tagname) dir pss+    writeDocBinFile (dir++"/"++darcsdir++"/"++name) $ text "Starting with tag:"+                                           $$ format_inventory (mapFL info $ reverseRL ps)++write_inventory_and_patches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(x) -> IO ()+write_inventory_and_patches opts ps = do write_inventory "." ps+                                         sequence_ $ mapRL (write_patch opts . hopefully) $ concatRL ps++add_to_inventory :: FilePath -> [PatchInfo] -> IO ()+add_to_inventory dir pinfos =+    appendDocBinFile (dir++"/"++darcsdir++"/inventory") $ text "\n" <> pidocs pinfos+    where+        pidocs [] = text ""+        pidocs (p:ps) = showPatchInfo p $$ pidocs ps++add_to_tentative_inventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath+add_to_tentative_inventory opts p =+    do appendDocBinFile (darcsdir++"/tentative_inventory") $ text "\n"+                            <> showPatchInfo (patch2patchinfo p)+       when (is_tag $ patch2patchinfo p) $+            do debugMessage "Optimizing the tentative inventory, since we're adding a tag."+               realdir <- toPath `fmap` ioAbsoluteOrRemote "."+               let k = "Reading tentative inventory"+               beginTedious k+               Sealed ps <- read_repo_private k opts realdir "tentative_inventory"+                            :: IO  (SealedPatchSet p)+               simply_write_inventory "tentative_inventory" "." $ slightly_optimize_patchset ps+       write_patch opts p++add_to_tentative_pristine :: Effect p => p C(x y) -> IO ()+add_to_tentative_pristine p =+    do -- Sealed p <- (fst . fromJust . readPatchCarefully) `fmap` gzReadFilePS fp+       appendDocBinFile (darcsdir++"/tentative_pristine") $ showPatch (effect p) -- FIXME: this is inefficient!+       appendBinFile (darcsdir++"/tentative_pristine") "\n"++remove_from_tentative_inventory :: RepoPatch p => Bool -> [DarcsFlag] -> FL (Named p) C(x y) -> IO ()+remove_from_tentative_inventory update_pristine opts to_remove =+    do finalize_tentative_changes+       Sealed allpatches <- read_repo opts "."+       skipped :< unmodified <- return $ commute_to_end (unsafeCoerceP to_remove) allpatches+       sequence_ $ mapFL (write_patch opts) skipped+       write_inventory "." $ deep_optimize_patchset+                           $ mapRL_RL n2pia (reverseFL skipped) :<: unmodified+       remove_from_checkpoint_inventory to_remove+       when update_pristine $+            do pris <- identifyPristine+               repairable $ applyPristine pris+                              $ progressFL "Applying inverse to pristine" $ invert to_remove+       revert_tentative_changes++finalize_tentative_changes :: IO ()+finalize_tentative_changes = renameFile (darcsdir++"/tentative_inventory") (darcsdir++"/inventory")++finalize_pristine_changes :: IO ()+finalize_pristine_changes =+    do Sealed ps <- read_patches $ darcsdir++"/tentative_pristine"+       pris <- identifyPristine+       repairable $ applyPristine pris ps+    where +      read_patches :: String -> IO (Sealed (FL Prim C(x)))+      read_patches f = do ps <- B.readFile f+                          return $ case readPatch ps of+                                   Just (x, _) -> x+                                   Nothing -> seal $ NilFL++repairable :: IO a -> IO a+repairable x = x `clarify_errors` unlines+               ["Your repository is now in an inconsistent state.",+                "This must be fixed by running darcs repair."]++revert_tentative_changes :: IO ()+revert_tentative_changes =+    do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory")+       writeBinFile (darcsdir++"/tentative_pristine") ""++copy_patches :: [DarcsFlag] -> FilePath -> FilePath -> [PatchInfo] -> IO ()+copy_patches opts dir out patches = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote dir+  copyFilesOrUrls opts (realdir++"/"++darcsdir++"/patches") (map make_filename patches)+                       (out++"/"++darcsdir++"/patches") Cachable++read_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p)+read_repo opts d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  let k = "Reading inventory of repository "++d+  beginTedious k+  read_repo_private k opts realdir "inventory" `catch`+                        (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)+                                  ioError e)++read_tentative_repo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p)+read_tentative_repo opts d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  let k = "Reading tentative inventory of repository "++d+  beginTedious k+  read_repo_private k opts realdir "tentative_inventory" `catch`+                        (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)+                                  ioError e)++read_repo_private :: RepoPatch p => String -> [DarcsFlag] -> FilePath -> FilePath -> IO (SealedPatchSet p)+read_repo_private k opts d iname = do+    i <- gzFetchFilePS (d++"/"++darcsdir++"/"++iname) Uncachable+    finishedOneIO k iname+    (rest,str) <- case BC.break ((==) '\n') i of+                  (swt,pistr) | swt == BC.pack "Starting with tag:" ->+                    do r <- rr $ head $ read_patch_ids pistr+                       return (r,pistr)+                  _ -> do endTedious k+                          return (seal NilRL,i)+    pis <- return $ reverse $ read_patch_ids str+    isdir <- doesDirectoryExist d+    let parse f = let fn = d ++ "/"++darcsdir++"/patches/" ++ make_filename f+                  in if isdir then parse_local fn+                              else parse_remote fn+    lift2Sealed (:<:) (return rest) (read_patches parse pis)+    where rr pinfo = unsafeInterleaveIO $ read_repo_private k opts d $+                     "inventories/"++make_filename pinfo+          -- parse_remote should really download to a temporary file removed+          -- at exit+          parse_remote, parse_local :: RepoPatch p => String -> IO (Sealed (Hopefully (Named p) C(x)))+          parse_remote fn = do ps <- gzFetchFilePS fn Cachable+                               return $ hopefullyNoParseError fn (readPatch ps)+          parse_local fn = do ps <- gzReadFilePS fn+                              return $ hopefullyNoParseError fn (readPatch ps)+          hopefullyNoParseError :: String -> Maybe (Sealed (a C(x)), b) -> Sealed (Hopefully a C(x))+          hopefullyNoParseError _ (Just (Sealed x, _)) = seal $ actually x+          hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s+          read_patches :: RepoPatch p => (FORALL(b) PatchInfo -> IO (Sealed (Hopefully (Named p) C(b))))+                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))+          read_patches _ [] = return $ seal NilRL+          read_patches parse (i:is) =+              lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)+                          (read_patches parse is)+                          (parse i `catch` \e -> return $ seal $ unavailable $ show e)+          lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))+                      -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x)))+          lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox+                                     Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy+                                     return $ seal $ f y x++read_patch_ids :: B.ByteString -> [PatchInfo]+read_patch_ids inv | B.null inv = []+read_patch_ids inv = case readPatchInfo inv of+                     Just (pinfo,r) -> pinfo : read_patch_ids r+                     Nothing -> []++read_checkpoints :: String -> IO [(PatchInfo, Maybe Slurpy)]+read_checkpoints d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  pistr <- fetchFilePS (realdir++"/"++darcsdir++"/checkpoints/inventory") Uncachable+           `catchall` return B.empty+  pis <- return $ reverse $ read_patch_ids pistr+  slurpies <- sequence $ map (fetch_checkpoint realdir) pis+  return $ zip pis slurpies+      where fetch_checkpoint r pinfo =+                unsafeInterleaveIO $ do+                pstr <- gzFetchFilePS+                    (r++"/"++darcsdir++"/checkpoints/"++make_filename pinfo) Cachable+                case fst `liftM` readPatch_ pstr of+                  Nothing -> return Nothing+                  Just (Sealed p) -> return $ apply_to_slurpy p empty_slurpy+            readPatch_ :: B.ByteString -> Maybe (Sealed (Named Patch C(x)), B.ByteString)+            readPatch_ = readPatch++remove_from_checkpoint_inventory :: RepoPatch p => FL (Named p) C(x y) -> IO ()+remove_from_checkpoint_inventory ps = do+    -- only tags can be checkpoints+    let pinfos = filter is_tag $ mapFL patch2patchinfo ps+    unless (null pinfos) $ do+        createDirectoryIfMissing False (darcsdir++"/checkpoints")+        cpi <- (map fst) `liftM` read_checkpoints "."+        writeDocBinFile (darcsdir++"/checkpoints/inventory") $+            format_inventory $ reverse $ filter (`notElem` pinfos) cpi+\end{code}++The \verb!_darcs! directory also contains a directory called+``\verb!prefs!'', which is described in Chapter~\ref{configuring}.++\begin{comment}+\section{Getting interesting info on change history}++One can query the repository for the entire markup history of a file.  This+provides a data structure which contains a history of \emph{all} the+revisions ever made on a given file.++\end{comment}+
+ src/Darcs/Repository/Format.hs view
@@ -0,0 +1,153 @@+-- Copyright (C) 2005 David Roundy+--+-- This file is licensed under the GPL, version two or later.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..), identifyRepoFormat,+                    create_repo_format, writeRepoFormat,+                    write_problem, read_problem, readfrom_and_writeto_problem,+                    format_has, format_has_together,+                  ) where++import Data.List ( sort )+import Data.Maybe ( isJust, catMaybes )+import Control.Monad ( msum )++import Darcs.SignalHandler ( catchNonSignal )+import Darcs.External ( fetchFilePS, Cachable( Cachable ) )+import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory,+                                 UseOldFashionedInventory ) )+import Darcs.Lock ( writeBinFile )+import Darcs.Utils ( catchall, prettyException )+import Progress ( beginTedious, endTedious, finishedOneIO )+import Darcs.Global ( darcsdir )++import ByteStringUtils ( linesPS )+import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack)+import qualified Data.ByteString       as B (ByteString, null, empty)+import qualified ByteStringUtils       as BU ( intercalate )++#include "impossible.h"++data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory++-- | @RepoFormat@ is the representation of the format of a+-- repository. Each sublist corresponds to a line in the format+-- file. Each line is decomposed into words.+newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )++-- | The file where the format information should be.+df :: FilePath+df = darcsdir++"/format"++-- | @identifyRepoFormat URL@ identifies the format of the repository+-- at the given address. Return @Left reason@ if it fails, where+-- @reason@ explains why we weren't able to identify the format.+identifyRepoFormat :: String -> IO (Either String RepoFormat)+identifyRepoFormat repo =+ do let k = "Identifying repository "++repo+    beginTedious k+    finishedOneIO k "format"+    dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty+    -- below is a workaround for servers that don't return a 404 on nonexistent files+    rf <- if B.null dff || isJust (BC.elemIndex '<' dff)+          then do finishedOneIO k "inventory"+                  have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")+                  case have_inventory of+                    Right _ -> return $ Right default_repo_format+                    Left e -> return $ Left $ "Not a repository: "++repo++" ("++e++")"+          else return $ Right $ parse_repo_format dff+    endTedious k+    return rf+    where drfe x = fetchFilePS x Cachable >> return True+          doesRemoteFileExist x = (fmap Right) (drfe x) `catchNonSignal`+                                  (\e -> return (Left (prettyException e)))++-- | @writeRepoFormat@ writes the repo format to the given file.+writeRepoFormat :: RepoFormat -> FilePath -> IO ()+writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $+                              map (BC.unpack . BU.intercalate (BC.singleton '|')) rf++parse_repo_format :: B.ByteString -> RepoFormat+parse_repo_format ps =+    RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps++-- | The repo format we assume if we do not find a format file.+default_repo_format :: RepoFormat+default_repo_format = RF [[rp2ps Darcs1_0]]++create_repo_format :: [DarcsFlag] -> RepoFormat+create_repo_format fs = RF ([map rp2ps flags2inv] ++ maybe2)+    where flags2inv | UseFormat2 `elem` fs = [HashedInventory]+                    | UseHashedInventory `elem` fs = [HashedInventory]+                    | UseOldFashionedInventory `elem` fs = [Darcs1_0]+                    | otherwise = [HashedInventory]+          maybe2 = if UseFormat2 `notElem` fs &&+                      (UseOldFashionedInventory `elem` fs ||+                       UseHashedInventory `elem` fs)+                   then []+                   else [[rp2ps Darcs2]]++-- | @write_problem from@ tells if we can write to a repo in format @form@.+-- it returns @Nothing@ if there's no problem writing to such a repository.+write_problem :: RepoFormat -> Maybe String+write_problem rf | isJust $ read_problem rf = read_problem rf+write_problem (RF ks) = unlines `fmap` justsOrNothing (map wp ks)+    where wp x | all is_known x = Nothing+          wp [] = impossible+          wp x = Just $ unwords $ "Can't write repository format: " :+                 map BC.unpack (filter (not . is_known) x)+++-- | @write_problem from@ tells if we can read and write to a repo in+-- format @form@.  it returns @Nothing@ if there's no problem reading+-- and writing to such a repository.+readfrom_and_writeto_problem :: RepoFormat -> RepoFormat -> Maybe String+readfrom_and_writeto_problem inrf outrf+    | format_has Darcs2 inrf /= format_has Darcs2 outrf+        = Just "Cannot mix darcs-2 repositories with older formats" +    | otherwise = msum [read_problem inrf, write_problem outrf]+++-- | @read_problem from@ tells if we can write to a repo in format @form@.+-- it returns @Nothing@ if there's no problem reading from such a repository.+read_problem :: RepoFormat -> Maybe String+read_problem rf | format_has Darcs1_0 rf && format_has Darcs2 rf+                    = Just "Invalid repositoryformat:  format 2 is incompatible with format 1"+read_problem (RF ks) = unlines `fmap` justsOrNothing (map rp ks)+    where rp x | any is_known x = Nothing+          rp [] = impossible+          rp x = Just $ unwords $+                 "Can't understand repository format:" : map BC.unpack x+++-- | Does this version of darcs know how to handle this property?+is_known :: B.ByteString -> Bool+is_known p = p `elem` map rp2ps known_properties++-- | This is the list of properties which this version of darcs knows+-- how to handle.+known_properties :: [RepoProperty]+known_properties = [Darcs1_0, Darcs2, HashedInventory]++justsOrNothing :: [Maybe x] -> Maybe [x]+justsOrNothing mxs =+ case catMaybes mxs of+   [] -> Nothing+   xs -> Just xs++format_has :: RepoProperty -> RepoFormat -> Bool+format_has f (RF ks) = rp2ps f `elem` concat ks++format_has_together :: [RepoProperty] -> RepoFormat -> Bool+format_has_together fs (RF ks) = fht (sort $ map rp2ps fs) ks+    where fht _ [] = False+          fht x (y:ys) | x == sort y = True+                       | otherwise = fht x ys++rp2ps :: RepoProperty -> B.ByteString+rp2ps Darcs1_0 = BC.pack "darcs-1.0"+rp2ps Darcs2 = BC.pack "darcs-2"+rp2ps HashedInventory = BC.pack "hashed"
+ src/Darcs/Repository/HashedIO.hs view
@@ -0,0 +1,417 @@+-- Copyright (C) 2007 David Roundy+--+-- 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; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}++#include "gadts.h"++module Darcs.Repository.HashedIO ( HashedIO, applyHashed,+                                   copyHashed, syncHashedPristine, copyPartialsHashed, listHashedContents,+                                   slurpHashedPristine, writeHashedPristine,+                                   clean_hashdir ) where++import Darcs.Global ( darcsdir )+import Data.List ( (\\) )+import qualified Data.Map as Map+import System.Directory ( getDirectoryContents, createDirectoryIfMissing )+import System.Posix.Types ( EpochTime )+import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )+import Control.Monad ( when )+import Data.Maybe ( isJust )+import System.IO.Unsafe ( unsafeInterleaveIO )++import Darcs.SlurpDirectory.Internal ( Slurpy(..), SlurpyContents(..), map_to_slurpies, slurpies_to_map )+import Darcs.SlurpDirectory ( withSlurpy, undefined_time, undefined_size )+import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,+                                peekInCache, speculateFileUsingCache,+                                findFileMtimeUsingCache, setFileMtimeUsingCache,+                                okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )+import Darcs.Patch ( Patchy, apply )+import Darcs.RepoPath ( FilePathLike, toFilePath )+import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )+import Darcs.Flags ( DarcsFlag, Compression( .. ), compression )+import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist )+import Darcs.Utils ( withCurrentDirectory )+import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO, progress )+import Darcs.Patch.FileName ( FileName, norm_path, fp2fn, fn2fp, fn2niceps, niceps2fn,+                              break_on_dir, own_name, super_name )++import ByteStringUtils ( linesPS, unlinesPS )+import qualified Data.ByteString       as B  (ByteString, length, empty)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++import SHA1 ( sha1PS )++-- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,+-- fetching it from 'Cache' @c@ if needed.+readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)+readHashFile c subdir hash =+    do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/"+       fetchFileUsingCache c subdir hash++applyHashed :: Patchy q => Cache -> [DarcsFlag] -> String -> q C(x y) -> IO String+applyHashed c fs h p = do s <- slurpHashedPristine c (compression fs) h+                          let ms = withSlurpy s $ apply fs p+                          case ms of+                            Left e -> fail e+                            Right (s', ()) -> writeHashedPristine c (compression fs) s'+{-+applyHashed c fs h p = do (_,hd) <- runStateT (apply fs p) $+                                    HashDir { permissions = RW, cache = c,+                                              options = fs, rootHash = h }+                          return $ rootHash hd+-}++data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,+                             compress :: !Compression, rootHash :: !String }+type HashedIO r p = StateT (HashDir r p) IO++data RO = RO+data RW = RW+{-+class Readable r where+    isRO :: r -> Bool+    isRO = const False+instance Readable RW+instance Readable RO where+    isRO RO = True+-}++instance ReadableDirectory (HashedIO r p) where+    mDoesDirectoryExist fn = do thing <- identifyThing fn+                                case thing of Just (D,_) -> return True+                                              _ -> return False+    mDoesFileExist fn = do thing <- identifyThing fn+                           case thing of Just (F,_) -> return True+                                         _ -> return False+    mInCurrentDirectory fn j | fn' == fp2fn "" = j+                             | otherwise =+                                 case break_on_dir fn' of+                                 Nothing -> do c <- readroot+                                               case geta D fn' c of+                                                 Nothing -> fail "dir doesn't exist mInCurrentDirectory..."+                                                 Just h -> inh h j+                                 Just (d,fn'') -> do c <- readroot+                                                     case geta D d c of+                                                       Nothing -> fail "dir doesn't exist..."+                                                       Just h -> inh h $ mInCurrentDirectory fn'' j+        where fn' = norm_path fn+    mGetDirectoryContents = map (\ (_,f,_) -> f) `fmap` readroot+    mReadFilePS fn = mInCurrentDirectory (super_name fn) $ do+                                          c <- readroot+                                          case geta F (own_name fn) c of+                                            Nothing -> fail $ " file don't exist... "++ fn2fp fn+                                            Just h -> readhash h++instance WriteableDirectory (HashedIO RW p) where+    mWithCurrentDirectory fn j+        | fn' == fp2fn "" = j+        | otherwise =+            case break_on_dir fn' of+            Nothing -> do c <- readroot+                          case geta D fn' c of+                            Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."+                            Just h -> do (h',x) <- withh h j+                                         writeroot $ seta D fn' h' c+                                         return x+            Just (d,fn'') -> do c <- readroot+                                case geta D d c of+                                  Nothing -> fail "dir doesn't exist..."+                                  Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j+                                               writeroot $ seta D d h' c+                                               return x+        where fn' = norm_path fn+    mSetFileExecutable _ _ = return ()+    mWriteFilePS fn ps = do mexists <- identifyThing fn+                            case mexists of+                              Just (D,_) -> fail "can't write file over directory"+                              _ -> do h <- writeHashFile ps+                                      makeThing fn (F,h)+    mCreateDirectory fn = do h <- writeHashFile B.empty+                             exists <- isJust `fmap` identifyThing fn+                             when exists $ fail "can't mCreateDirectory over an existing object."+                             makeThing fn (D,h)+    mRename o n = do nexists <- isJust `fmap` identifyThing n+                     when nexists $ fail "mRename failed..."+                     mx <- identifyThing o+                     -- for backwards compatibility accept rename of nonexistent files.+                     case mx of Nothing -> return ()+                                Just x -> do rmThing o+                                             makeThing n x+    mRemoveDirectory = rmThing+    mRemoveFile f = do x <- mReadFilePS f+                       when (B.length x /= 0) $+                            fail $ "Cannot remove non-empty file "++fn2fp f+                       rmThing f++identifyThing :: FileName -> HashedIO r p (Maybe (ObjType,String))+identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash+                                        return $ Just (D, h)+                 | otherwise = case break_on_dir fn' of+                               Nothing -> getany fn' `fmap` readroot+                               Just (d,fn'') -> do c <- readroot+                                                   case geta D d c of+                                                     Nothing -> return Nothing+                                                     Just h -> inh h $ identifyThing fn''+        where fn' = norm_path fn++makeThing :: FileName -> (ObjType,String) -> HashedIO RW p ()+makeThing fn (o,h) = mWithCurrentDirectory (super_name $ norm_path fn) $+                     seta o (own_name $ norm_path fn) h `fmap` readroot >>= writeroot++rmThing :: FileName -> HashedIO RW p ()+rmThing fn = mWithCurrentDirectory (super_name $ norm_path fn) $+             do c <- readroot+                let c' = filter (\(_,x,_)->x/= own_name (norm_path fn)) c+                if length c' == length c - 1+                  then writeroot c'+                  else fail "obj doesn't exist in rmThing"++readhash :: String -> HashedIO r p B.ByteString+readhash h = do c <- gets cache+                z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h+                let (_,out) = z+                return out++readTediousHash :: String -> String -> HashedIO r p B.ByteString+readTediousHash k h = do lift $ finishedOneIO k h+                         readhash h++gethashmtime :: String -> HashedIO r p EpochTime+gethashmtime h = do HashDir _ c _ _ <- get+                    lift $ unsafeInterleaveIO $ findFileMtimeUsingCache c HashedPristineDir h++withh :: String -> HashedIO RW p a -> HashedIO RW p (String,a)+withh h j = do hd <- get+               put $ hd { rootHash = h }+               x <- j+               h' <- gets rootHash+               put hd+               return (h',x)++inh :: String -> HashedIO r p a -> HashedIO r p a+inh h j = do hd <- get+             put $ hd { rootHash = h }+             x <- j+             put hd+             return x++safeInterleave :: HashedIO RO p a -> HashedIO r p a+safeInterleave job = do HashDir _ c compr h <- get+                        z <- lift $ unsafeInterleaveIO $ runStateT job+                             (HashDir { permissions = RO, cache = c, compress = compr, rootHash = h })+                        let (x,_) = z+                        return x++readroot :: HashedIO r p [(ObjType, FileName, String)]+readroot = do haveitalready <- peekroot+              cc <- gets rootHash >>= readdir+              when (not haveitalready) $ speculate cc+              return cc+    where speculate :: [(a,b,String)] -> HashedIO r q ()+          speculate c = do cac <- gets cache+                           mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c+          peekroot :: HashedIO r p Bool+          peekroot = do HashDir _ c _ h <- get+                        lift $ peekInCache c HashedPristineDir h++writeroot :: [(ObjType, FileName, String)] -> HashedIO r p ()+writeroot c = do h <- writedir c+                 modify $ \hd -> hd { rootHash = h }++data ObjType = F | D deriving Eq++-- | @geta objtype name stuff@ tries to get an object of type @objtype@ named @name@+-- in @stuff@.+geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String+geta o f c = do (o',h) <- getany f c+                if o == o' then Just h else Nothing++getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)+getany _ [] = Nothing+getany f ((o,f',h):_) | f == f' = Just (o,h)+getany f (_:r) = getany f r++seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]+seta o f h [] = [(o,f,h)]+seta o f h ((_,f',_):r) | f == f' = (o,f,h):r+seta o f h (x:xs) = x : seta o f h xs++readdir :: String -> HashedIO r p [(ObjType, FileName, String)]+readdir hash = (parsed . linesPS) `fmap` readhash hash+    where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest+                              | t == file = (F, niceps2fn n, BC.unpack h) : parsed rest+          parsed _ = []+dir :: B.ByteString+dir = BC.pack "directory:"+file :: B.ByteString+file = BC.pack "file:"+++writedir :: [(ObjType, FileName, String)] -> HashedIO r p String+writedir c = writeHashFile cps+    where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty]+          showO D = dir+          showO F = file++writeHashFile :: B.ByteString -> HashedIO r p String+writeHashFile ps = do c <- gets cache+                      compr <- gets compress+                      lift $ writeFileUsingCache c compr HashedPristineDir ps++-- |Create a Slurpy representing the pristine content determined by the+-- supplied root hash (which uniquely determines the pristine tree)+slurpHashedPristine :: Cache -> Compression -> String -> IO Slurpy+slurpHashedPristine c compr h = fst `fmap` runStateT slh+                                  (HashDir { permissions = RO, cache = c,+                                             compress = compr, rootHash = h })++slh :: HashedIO r p Slurpy+slh = do c <- readroot+         hroot <- gets rootHash+         lift $ beginTedious k+         safeInterleave $ (Slurpy rootdir . SlurpDir (Just hroot) . slurpies_to_map) `fmap` mapM sl c+    where sl (F,n,h) = do ps <- safeInterleave $ readTediousHash k h+                          t <- gethashmtime h+                          let len = if length h == 75 then read (take 10 h)+                                                      else undefined_size+                          return $ Slurpy n $ SlurpFile (Just h, t, len) ps+          sl (D,n,h) = inh h $ do c <- readroot+                                  lift $ tediousSize k (length c)+                                  lift $ finishedOneIO k h+                                  (Slurpy n . SlurpDir (Just h) . slurpies_to_map) `fmap` mapM sl c+          k = "Reading pristine"++rootdir :: FileName+rootdir = fp2fn "."++-- |Write contents of a Slurpy into hashed pristine. Only files that have not+-- not yet been hashed (that is, the hash corresponding to their content is+-- already present in hashed pristine) will be written out, so it is efficient+-- to use this function to update existing pristine cache. Note that the+-- pristine root hash will *not* be updated. You need to do that manually.+writeHashedPristine :: Cache -> Compression -> Slurpy -> IO String+writeHashedPristine c compr sl =+    do beginTedious k+       h <- fst `fmap` runStateT (hsl sl)+            (HashDir { permissions = RW, cache = c,+                       compress = compr, rootHash = sha1PS B.empty })+       endTedious k+       return h+    where hsl (Slurpy _ (SlurpDir (Just h) _)) = return h+          hsl (Slurpy _ (SlurpDir Nothing ss)) = do lift $ tediousSize k (Map.size ss)+                                                    mapM hs (map_to_slurpies ss) >>= writedir+          hsl (Slurpy _ (SlurpFile (Just h,_,_) _)) = return h+          hsl (Slurpy _ (SlurpFile _ x)) = writeHashFile x+          hs (Slurpy d (SlurpDir (Just h) _)) = progress k $ return (D, d, h)+          hs s@(Slurpy d (SlurpDir Nothing _)) = do h <- hsl s+                                                    lift $ finishedOneIO k h+                                                    return (D, d, h)+          hs (Slurpy f (SlurpFile (Just h,_,_) _)) = progress k $ return (F, f, h)+          hs s@(Slurpy f (SlurpFile _ _)) = do h <- hsl s+                                               lift $ finishedOneIO k h+                                               return (F, f, h)+          k = "Writing pristine"++grab :: FileName -> Slurpy -> Maybe Slurpy+grab _ (Slurpy _ (SlurpFile _ _)) = Nothing+grab fn (Slurpy _ (SlurpDir _ ss)) = fmap (Slurpy fn) $ Map.lookup fn ss++-- | Update timestamps on pristine files to match those in the working directory+-- (which is passed to this function in form of a Slurpy). It needed for the+-- mtime-based unsafeDiff optimisation to work efficiently.+syncHashedPristine :: Cache -> Slurpy -> String -> IO ()+syncHashedPristine c s r = do runStateT sh $ HashDir { permissions=RW, cache=c,+                                                       compress=compression [], rootHash=r }+                              return ()+    where sh = do cc <- readroot+                  lift $ tediousSize k (length cc)+                  mapM_ sh' cc+          sh' (D,n,h) = case progress k $ grab n s of+                        Just s' -> lift $ syncHashedPristine c s' h+                        Nothing -> return ()+          sh' (F,n,h) = case progress k $ grab n s of+                        Just (Slurpy _ (SlurpFile (_,t',l) x)) ->+                            do t <- lift $ findFileMtimeUsingCache c HashedPristineDir h+                               when (t' /= undefined_time && t' /= t) $+                                    do ps <- readhash h+                                       when (B.length ps == fromIntegral l && ps == x) $+                                            lift $ setFileMtimeUsingCache c HashedPristineDir h t'+                        _ -> return ()+          k = "Synchronizing pristine"++copyHashed :: String -> Cache -> Compression -> String -> IO ()+copyHashed k c compr z = do runStateT cph $ HashDir { permissions = RO, cache = c,+                                                      compress = compr, rootHash = z }+                            return ()+    where cph = do cc <- readroot+                   lift $ tediousSize k (length cc)+                   mapM_ cp cc+          cp (F,n,h) = do ps <- readhash h+                          lift $ finishedOneIO k (fn2fp n)+                          lift $ writeAtomicFilePS (fn2fp n) ps+          cp (D,n,h) = do lift $ createDirectoryIfMissing False (fn2fp n)+                          lift $ finishedOneIO k (fn2fp n)+                          lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h++copyPartialsHashed :: FilePathLike fp =>+                      Cache -> Compression -> String -> [fp] -> IO ()+copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root)++copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO ()+copyPartialHashed c compr root ff =+    do createDirectoryIfMissing True (basename $ toFilePath ff)+       runStateT (cp $ fp2fn $ toFilePath ff) $+                 HashDir { permissions = RO, cache = c,+                           compress=compr, rootHash = root }+       return ()+ where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse+       cp f = do mt <- identifyThing f+                 case mt of+                   Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)+                                    lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h+                   Just (F,h) -> do ps <- readhash h+                                    lift $ writeAtomicFilePS (fn2fp f) ps+                   Nothing -> return ()++-- | Seems to list all hashes reachable from "root".+listHashedContents :: String -> Cache -> String -> IO [String]+listHashedContents k c root =+    do beginTedious k+       tediousSize k 1+       x <- fst `fmap` runStateT (lhc (D,fp2fn ".",root)) (HashDir RO c NoCompression root)+       endTedious k+       return x+    where lhc :: (ObjType, FileName, String) -> HashedIO r a [String]+          lhc (D,dname,d) = do xs <- inh d $ readroot+                               lift $ finishedOneIO k (fn2fp dname)+                               lift $ tediousSize k (length $ filter (\(x,_,_) -> x == D) xs)+                               hcxs <- mapM lhc xs+                               return (d:concat hcxs)+          lhc (F,_,h) = return [h]++clean_hashdir :: Cache -> HashedDir -> [String] -> IO ()+clean_hashdir c dir_ hashroots =+   do -- we'll remove obsolete bits of "dir"+      debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."+      let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"+      hs <- concat `fmap` (mapM (listHashedContents "cleaning up..." c) hashroots)+      fs <- filter okayHash `fmap` getDirectoryContents hashdir+      mapM_ (removeFileMayNotExist . (hashdir++)) (fs \\ hs)+      -- and also clean out any global caches.+      debugMessage "Cleaning out any global caches..."+      cleanCachesWithHint c dir_ (fs \\ hs)
+ src/Darcs/Repository/HashedRepo.hs view
@@ -0,0 +1,401 @@+-- Copyright (C) 2006-2007 David Roundy+--+-- 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; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-}++#include "gadts.h"++module Darcs.Repository.HashedRepo ( revert_tentative_changes, finalize_tentative_changes,+                                     slurp_pristine, sync_repo, clean_pristine,+                                     copy_pristine, copy_partials_pristine, pristine_from_working,+                                     apply_to_tentative_pristine,+                                     replacePristineFromSlurpy,+                                     add_to_tentative_inventory, remove_from_tentative_inventory,+                                     read_repo, read_tentative_repo, write_and_read_patch,+                                     write_tentative_inventory, copy_repo, slurp_all_but_darcs,+                                     readHashedPristineRoot+                                   ) where++import System.Directory ( doesFileExist, createDirectoryIfMissing )+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO ( stderr, hPutStrLn )+import Data.List ( delete )+import Control.Monad ( unless )++import Workaround ( renameFile )+import Darcs.Flags ( DarcsFlag, Compression )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath )+import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache,+                                writeFileUsingCache,+                                unionCaches, repo2cache, okayHash, takeHash,+                                HashedDir(..), hashedDir )+import Darcs.Repository.HashedIO ( applyHashed, slurpHashedPristine,+                                   copyHashed, syncHashedPristine, copyPartialsHashed,+                                   writeHashedPristine, clean_hashdir )+import Darcs.Repository.InternalTypes ( Repository(..), extractCache )+import Darcs.Hopefully ( PatchInfoAnd, patchInfoAndPatch, n2pia, info,+                         extractHash, createHashed )+import Darcs.SlurpDirectory ( Slurpy, empty_slurpy, slurp_remove, slurp )+import Darcs.Patch ( RepoPatch, Patchy, Named, showPatch, patch2patchinfo, readPatch )+import Darcs.Patch.Depends ( commute_to_end, slightly_optimize_patchset )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo, human_friendly, readPatchInfo )+import Darcs.Ordered ( unsafeCoerceP, (:<)(..) )+import Darcs.Patch.FileName ( fp2fn )++import ByteStringUtils ( gzReadFilePS, dropSpace )+import qualified Data.ByteString as B (null, length, readFile, empty+                                      ,tail, take, drop, ByteString)+import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack)++import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS )+import SHA1 ( sha1PS )+import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, Cachable( Uncachable ) )+import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile )+import Darcs.Utils ( withCurrentDirectory )+import Progress ( beginTedious, tediousSize, endTedious, debugMessage, finishedOneIO )+#include "impossible.h"+import Darcs.Ordered ( FL(..), RL(..),+                             mapRL, mapFL, lengthRL )+import Darcs.Sealed ( Sealed(..), seal, unseal )+import Darcs.Global ( darcsdir )++revert_tentative_changes :: IO ()+revert_tentative_changes =+    do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")+       i <- gzReadFilePS (darcsdir++"/hashed_inventory")+       writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i++finalize_tentative_changes :: RepoPatch p => Repository p C(r u t) -> Compression -> IO ()+finalize_tentative_changes r compr =+    do let t = darcsdir++"/tentative_hashed_inventory"+       -- first let's optimize it...+       debugMessage "Optimizing the inventory..."+       ps <- read_tentative_repo r "."+       write_tentative_inventory (extractCache r) compr ps+       -- then we'll add in the pristine cache,+       i <- gzReadFilePS t+       p <- gzReadFilePS $ darcsdir++"/tentative_pristine"+       writeDocBinFile t $ pris2inv (inv2pris p) i+       -- and rename it to its final value+       renameFile t $ darcsdir++"/hashed_inventory"+       -- note: in general we can't clean the pristine cache, because a+       -- simultaneous get might be in progress++readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String)+readHashedPristineRoot (Repo d _ _ _) =+    withCurrentDirectory d $ do+      i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\_ -> return Nothing)+      return $ inv2pris `fmap` i++clean_pristine :: Repository p C(r u t) -> IO ()+clean_pristine r@(Repo d _ _ _) = withCurrentDirectory d $+   do -- we'll remove obsolete bits of our pristine cache+      debugMessage "Cleaning out the pristine cache..."+      i <- gzReadFilePS (darcsdir++"/hashed_inventory")+      clean_hashdir (extractCache r) HashedPristineDir [inv2pris i]++add_to_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y) -> IO FilePath+add_to_tentative_inventory c compr p =+    do hash <- snd `fmap` write_patch_if_necesary c compr p+       appendDocBinFile (darcsdir++"/tentative_hashed_inventory") $ showPatchInfo $ info p+       appendBinFile (darcsdir++"/tentative_hashed_inventory") $ "\nhash: " ++ hash ++ "\n"+       return $ darcsdir++"/patches/" ++ hash++remove_from_tentative_inventory :: RepoPatch p => Repository p C(r u t) -> Compression+                                -> FL (Named p) C(x t) -> IO ()+remove_from_tentative_inventory repo compr to_remove =+       -- FIXME: This algorithm should be *far* simpler.  All we need do is+       -- to to remove the patches from a patchset and then write that+       -- patchset.  The commutation behavior of PatchInfoAnd should track+       -- which patches need to be rewritten for us.+    do allpatches <- read_tentative_repo repo "."+       skipped :< _ <- return $ commute_to_end to_remove allpatches+       okay <- simple_remove_from_tentative_inventory repo compr+               (mapFL patch2patchinfo to_remove ++ mapFL patch2patchinfo skipped)+       unless okay $ bug "bug in HashedRepo.remove_from_tentative_inventory"+       sequence_ $ mapFL (add_to_tentative_inventory (extractCache repo) compr . n2pia) skipped++simple_remove_from_tentative_inventory :: forall p C(r u t). RepoPatch p =>+                                          Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool+simple_remove_from_tentative_inventory repo compr pis = do+    inv <- read_tentative_repo repo "."+    case cut_inv pis inv of+      Nothing -> return False+      Just (Sealed inv') -> do write_tentative_inventory (extractCache repo) compr inv'+                               return True+    where cut_inv :: [PatchInfo] -> PatchSet p C(x) -> Maybe (SealedPatchSet p)+          cut_inv [] x = Just $ seal x+          cut_inv x (NilRL:<:rs) = cut_inv x rs+          cut_inv xs ((hp:<:r):<:rs) | info hp `elem` xs = cut_inv (info hp `delete` xs) (r:<:rs)+          cut_inv _ _ = Nothing++writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String+writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir)+                                    writeFileUsingCache c compr subdir $ renderPS d++read_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(r))+read_repo repo d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  Sealed ps <- read_repo_private repo realdir "hashed_inventory" `catch`+                 (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)+                           ioError e)+  return $ unsafeCoerceP ps++read_tentative_repo :: RepoPatch p => Repository p C(r u t) -> String -> IO (PatchSet p C(t))+read_tentative_repo repo d = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote d+  Sealed ps <- read_repo_private repo realdir "tentative_hashed_inventory" `catch`+                 (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)+                           ioError e)+  return $ unsafeCoerceP ps++read_repo_private :: RepoPatch p => Repository p C(r u t)+                  -> FilePath -> FilePath -> IO (SealedPatchSet p)+read_repo_private repo d iname =+ do inventories <- read_inventory_private repo (d++"/"++darcsdir) iname+    parseinvs inventories+    where read_patches :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))+          read_patches [] = return $ seal NilRL+          read_patches allis@((i1,h1):is1) =+              lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest)+                          (rp is1)+                          (createHashed h1 (const $ speculate h1 allis >> parse i1 h1))+              where rp :: RepoPatch p => [(PatchInfo, String)] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))+                    rp [] = return $ seal NilRL+                    rp [(i,h),(il,hl)] =+                        lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)+                                    (rp [(il,hl)])+                                    (createHashed h (const $ speculate h (reverse allis) >> parse i h))+                    rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)+                                                (rp is)+                                                (createHashed h (parse i))+          speculate :: String -> [(PatchInfo, String)] -> IO ()+          speculate h is = do already_got_one <- doesFileExist (d++"/"++darcsdir++"/patches/"++h)+                              unless already_got_one $+                                     mapM_ (speculateFileUsingCache (extractCache repo) HashedPatchesDir . snd) is+          parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))+          parse i h = do debugMessage ("Reading patch file: "++ show (human_friendly i))+                         (fn,ps) <- fetchFileUsingCache (extractCache repo) HashedPatchesDir h+                         case readPatch ps of+                           Just (p,_) -> return p+                           Nothing -> fail $ unlines ["Couldn't parse file "++fn,+                                                      "which is patch",+                                                      renderString $ human_friendly i]+          parseinvs :: RepoPatch p => [[(PatchInfo, String)]] -> IO (SealedPatchSet p)+          parseinvs [] = return $ seal NilRL+          parseinvs (i:is) = lift2Sealed (:<:) (parseinvs is) (read_patches i)+          lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))+                      -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed (r C(x)))+          lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox+                                     Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy+                                     return $ seal $ f y x++write_and_read_patch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y)+                     -> IO (PatchInfoAnd p C(x y))+write_and_read_patch c compr p = do (i,h) <- write_patch_if_necesary c compr p+                                    unsafeInterleaveIO $ readp h i+    where parse i h = do debugMessage ("Rereading patch file: "++ show (human_friendly i))+                         (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h+                         case readPatch ps of+                           Just (x,_) -> return x+                           Nothing -> fail $ unlines ["Couldn't parse patch file "++fn,+                                                      "which is",+                                                      renderString $ human_friendly i]+          readp h i = do Sealed x <- createHashed h (parse i)+                         return $ patchInfoAndPatch i $ unsafeCoerceP x++write_tentative_inventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(x) -> IO ()+write_tentative_inventory c compr = write_either_inventory c compr "tentative_hashed_inventory"++copy_repo :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> String -> IO ()+copy_repo repo@(Repo outr _ _ _) opts inr = do+    createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")+    copyFileOrUrl opts (inr++"/"++darcsdir++"/hashed_inventory") (outr++"/"++darcsdir++"/hashed_inventory")+                  Uncachable -- no need to copy anything but hashed_inventory!+    appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` extractCache repo)+    debugMessage "Done copying hashed inventory."++write_either_inventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(x) -> IO ()+write_either_inventory c compr iname x =+    do createDirectoryIfMissing False $ darcsdir++"/inventories"+       let k = "Writing inventory"+       beginTedious k+       tediousSize k (lengthRL x)+       hsh <- write_inventory_private k c compr $ slightly_optimize_patchset x+       endTedious k+       case hsh of+         Nothing -> writeBinFile (darcsdir++"/"++iname) ""+         Just h -> gzReadFilePS (darcsdir++"/inventories/"++h) >>= writeAtomicFilePS (darcsdir++"/"++iname)++write_inventory_private :: RepoPatch p => String -> Cache -> Compression+                        -> PatchSet p C(x) -> IO (Maybe String)+write_inventory_private _ _ _ NilRL = return Nothing+write_inventory_private _ _ _ (NilRL:<:NilRL) = return Nothing+write_inventory_private _ _ _ (NilRL:<:_) = -- This shouldn't be possible, so best to check...+    bug "malformed PatchSet in HashedRepo.write_inventory_private"+write_inventory_private k c compr (x:<:xs) =+  do resthash <- write_inventory_private k c compr xs+     finishedOneIO k (case resthash of Nothing -> ""; Just h -> h)+     inventory <- sequence $ mapRL (write_patch_if_necesary c compr) x+     let inventorylist = hcat (map pihash $ reverse inventory)+         inventorycontents = case resthash of+                             Just lasthash -> text ("Starting with inventory:\n"++lasthash) $$+                                              inventorylist+                             _ -> inventorylist+     hash <- writeHashFile c compr HashedInventoriesDir inventorycontents+     return $ Just hash++write_patch_if_necesary :: RepoPatch p => Cache -> Compression+                        -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)+write_patch_if_necesary c compr hp =+    seq infohp $ case extractHash hp of+                   Right h -> return (infohp, h)+                   Left p -> (\h -> (infohp, h)) `fmap`+                             writeHashFile c compr HashedPatchesDir (showPatch p)+    where infohp = info hp++pihash :: (PatchInfo,String) -> Doc+pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")++read_inventory_private :: Repository p C(r u t) -> String -> String+                       -> IO [[(PatchInfo, String)]]+read_inventory_private repo d iname = do+    i <- skip_pristine `fmap` fetchFilePS (d++"/"++iname) Uncachable+    (rest,str) <- case BC.break ((==)'\n') i of+                  (swt,pistr) | swt == BC.pack "Starting with inventory:" ->+                    case BC.break ((==)'\n') $ B.tail pistr of+                    (h,thisinv) | okayHash $ BC.unpack h ->+                      do r <- unsafeInterleaveIO $ read_inventories+                              (extractCache repo) (BC.unpack h) -- don't unpack twice!+                         return (r,thisinv)+                    _ -> fail $ "Bad hash in " ++ d ++ "/"++darcsdir++"/" ++ iname+                  _ -> return ([],i)+    return $ reverse (read_patch_ids str) : rest++read_inventories :: Cache -> String -> IO [[(PatchInfo, String)]]+read_inventories cache ihash = do+    (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash+    let i = skip_pristine i_and_p+    (rest,str) <- case BC.break ((==)'\n') i of+                  (swt,pistr) | swt == BC.pack "Starting with inventory:" ->+                    case BC.break ((==)'\n') $ B.tail pistr of+                    (h,thisinv) | okayHash $ BC.unpack h ->+                      do r <- unsafeInterleaveIO $+                              read_inventories cache (BC.unpack h) -- again. no.+                         return (r,thisinv)+                    _ -> fail $ "Bad hash in file " ++ fn+                  _ -> return ([],i)+    return $ reverse (read_patch_ids str) : rest++read_patch_ids :: B.ByteString -> [(PatchInfo, String)]+read_patch_ids inv | B.null inv = []+read_patch_ids inv = case readPatchInfo inv of+                     Nothing -> []+                     Just (pinfo,r) ->+                         case readHash r of+                         Nothing -> []+                         Just (h,r') -> (pinfo,h) : read_patch_ids r'++readHash :: B.ByteString -> Maybe (String, B.ByteString)+readHash s = let s' = dropSpace s+                 (l,r) = BC.break ((==)'\n') s'+                 (kw,h) = BC.break ((==)' ') l+             in if kw /= BC.pack "hash:" || B.length h <= 1+                then Nothing+                else Just (BC.unpack $ B.tail h,r)++apply_pristine :: Patchy q => Cache -> [DarcsFlag] -> String -> String -> q C(x y) -> IO ()+apply_pristine c opts d iname p =+    do i <- gzReadFilePS (d++"/"++iname)+       h <- applyHashed c opts (inv2pris i) p+       writeDocBinFile (d++"/"++iname) $ pris2inv h i++apply_to_tentative_pristine :: Patchy q => Cache -> [DarcsFlag] -> q C(x y) -> IO ()+apply_to_tentative_pristine c opts p = apply_pristine c opts "." (darcsdir++"/tentative_pristine") p++slurp_pristine :: Cache -> Compression -> String -> String -> IO Slurpy+slurp_pristine c compr d iname = do+    i <- fetchFilePS (d++"/"++iname) Uncachable+    slurp_pristine_private c compr i++slurp_pristine_private :: Cache -> Compression -> B.ByteString -> IO Slurpy+slurp_pristine_private c compr inv = case inv2pris inv of+                                    h | h == sha1PS B.empty -> return empty_slurpy+                                      | otherwise -> slurpHashedPristine c compr h++pristine_from_working :: Cache -> Compression -> IO ()+pristine_from_working c compr = do+  s <- slurp_all_but_darcs "."+  replacePristineFromSlurpy c compr s++replacePristineFromSlurpy :: Cache -> Compression -> Slurpy -> IO ()+replacePristineFromSlurpy c compr s = do +  h <- writeHashedPristine c compr s+  let t = darcsdir++"/hashed_inventory"+  i <- gzReadFilePS t+  writeDocBinFile t $ pris2inv h i++copy_pristine :: Cache -> Compression -> String -> String -> IO ()+copy_pristine c compr d iname = do+    i <- fetchFilePS (d++"/"++iname) Uncachable+    debugMessage $ "Copying hashed pristine tree: "++inv2pris i+    let k = "Copying pristine"+    beginTedious k+    copyHashed k c compr $ inv2pris i+    endTedious k++sync_repo :: Cache -> IO ()+sync_repo c = do i <- B.readFile $ darcsdir++"/hashed_inventory"+                 s <- slurp_all_but_darcs "."+                 beginTedious "Synchronizing pristine"+                 syncHashedPristine c s $ inv2pris i+                 ++copy_partials_pristine :: FilePathLike fp =>+                          Cache -> Compression -> String -> String -> [fp] -> IO ()+copy_partials_pristine c compr d iname fps =+  do i <- fetchFilePS (d++"/"++iname) Uncachable+     copyPartialsHashed c compr (inv2pris i) fps++inv2pris :: B.ByteString -> String+inv2pris inv | B.take pristine_name_length inv == pristine_name =+                 case takeHash $ B.drop pristine_name_length inv of+                 Just (h,_) -> h+                 Nothing -> error "Bad hash in inventory!"+             | otherwise = sha1PS B.empty++pris2inv :: String -> B.ByteString -> Doc+pris2inv h inv = invisiblePS pristine_name <> text h $$ invisiblePS (skip_pristine inv)++pristine_name :: B.ByteString+pristine_name = BC.pack "pristine:"++skip_pristine :: B.ByteString -> B.ByteString+skip_pristine ps+    | B.take pristine_name_length ps == pristine_name = B.drop 1 $ BC.dropWhile (/= '\n') $+                                                        B.drop pristine_name_length ps+    | otherwise = ps++pristine_name_length :: Int+pristine_name_length = B.length pristine_name++slurp_all_but_darcs :: FilePath -> IO Slurpy+slurp_all_but_darcs d = do s <- slurp d+                           case slurp_remove (fp2fn $ "./"++darcsdir) s of+                             Nothing -> return s+                             Just s' -> return s'
+ src/Darcs/Repository/Internal.hs view
@@ -0,0 +1,1062 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}++#include "gadts.h"++module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),+                    maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,+                    findRepository, amInRepository, amNotInRepository,+                    slurp_pending, pristineFromWorking, revertRepositoryChanges,+                    slurp_recorded, slurp_recorded_and_unrecorded,+                    read_pending, announce_merge_conflicts, setTentativePending,+                    check_unrecorded_conflicts,+                    withRecorded,+                    checkPristineAgainstSlurpy,+                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+                    get_unrecorded_in_files, get_unrecorded_in_files_unsorted,+                    read_repo, sync_repo,+                    prefsUrl, makePatchLazy,+                    add_to_pending,+                    withRepoLock, withRepoReadLock,+                    withRepository, withRepositoryDirectory, withGutsOf,+                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,+                    tentativelyReplacePatches,+                    tentativelyMergePatches, considerMergeToWorking,+                    finalizeRepositoryChanges,+                    unrevertUrl,+                    applyToWorking, patchSetToPatches,+                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,+                    replacePristineFromSlurpy,+                    optimizeInventory, cleanRepository,+                    getMarkedupFile,+                    PatchSet, SealedPatchSet,+                    setScriptsExecutable,+                    getRepository, rIO,+                    testTentative, testRecorded+                  ) where++import Printer ( putDocLn, (<+>), text, ($$) )++import Data.Maybe ( isJust, isNothing )+import Darcs.Repository.Prefs ( get_prefval )+import Darcs.Resolution ( standard_resolution, external_resolution )+import System.Exit ( ExitCode(..), exitWith )+import System.Cmd ( system )+import Darcs.External ( backupByCopying, clonePartialsTree )+import Darcs.IO ( runTolerantly, runSilently )+import Darcs.Repository.Pristine ( identifyPristine, nopristine,+                                   easyCreatePristineDirectoryTree, slurpPristine, syncPristine,+                                   easyCreatePartialsPristineDirectoryTree,+                                   createPristineFromWorking )+import qualified Darcs.Repository.Pristine as Pristine ( replacePristineFromSlurpy )+                                                         +import Data.List ( (\\) )+import Darcs.SignalHandler ( withSignalsBlocked )+import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),+                                 identifyRepoFormat, format_has,+                                 write_problem, read_problem, readfrom_and_writeto_problem )+import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile,+                          createDirectoryIfMissing )+import Control.Monad ( liftM, when, unless )+import Workaround ( getCurrentDirectory, renameFile, setExecutable )++import ByteStringUtils ( gzReadFilePS )+import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf)+import qualified Data.ByteString.Char8 as BC (pack)++import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description,++                     try_to_shrink, commuteFL, commute, apply_to_filepaths )+import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict )+import Darcs.Patch.Bundle ( scan_bundle, make_bundle )+import Darcs.Patch.FileName ( FileName, fn2fp )+import Darcs.Patch.TouchesFiles ( choose_touching )+import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp,+                              slurp_has, list_slurpy_files )+import Darcs.Hopefully ( PatchInfoAnd, info, n2pia,+                         hopefully, hopefullyM )+import Darcs.Repository.ApplyPatches ( apply_patches )+import qualified Darcs.Repository.HashedRepo as HashedRepo+                            ( revert_tentative_changes, finalize_tentative_changes,+                              remove_from_tentative_inventory, sync_repo,+                              copy_pristine, copy_partials_pristine, slurp_pristine,+                              apply_to_tentative_pristine, pristine_from_working,+                              write_tentative_inventory, write_and_read_patch,+                              add_to_tentative_inventory,+                              read_repo, read_tentative_repo, clean_pristine,+                              replacePristineFromSlurpy,+                              slurp_all_but_darcs )+import qualified Darcs.Repository.DarcsRepo as DarcsRepo+import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,+                               MarkConflicts, AllowConflicts, NoUpdateWorking,+                               WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,+                               SetScriptsExecutable, DryRun, IgnoreTimes,+                               Summary, NoSummary),+                     want_external_merge, compression )+import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,+                             (:\/:)(..), (:/\:)(..), (:>)(..),+                             (+>+), lengthFL, nullFL,+                             allFL, filterFL,+                             reverseRL, reverseFL, concatRL, mapFL,+                             mapFL_FL, concatFL )+import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,+                     joinPatches, sort_coalesceFL,+                     list_conflicted_files, list_touched_files,+                     Named, patchcontents, anonymous,+                     commuteRL, fromPrims,+                     patch2patchinfo, readPatch,+                     writePatch, effect, invert,+                     is_addfile, is_adddir,+                     is_setpref,+                     apply, apply_to_slurpy,+                     empty_markedup_file, MarkedUpFile+                   )+import Darcs.Patch.Patchy ( Invert(..) )+import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.Apply ( markup_file, LineMark(None) )+import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset )+import Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff )+import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,+                        ioAbsoluteOrRemote, toPath )+import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )+import Progress ( debugMessage )+import Darcs.ProgressPatches (progressFL)+import Darcs.URL ( is_file )+import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function,+                                getCaches )+import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist,+                    withTempDir, withPermDir )+import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )+import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) )+import Darcs.Global ( darcsdir )+#include "impossible.h"++-- | Repository IO monad.  This monad-like datatype is responsible for+-- sequencing IO actions that modify the tentative recorded state of+-- the repository.+newtype RIO p C(r u t t1) a = RIO {+        unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@.+   }++-- | This is just like @>>=@ from the Monad class except that it+-- respects type witness safe repository transformations.  Even so, it+-- only tracks modifications to the tentative recorded state.+(>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b+m >>>= k = RIO $ \ (Repo x y z w) ->+             do a <- unsafeUnRIO m (Repo x y z w)+                unsafeUnRIO (k a) (Repo x y z w)++-- | This corresponds to @>>@ from the Monad class.+(>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b+a >>> b = a >>>= (const b)++-- | This corresponds to @return@ from the Monad class.+returnR :: a -> RIO p C(r u t t) a+returnR = rIO . return++-- | This the @RIO@ equivalent of @liftIO@.+rIO :: IO a -> RIO p C(r u t t) a+rIO = RIO . const++instance Functor (RIO p C(r u t t)) where+    fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r)++-- | We have an instance of Monad so that IO actions that do not+-- change the tentative recorded state are convenient in the IO monad.+instance Monad (RIO p C(r u t t)) where+ (>>=) = (>>>=)+ (>>) = (>>>)+ return = returnR+ fail = rIO . fail++-- | Similar to the @ask@ function of the MonadReader class.+-- This allows actions in the RIO monad to get the current+-- repository.+-- FIXME: Don't export this.  If we don't export this+-- it makes it harder for arbitrary IO actions to access+-- the repository and hence our code is easier to audit.+getRepository :: RIO p C(r u t t) (Repository p C(r u t))+getRepository = RIO return++maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p C(r u t)))+maybeIdentifyRepository opts "." =+    do darcs <- doesDirectoryExist darcsdir+       rf_or_e <- identifyRepoFormat "."+       here <- toPath `fmap` ioAbsoluteOrRemote "."+       case rf_or_e of+         Left err -> return $ Left err+         Right rf ->+             case read_problem rf of+             Just err -> return $ Left err+             Nothing -> if darcs then do pris <- identifyPristine+                                         cs <- getCaches opts here+                                         return $ Right $ Repo here opts rf (DarcsRepository pris cs)+                                 else return (Left "Not a repository")+maybeIdentifyRepository opts url' =+ do url <- toPath `fmap` ioAbsoluteOrRemote url'+    rf_or_e <- identifyRepoFormat url+    case rf_or_e of+      Left e -> return $ Left e+      Right rf -> case read_problem rf of+                  Just err -> return $ Left err+                  Nothing ->  do cs <- getCaches opts url+                                 return $ Right $ Repo url opts rf (DarcsRepository nopristine cs)++identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t))+identifyDarcs1Repository opts url =+    do er <- maybeIdentifyRepository opts url+       case er of+           Left s -> fail s+           Right r -> return r++identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))+identifyRepositoryFor (Repo _ opts rf _) url =+    do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url+       let t' = case t of DarcsRepository x c -> DarcsRepository x c+       case readfrom_and_writeto_problem rf_ rf of+         Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e+         Nothing -> return $ Repo absurl opts rf_ t'++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _         = False++currentDirIsRepository :: IO Bool+currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "."++amInRepository :: [DarcsFlag] -> IO (Either String ())+amInRepository (WorkRepoDir d:_) =+    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)+       air <- currentDirIsRepository+       if air+          then return (Right ())+          else return (Left "You need to be in a repository directory to run this command.")+amInRepository (_:fs) = amInRepository fs+amInRepository [] =+    seekRepo (Left "You need to be in a repository directory to run this command.")++-- | hunt upwards for the darcs repository+-- This keeps changing up one parent directory, testing at each+-- step if the current directory is a repository or not.  $+-- WARNING this changes the current directory for good if matchFn succeeds+seekRepo :: Either String ()+            -- ^ what to return if we don't find a repository+         -> IO (Either String ())+seekRepo onFail = getCurrentDirectory >>= helper where+   helper startpwd = do+    air <- currentDirIsRepository+    if air+       then return (Right ())+       else do cd <- toFilePath `fmap` getCurrentDirectory+               setCurrentDirectory ".."+               cd' <- toFilePath `fmap` getCurrentDirectory+               if cd' /= cd+                  then helper startpwd+                  else do setCurrentDirectory startpwd+                          return onFail++amNotInRepository :: [DarcsFlag] -> IO (Either String ())+amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d+                                         -- note that the above could always fail+                                         setCurrentDirectory d+                                         amNotInRepository []+amNotInRepository (_:f) = amNotInRepository f+amNotInRepository [] =+    do air <- currentDirIsRepository+       if air then return (Left $ "You may not run this command in a repository.")+              else return $ Right ()++findRepository :: [DarcsFlag] -> IO (Either String ())+findRepository (WorkRepoUrl d:_) | is_file d =+    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)+       findRepository []+findRepository (WorkRepoDir d:_) =+    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)+       findRepository []+findRepository (_:fs) = findRepository fs+findRepository [] = seekRepo (Right ())++slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy+slurp_pending repo@(Repo _ _ _ rt) = do+  cur <- slurp_recorded repo+  Sealed pend <- read_pending repo+  case apply_to_slurpy pend cur of+    Just pendcur -> return pendcur+    Nothing -> do putStrLn "Yikes, pending has conflicts.  Renaming file as_darcs/patches/pending_buggy"+                  renameFile (pendingName rt) (pendingName rt++"_buggy")+                  return cur++slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy+slurp_recorded (Repo dir opts rf (DarcsRepository _ c))+    | format_has HashedInventory rf =+        HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory"+slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do+    mc <- withCurrentDirectory dir $ slurpPristine p+    case mc of (Just slurpy) -> return slurpy+               Nothing -> withDelayedDir "pristine.temp" $ \abscd ->+                          do let cd = toFilePath abscd+                             createPristineDirectoryTree repository cd+                             mmap_slurp cd++slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy)+slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do+  cur <- slurp_recorded repo+  Sealed pend <- read_pending repo+  withCurrentDirectory r $+      case apply_to_slurpy pend cur of+      Nothing -> fail "Yikes, pending has conflicts!"+      Just pendslurp -> do unrec <- co_slurp pendslurp "."+                           return (cur, unrec)++pendingName :: RepoType p -> String+pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"++read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r)))+read_pending (Repo r _ _ tp) =+    withCurrentDirectory r (read_pendingfile (pendingName tp))++add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()+add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+add_to_pending repo p =+    do pend <- get_unrecorded repo+       make_new_pending repo (pend +>+ p)++readPrims :: B.ByteString -> Sealed (FL Prim C(x))+readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of+              Nothing -> Sealed NilFL+              Just (Sealed p,_) -> Sealed (effect p)++read_pendingfile :: String -> IO (Sealed (FL Prim C(x)))+read_pendingfile name = do+  pend <- gzReadFilePS name `catchall` return B.empty+  return $ readPrims pend++make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO ()+make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+make_new_pending repo@(Repo r _ _ tp) origp =+    withCurrentDirectory r $+    do let newname = pendingName tp ++ ".new"+       debugMessage $ "Writing new pending:  " ++ newname+       Sealed sfp <- return $ sift_for_pending origp+       writeSealedPatch newname $ seal $ fromPrims $ sfp+       cur <- slurp_recorded repo+       Sealed p <- read_pendingfile newname+       when (isNothing $ apply_to_slurpy p cur) $ do+         let buggyname = pendingName tp ++ "_buggy"+         renameFile newname buggyname+         bugDoc $ text "There was an attempt to write an invalid pending!"+                    $$ text "If possible, please send the contents of"+                    <+> text buggyname+                    $$ text "along with a bug report."+       renameFile newname (pendingName tp)+       debugMessage $ "Finished writing new pending:  " ++ newname+    where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO ()+          writeSealedPatch fp (Sealed p) = writePatch fp p++sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x))+sift_for_pending simple_ps =+ let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps+ in if allFL (\p -> is_addfile p || is_adddir p) $ oldps+    then seal oldps+    else fromJust $ do+      Sealed x <- return $ sfp NilFL $ reverseFL oldps+      return (case try_to_shrink x of+              ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps+                 | otherwise -> seal ps)+      where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c))+            sfp sofar NilRL = seal sofar+            sfp sofar (p:<:ps)+                | is_hunk p || is_binary p+                    = case commuteFL (p :> sofar) of+                      Right (sofar' :> _) -> sfp sofar' ps+                      Left _ -> sfp (p:>:sofar) ps+            sfp sofar (p:<:ps) = sfp (p:>:sofar) ps++get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y))+get_unrecorded_no_look_for_adds r paths = get_unrecorded_private (filter (/= LookForAdds)) r paths ++get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))+get_unrecorded_unsorted r = get_unrecorded_in_files_unsorted r []++get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))+get_unrecorded r = get_unrecorded_private id r []++-- | Gets the unrecorded changes in the given paths in the current repository,+--   without sorting them for presentation to the user+get_unrecorded_in_files_unsorted :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u))+get_unrecorded_in_files_unsorted = get_unrecorded_private (AnyOrder:)++-- | Gets the unrecorded changes in the given paths in the current repository.+get_unrecorded_in_files :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u))+get_unrecorded_in_files = get_unrecorded_private id ++-- | The /unrecorded/ includes the pending and the working directory changes.+--   The third argument is a list of paths: if this list is [], it will diff+--   the whole repo, but if there are elements in it, the function will return+--   only changes to files under those paths. The paths must be fixed paths +--   starting with ".", but need not yet be unique.+get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y))+get_unrecorded_private _ (Repo _ opts _ _) _+    | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL+get_unrecorded_private modopts repository@(Repo r oldopts _ _) files =+  withCurrentDirectory r (do+    debugMessage "Looking for unrecorded changes..."+    cur <- slurp_pending repository+    work <- if LookForAdds `elem` opts+            then do nboring <- if Boring `elem` opts+                               then return $ darcsdir_filter+                               else boring_file_filter+                    slurp_unboring (myfilt cur nboring) "."+            else co_slurp cur "."+    ftf <- filetype_function+    Sealed pend <- read_pending repository+    let changed_files = apply_to_filepaths pend filesFP+        pre_changed_files = apply_to_filepaths (invert pend) filesFP+    Sealed relevantPend <- return $ if null files+                                      then seal pend+                                      else choose_touching pre_changed_files pend+    debugMessage "diffing dir..."+    let diffs = if null files+                  then unsafeDiff opts ftf cur work+                  else unsafeDiffAtPaths (ignoreTimes, lookForAdds, summary) ftf cur work changed_files+        dif = if AnyOrder `elem` opts+                  then relevantPend +>+ diffs+                  else sort_coalesceFL $ relevantPend +>+ diffs+    seq dif $ debugMessage "Found unrecorded changes."+    return dif)+    where myfilt s nboring f = slurp_has f s || nboring [f] /= []+          opts = modopts oldopts+          -- NoSummary/Summary both present gives False+          -- Just Summary gives True+          -- Just NoSummary gives False+          -- Neither gives False+          summary = Summary `elem` opts && NoSummary `notElem` opts+          lookForAdds = LookForAdds `elem` opts+          ignoreTimes = IgnoreTimes `elem` opts+          filesFP = map fn2fp files++-- @todo: we should not have to open the result of HashedRepo and+-- seal it.  Instead, update this function to work with type witnesses+-- by fixing DarcsRepo to match HashedRepo in the handling of+-- Repository state.+read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r))+read_repo repo@(Repo r opts rf _)+    | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r+                                         return ps+    | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r+                     return $ unsafeCoerceP ps++readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t))+readTentativeRepo repo@(Repo r opts rf _)+    | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r+                                         return ps+    | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r+                     return $ unsafeCoerceP ps++makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))+makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p+    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p+    | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p++sync_repo :: Repository p C(r u t) -> IO ()+sync_repo (Repo r _ rf (DarcsRepository _ c))+    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c+sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p++prefsUrl :: Repository p C(r u t) -> String+prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"++unrevertUrl :: Repository p C(r u t) -> String+unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"++applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO ()+applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch =+    withCurrentDirectory r $ if Quiet `elem` opts+                             then runSilently $ apply opts patch+                             else runTolerantly $ apply opts patch++handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q)+                    => Repository p C(r u t) -> q C(x y) -> IO ()+handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+handle_pend_for_add (Repo _ _ _ rt) p =+    do let pn = pendingName rt ++ ".tentative"+       Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL)+       let effectp = if allFL is_simple pend then crude_sift $ effect p+                                             else effect p+       Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend+       writePatch pn $ fromPrims_ newpend+    where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b))+          rmpend NilFL x = Sealed x+          rmpend _ NilFL = Sealed NilFL+          rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys+          rmpend (x:>:xs) ys =+              case commuteWhatWeCanFL (x:>xs) of+              a:>x':>b -> case rmpend a ys of+                          Sealed ys' -> case commute (invert (x':>:b) :> ys') of+                                        Just (ys'' :> _) -> seal ys''+                                        Nothing -> seal $ invert (x':>:b)+>+ys'+                                        -- DJR: I don't think this+                                        -- last case should be+                                        -- reached, but it also+                                        -- shouldn't lead to+                                        -- corruption.+          fromPrims_ :: FL Prim C(a b) -> Patch C(a b)+          fromPrims_ = fromPrims++is_simple :: Prim C(x y) -> Bool+is_simple x = is_hunk x || is_binary x || is_setpref x++crude_sift :: FL Prim C(x y) -> FL Prim C(x y)+crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs+    where ishunkbinary :: Prim C(x y) -> EqCheck C(x y)+          ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq+                         | otherwise = NotEq++data HashedVsOld a = HvsO { old, hashed :: a }++decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a+decideHashedOrNormal rf (HvsO { hashed = h, old = o })+    | format_has HashedInventory rf = h+    | otherwise = o+++tentativelyMergePatches :: RepoPatch p+                        => Repository p C(r u t) -> String -> [DarcsFlag]+                        -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                        -> IO (Sealed (FL Prim C(u)))+tentativelyMergePatches = tentativelyMergePatches_ MakeChanges++considerMergeToWorking :: RepoPatch p+                       => Repository p C(r u t) -> String -> [DarcsFlag]+                       -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                       -> IO (Sealed (FL Prim C(u)))+considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges++data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )++tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p+                         => MakeChanges+                         -> Repository p C(r u t) -> String -> [DarcsFlag]+                         -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)+                         -> IO (Sealed (FL Prim C(u)))+tentativelyMergePatches_ mc r cmd opts usi themi =+  do let us = mapFL_FL hopefully usi+         them = mapFL_FL hopefully themi+     _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)+     pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty...+     anonpend <- anonymous (fromPrims pend)+     pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)+     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw+     Sealed standard_resolved_pw <- return $ standard_resolution pwprim+     debugMessage "Checking for conflicts..."+     mapM_ backupByCopying $ list_touched_files standard_resolved_pw+     debugMessage "Announcing conflicts..."+     have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw+     debugMessage "Checking for unrecorded conflicts..."+     have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc+     debugMessage "Reading working directory..."+     (_, working) <- slurp_recorded_and_unrecorded r+     debugMessage "Working out conflicts in actual working directory..."+     Sealed pw_resolution <-+          case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of+          (Nothing,_) -> return $ if AllowConflicts `elem` opts+                                  then seal NilFL+                                  else seal standard_resolved_pw+          (_,False) -> return $ seal standard_resolved_pw+          (Just c, True) -> external_resolution working c+                                                    (effect us +>+ pend)+                                                    (effect them) pwprim+     debugMessage "Applying patches to the local directories..."+     when (mc == MakeChanges) $+          do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO ()+                 doChanges NilFL = applyps r themi+                 doChanges _     = applyps r (mapFL_FL n2pia pc)+             doChanges usi+             setTentativePending r (effect pend' +>+ pw_resolution)+     return $ seal (effect pwprim +>+ pw_resolution)+  where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()]+        mapAdd _ NilFL = []+        mapAdd r'@(Repo dir df rf dr) (a:>:as) =+               -- we construct a new Repository object on the recursive case so that the+               -- recordedstate of the repository can match the fact that we just wrote a patch+               tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as+        applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()+        applyps repo ps = do debugMessage "Adding patches to inventory..."+                             sequence_ $ mapAdd repo ps+                             debugMessage "Applying patches to pristine..."+                             applyToTentativePristine repo ps++announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool+announce_merge_conflicts cmd opts resolved_pw =+    case nubsort $ list_touched_files $ resolved_pw of+    [] -> return False+    cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts+              || want_external_merge opts /= Nothing+           then do putStrLn "We have conflicts in the following files:"+                   putStrLn $ unwords cfs+                   return True+           else do putStrLn "There are conflicts in the following files:"+                   putStrLn $ unwords cfs+                   fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"+++                          "If you would rather apply the patch and mark the conflicts,\n"+++                          "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"+++                          "These can set as defaults by adding\n"+++                          " "++cmd++" mark-conflicts\n"+++                          "to "++darcsdir++"/prefs/defaults in the target repo. "++check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool+check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False+check_unrecorded_conflicts opts pc =+    do repository <- identifyDarcs1Repository opts "."+       cuc repository+    where cuc :: Repository Patch C(r u t) -> IO Bool+          cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r)))+                     case mpend of+                       NilFL -> return False+                       pend ->+                           case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of+                           _ :/\: pend' ->+                               case list_conflicted_files pend' of+                               [] -> return False+                               fs -> do yorn <- promptYorn+                                                ("You have conflicting local changes to:\n"+                                                 ++ unwords fs++"\nProceed?")+                                        when (yorn /= 'y') $+                                             do putStrLn "Cancelled."+                                                exitWith ExitSuccess+                                        return True+          fromPrims_ :: FL Prim C(a b) -> p C(a b)+          fromPrims_ = fromPrims++tentativelyAddPatch :: RepoPatch p+                    => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(r y) -> IO ()+tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine++data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq++tentativelyAddPatch_ :: RepoPatch p+                     => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag]+                     -> PatchInfoAnd p C(r y) -> IO ()+tentativelyAddPatch_ _ _ opts _+    | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified"+tentativelyAddPatch_ up r@(Repo dir _ rf (DarcsRepository _ c)) opts p =+    withCurrentDirectory dir $+    do decideHashedOrNormal rf $ HvsO {+          hashed = HashedRepo.add_to_tentative_inventory c (compression opts) p,+          old = DarcsRepo.add_to_tentative_inventory opts (hopefully p) }+       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."+                                        applyToTentativePristine r p+                                        debugMessage "Updating pending..."+                                        handle_pend_for_add r p++applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r y) -> IO ()+applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p =+    withCurrentDirectory dir $+    do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p+       decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.apply_to_tentative_pristine c opts p,+                                       old = DarcsRepo.add_to_tentative_pristine p}++-- | This fuction is unsafe because it accepts a patch that works on the tentative+-- pending and we don't currently track the state of the tentative pending.+tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p+                        => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO ()+tentativelyAddToPending (Repo _ opts _ _) _ _+    | NoUpdateWorking `elem` opts = return ()+    | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified"+tentativelyAddToPending (Repo dir _ _ rt) _ patch =+    withCurrentDirectory dir $ do+      let pn = pendingName rt+          tpn = pn ++ ".tentative"+      Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty))+      FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch+      writePatch tpn $ fromPrims_ newpend_+      where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c)+            newpend NilFL patch_ = flipSeal patch_+            newpend p     patch_ = flipSeal $ p +>+ patch_+            fromPrims_ :: FL Prim C(a b) -> Patch C(a b)+            fromPrims_ = fromPrims++-- | setTentativePending is basically unsafe.  It overwrites the pending state with a new one, not related to+-- the repository state.+setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO ()+setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+setTentativePending (Repo dir _ _ rt) patch = do+    Sealed prims <- return $ sift_for_pending patch+    withCurrentDirectory dir $+      writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims+    where fromPrims_ :: FL Prim C(a b) -> Patch C(a b)+          fromPrims_ = fromPrims++-- | prepend is basically unsafe.  It overwrites the pending state+-- with a new one, not related to the repository state.+prepend :: forall p C(r u t x y). RepoPatch p =>+           Repository p C(r u t) -> FL Prim C(x y) -> IO ()+prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()+prepend (Repo _ _ _ rt) patch =+    do let pn = pendingName rt ++ ".tentative"+       Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty))+       Sealed newpend_ <- return $ newpend pend patch+       writePatch pn $ fromPrims_ (crude_sift newpend_)+      where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a))+            newpend NilFL patch_ = seal patch_+            newpend p     patch_ = seal $ patch_ +>+ p+            fromPrims_ :: FL Prim C(a b) -> Patch C(a b)+            fromPrims_ = fromPrims++tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]+                         -> FL (Named p) C(x t) -> IO ()+tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine++tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine+                          -> Repository p C(r u t) -> [DarcsFlag]+                          -> FL (Named p) C(x t) -> IO ()+tentativelyRemovePatches_ up repository@(Repo dir _ rf (DarcsRepository _ c)) opts ps =+    withCurrentDirectory dir $ do+      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."+                                       prepend repository $ effect ps+      remove_from_unrevert_context repository ps+      debugMessage "Removing changes from tentative inventory..."+      if format_has HashedInventory rf+        then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps+                when (up == UpdatePristine) $+                     HashedRepo.apply_to_tentative_pristine c opts $+                     progressFL "Applying inverse to pristine" $ invert ps+        else DarcsRepo.remove_from_tentative_inventory (up==UpdatePristine) opts ps++tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]+                          -> FL (Named p) C(x t) -> IO ()+tentativelyReplacePatches repository@(Repo x y z w) opts ps =+    -- tentativelyRemovePatches_ leaves the repository in state C(x u t)+    do tentativelyRemovePatches_ DontUpdatePristine repository opts ps+       -- Now we add the patches back so that the repo again has state C(r u t)+       sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps+  where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()]+        mapAdd _ NilFL = []+        mapAdd r@(Repo dir df rf dr) (a:>:as) =+               -- we construct a new Repository object on the recursive case so that the+               -- recordedstate of the repository can match the fact that we just wrote a patch+               tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as++finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO ()+finalize_pending (Repo dir opts _ rt)+    | NoUpdateWorking `elem` opts =+        withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)+finalize_pending repository@(Repo dir _ _ rt) = do+  withCurrentDirectory dir $ do let pn = pendingName rt+                                    tpn = pn ++ ".tentative"+                                tpfile <- gzReadFilePS tpn `catchall` (return B.empty)+                                Sealed tpend <- return $ readPrims tpfile+                                Sealed new_pending <- return $ sift_for_pending tpend+                                make_new_pending repository new_pending++finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()+finalizeRepositoryChanges (Repo _ opts _ _)+    | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"+finalizeRepositoryChanges repository@(Repo dir opts rf _)+    | format_has HashedInventory rf =+        withCurrentDirectory dir $ do debugMessage "Considering whether to test..."+                                      testTentative repository+                                      debugMessage "Finalizing changes..."+                                      withSignalsBlocked $ do HashedRepo.finalize_tentative_changes repository (compression opts)+                                                              finalize_pending repository+                                      debugMessage "Done finalizing changes..."+finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) =+  withCurrentDirectory dir $ do debugMessage "Considering whether to test..."+                                testTentative repository+                                debugMessage "Finalizing changes..."+                                withSignalsBlocked $ do DarcsRepo.finalize_pristine_changes+                                                        DarcsRepo.finalize_tentative_changes+                                                        finalize_pending repository++testTentative :: RepoPatch p => Repository p C(r u t) -> IO ()+testTentative = testAny withTentative++testRecorded :: RepoPatch p => Repository p C(r u t) -> IO ()+testRecorded = testAny withRecorded++testAny :: RepoPatch p => (Repository p C(r u t)+                               -> ((AbsolutePath -> IO ()) -> IO ())+                               -> (AbsolutePath -> IO ()) -> IO ())+        ->  Repository p C(r u t) -> IO ()+testAny withD repository@(Repo dir opts _ _) =+    when (Test `elem` opts) $ withCurrentDirectory dir $+    do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ())+       debugMessage "About to run test if it exists."+       testline <- get_prefval "test"+       case testline of+         Nothing -> return ()+         Just testcode ->+             withD repository (wd "testing") $ \_ ->+             do putInfo "Running test...\n"+                when (SetScriptsExecutable `elem` opts) setScriptsExecutable+                ec <- system testcode+                if ec == ExitSuccess+                  then putInfo "Test ran successfully.\n"+                  else do putInfo "Test failed!\n"+                          exitWith ec+    where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir++revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()+revertRepositoryChanges (Repo _ opts _ _)+    | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"+revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =+    withCurrentDirectory dir $+    do removeFileMayNotExist (pendingName dr ++ ".tentative")+       Sealed x <- read_pending r+       setTentativePending r $ effect x+       when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr+       decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes,+                                        old = DarcsRepo.revert_tentative_changes }++patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y)+patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL patchSet++getUMask :: [DarcsFlag] -> Maybe String+getUMask [] = Nothing+getUMask ((UMask u):_) = Just u+getUMask (_:l) = getUMask l++withGutsOf :: Repository p C(r u t) -> IO () -> IO ()+withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id+                           | otherwise = withSignalsBlocked++withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a+withRepository opts1 = withRepositoryDirectory opts1 "."++withRepositoryDirectory :: forall a. [DarcsFlag] -> String+                        -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a+withRepositoryDirectory opts1 url job =+    do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url+       let rt' = case rt of DarcsRepository t c -> DarcsRepository t c+       if format_has Darcs2 rf+         then do debugMessage $ "Identified darcs-2 repo: " ++ dir+                 job1_ (Repo dir opts rf rt')+         else do debugMessage $ "Identified darcs-1 repo: " ++ dir+                 job2_ (Repo dir opts rf rt)+  where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a+        job1_ = job+        job2_ :: Repository Patch C(r u r) -> IO a+        job2_ = job+++-- RankNTypes+-- $- works around the lack of impredicative instantiation in GHC+($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a)+     -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a+x $- y = x y++withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a+withRepoLock opts job =+    withRepository opts $- \repository@(Repo _ _ rf _) ->+    do case write_problem rf of+         Nothing -> return ()+         Just err -> fail err+       let name = "./"++darcsdir++"/lock"+           wu = case (getUMask opts) of+                  Nothing -> id+                  Just u -> withUMask u+       wu $ if DryRun `elem` opts+            then job repository+            else withLock name (revertRepositoryChanges repository >> job repository)++withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a+withRepoReadLock opts job =+    withRepository opts $- \repository@(Repo _ _ rf _) ->+    do case write_problem rf of+         Nothing -> return ()+         Just err -> fail err+       let name = "./"++darcsdir++"/lock"+           wu = case (getUMask opts) of Nothing -> id+                                        Just u -> withUMask u+       wu $ if format_has HashedInventory rf || DryRun `elem` opts+            then job repository+            else withLock name (revertRepositoryChanges repository >> job repository)++remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p+                             => Repository p C(r u t) -> FL (Named p) C(x t) -> IO ()+remove_from_unrevert_context repository ps = do+  Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL))+  remove_from_unrevert_context_ bundle+  where unrevert_impossible unrevert_loc =+            do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"+               case yorn of+                 'n' -> fail "Cancelled."+                 'y' -> removeFile unrevert_loc `catchall` return ()+                 _ -> impossible+        pis = mapFL patch2patchinfo ps+        unrevert_patch_bundle :: IO (SealedPatchSet p)+        unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)+                                   case scan_bundle pf of+                                     Right foo -> return foo+                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+        remove_from_unrevert_context_ :: PatchSet p C(z) -> IO ()+        remove_from_unrevert_context_ (NilRL :<: NilRL) = return ()+        remove_from_unrevert_context_ bundle = do+            let unrevert_loc = unrevertUrl repository+            debugMessage "Adjusting the context of the unrevert changes..."+            ref <- readTentativeRepo repository+            case get_common_and_uncommon (bundle, ref) of+                 (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) ->+                    case commuteRL (reverseFL ps :> hopefully h_us) of+                    Nothing -> unrevert_impossible unrevert_loc+                    Just (us' :> _) -> do+                        s <- slurp_recorded repository+                        writeDocBinFile unrevert_loc $+                             make_bundle [] s+                             (common \\ pis) (us':>:NilFL)+                 (common,(x:<:NilRL):<:NilRL:\/:_)+                        | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc+                        | isr -> return ()+                        where isr = isJust $ hopefullyM x+                 _ -> unrevert_impossible unrevert_loc++-- | Writes out a fresh copy of the inventory that minimizes the+-- amount of inventory that need be downloaded when people pull from+-- the repository.+--+-- Specifically, it breaks up the inventory on the most recent tag.+-- This speeds up most commands when run remotely, both because a+-- smaller file needs to be transfered (only the most recent+-- inventory).  It also gives a guarantee that all the patches prior+-- to a given tag are included in that tag, so less commutation and+-- history traversal is needed.  This latter issue can become very+-- important in large repositories.+optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO ()+optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) =+    do ps <- read_repo repository+       decideHashedOrNormal rf $+           HvsO { hashed = do revertRepositoryChanges repository+                              HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps+                              finalizeRepositoryChanges repository,+                  old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps+                }++cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()+cleanRepository repository@(Repo _ _ rf _) =+    decideHashedOrNormal rf $+    HvsO { hashed = HashedRepo.clean_pristine repository,+           old = return () }++replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO ()+replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s+    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s+    | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris++createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()+createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir+    | format_has HashedInventory rf =+        do createDirectoryIfMissing True reldir+           withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory")+    | otherwise =+        do dir <- toPath `fmap` ioAbsoluteOrRemote reldir+           done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir+           unless done $ do Sealed patches <- (seal . reverseRL . concatRL) `liftM` read_repo repo+                            createDirectoryIfMissing True dir+                            withCurrentDirectory dir $ apply_patches [] patches++-- fp below really should be FileName+createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()+createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir+    | format_has HashedInventory rf =+        do createDirectoryIfMissing True dir+           withCurrentDirectory dir $+               HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs+createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir+ = withCurrentDirectory rdir $+   do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir+      unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do+          clonePartialsTree "." dir (map toFilePath prefs)++pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()+pristineFromWorking (Repo dir opts rf (DarcsRepository _ c))+    | format_has HashedInventory rf =+        withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts)+pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =+  withCurrentDirectory dir $ createPristineFromWorking p++withRecorded :: RepoPatch p => Repository p C(r u t)+             -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a+withRecorded repository mk_dir f+    = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)+                        f d++checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool+checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 =+    do s1 <- slurp_recorded repository+       ftf <- filetype_function+       -- The @$!@ is necessary because some code called from this function uses+       -- unsafeInterleaveIO around functions that throw exceptions. If one used+       -- @$@ instead of @$!@ here, those exceptions might not be caught by code+       -- that runs this function inside a @catch@.+       return $! nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2++withTentative :: forall p a C(r u t). RepoPatch p =>+                 Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)+              -> (AbsolutePath -> IO a) -> IO a+withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f+    | format_has HashedInventory rf =+        mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine")+                          f d+withTentative repository@(Repo dir opts _ _) mk_dir f =+    withRecorded repository mk_dir $ \d ->+    do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")+       apply opts $ joinPatches ps+       f d+    where read_patches :: FilePath -> IO (Sealed (FL p C(x)))+          read_patches fil = do ps <- B.readFile fil+                                return $ case readPatch ps of+                                           Just (x, _) -> x+                                           Nothing -> seal NilFL++getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile+getMarkedupFile repository pinfo f = do+  Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info)+                                  . reverseRL . concatRL) `liftM` read_repo repository+  return $ snd $ do_mark_all patches (f, empty_markedup_file)+  where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)+        dropWhileFL _ NilFL       = flipSeal NilFL+        dropWhileFL p xs@(x:>:xs')+              | p x       = dropWhileFL p xs'+              | otherwise = flipSeal xs+do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y)+            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)+do_mark_all (hp:>:pps) (f, mk) =+    case hopefullyM hp of+    Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk)+    Nothing -> (f, [(BC.pack "Error reading a patch!",None)])+do_mark_all NilFL (f, mk) = (f, mk)++-- | Sets scripts in or below the current directory executable. A script is any file that starts+--   with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times+--   --set-scripts-executable is handled by the hunk patch case of applyFL.+setScriptsExecutable :: IO ()+setScriptsExecutable = do+    debugMessage "Making scripts executable"+    myname <- getCurrentDirectory+    c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname)+    let setExecutableIfScript f =+              do contents <- B.readFile f+                 when (BC.pack "#!" `B.isPrefixOf` contents) $ do+                   debugMessage ("Making executable: " ++ f)+                   setExecutable f True+    mapM_ setExecutableIfScript c
+ src/Darcs/Repository/InternalTypes.hs view
@@ -0,0 +1,42 @@+-- Copyright (C) 2006-2007 David Roundy+--+-- 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; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , KindSignatures #-}++#include "gadts.h"++module Darcs.Repository.InternalTypes ( Repository(..), RepoType(..), Pristine(..)+                                      , extractCache+                                      ) where++import Darcs.Repository.Cache ( Cache )+import Darcs.Flags ( DarcsFlag )+import Darcs.Repository.Format ( RepoFormat )++data Pristine+  = NoPristine !String+  | PlainPristine !String+  | HashedPristine+    deriving ( Show )++data Repository (p :: * C(-> * -> *)) C(recordedstate unrecordedstate tentativestate) = Repo !String ![DarcsFlag] !RepoFormat !(RepoType p) deriving ( Show )++data RepoType (p :: * C(-> * -> *)) = DarcsRepository !Pristine Cache deriving ( Show )++extractCache :: Repository p C(r u t) -> Cache+extractCache (Repo _ _ _ (DarcsRepository _ c)) = c
+ src/Darcs/Repository/Motd.lhs view
@@ -0,0 +1,49 @@+%  Copyright (C) 2002-2004 David Roundy+%+%  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.+++\begin{code}+module Darcs.Repository.Motd (get_motd, show_motd) where+import Control.Monad ( unless )+import Darcs.Flags ( DarcsFlag( Quiet, XMLOutput ) )+import Darcs.External ( fetchFilePS, Cachable(..) )+import Darcs.Global ( darcsdir )+import qualified Data.ByteString as B (null, hPut, empty, ByteString)+import Darcs.Utils ( catchall )+import System.IO ( stdout )+\end{code}++\paragraph{motd}\label{motd}+The \verb!_darcs/prefs/motd! file may contain a ``message of the day''+which will be displayed to users who get or pull from the repository without the+\verb!--quiet! option.++\begin{code}+-- | Fetch and return the message of the day for a given repository.+get_motd :: String -> IO B.ByteString+get_motd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600)+                     `catchall` return B.empty++-- | Display the message of the day for a given repository,+--   unless either the 'XMLOutput' or the 'Quiet' flags are passed in+show_motd :: [DarcsFlag] -> String -> IO ()+show_motd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do+  motd <- get_motd repo+  unless (B.null motd)+      $ do B.hPut stdout motd+           putStrLn "**********************"+\end{code}
+ src/Darcs/Repository/Prefs.lhs view
@@ -0,0 +1,528 @@+%  Copyright (C) 2002-2003 David Roundy+%+%  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.+++\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.Prefs ( add_to_preflist, get_preflist, set_preflist,+                   get_global, environmentHelpHome,+                   defaultrepo, set_defaultrepo,+                   get_prefval, set_prefval, change_prefval,+                   def_prefval,+                   write_default_prefs,+                   boring_regexps, boring_file_filter, darcsdir_filter,+                   FileType(..), filetype_function,+                   getCaches,+                   binaries_file_help+                 ) where++import System.IO.Error ( isDoesNotExistError )+import Control.Monad ( unless, when, mplus )+import Text.Regex ( Regex, mkRegex, matchRegex, )+import Data.Char ( toUpper )+import Data.Maybe ( isJust, catMaybes )+import Data.List ( nub, isPrefixOf, union )+import System.Directory ( getAppUserDataDirectory )+import System.FilePath ( (</>) )++import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, Ephemeral, RemoteRepo ) )+import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory )+import Darcs.Utils ( catchall, stripCr )+import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )+import Darcs.Patch.FileName ( fp2fn )+import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) )+import qualified Data.ByteString.Char8 as BC ( unpack )+import qualified Data.ByteString       as B  ( empty )+import Darcs.Global ( darcsdir )+import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..),+                                WritableOrNot(..) )+import Darcs.URL ( is_file )+\end{code}++\section{prefs}++The \verb!_darcs! directory contains a \verb!prefs!  directory.  This+directory exists simply to hold user configuration settings specific to+this repository.  The contents of this directory are intended to be+modifiable by the user, although in some cases a mistake in such a+modification may cause darcs to behave strangely.++++\input{Darcs/ArgumentDefaults.lhs}++\begin{code}+write_default_prefs :: IO ()+write_default_prefs = do set_preflist "boring" default_boring+                         set_preflist "binaries" default_binaries+                         set_preflist "motd" []+\end{code}++\paragraph{repos}+The \verb!_darcs/prefs/repos! file contains a list of repositories you have+pulled from or pushed to, and is used for autocompletion of pull and push+commands in bash.  Feel free to delete any lines from this list that might+get in there, or to delete the file as a whole.++\paragraph{author}\label{author_prefs}+The \verb!_darcs/prefs/author! file contains the email address (or name) to+be used as the author when patches are recorded in this repository,+e.g.\ \verb!David Roundy <droundy@abridgegame.org>!.  This+file overrides the contents of the environment variables+\verb!$DARCS_EMAIL! and \verb!$EMAIL!.++\paragraph{boring}\label{boring}+The \verb!_darcs/prefs/boring! file may contain a list of regular+expressions describing files, such as object files, that you do not expect+to add to your project.  As an example, the boring file that I use with+my darcs repository is:+\begin{verbatim}+\.hi$+\.o$+^\.[^/]+^_+~$+(^|/)CVS($|/)+\end{verbatim}+A newly created repository has a longer boring file that+includes many common source control, backup, temporary, and compiled files.++You may want to have the boring file under version+control.  To do this you can use darcs setpref to set the value+``boringfile'' to the name of your desired boring file+(e.g.\ \verb-darcs setpref boringfile .boring-, where \verb-.boring-+is the repository path of a file+that has been+darcs added to your repository).  The boringfile preference overrides+\verb!_darcs/prefs/boring!, so be sure to copy that file to the boringfile.++You can also set up a ``boring'' regexps+file in your home directory, named \verb!~/.darcs/boring!, +on MS Windows~\ref{ms_win}, which will be+used with all of your darcs repositories.++Any file not already managed by darcs and whose repository path (such+as \verb!manual/index.html!) matches any of+the boring regular expressions is considered boring.  The boring file is+used to filter the files provided to darcs add, to allow you to use a+simple \verb-darcs add newdir newdir/*-+without accidentally adding a bunch of+object files.  It is also used when the \verb!--look-for-adds! flag is+given to whatsnew or record.+Note that once a file has been added to darcs, it is not considered+boring, even if it matches the boring file filter.++\begin{code}+{-# NOINLINE default_boring #-}+default_boring :: [String]+default_boring = ["# Boring file regexps:",+                  "",+                  "### compiler and interpreter intermediate files",+                  "# haskell (ghc) interfaces",+                  "\\.hi$", "\\.hi-boot$", "\\.o-boot$",+                  "# object files",+                  "\\.o$","\\.o\\.cmd$",+                  "# profiling haskell",+                  "\\.p_hi$", "\\.p_o$",+                  "# haskell program coverage resp. profiling info",+                  "\\.tix$", "\\.prof$",+                  "# fortran module files",+                  "\\.mod$",+                  "# linux kernel",+                  "\\.ko\\.cmd$","\\.mod\\.c$",+                  "(^|/)\\.tmp_versions($|/)",+                  "# *.ko files aren't boring by default because they might",+                  "# be Korean translations rather than kernel modules",+                  "# \\.ko$",+                  "# python, emacs, java byte code",+                  "\\.py[co]$", "\\.elc$","\\.class$",+                  "# objects and libraries; lo and la are libtool things",+                  "\\.(obj|a|exe|so|lo|la)$",+                  "# compiled zsh configuration files",+                  "\\.zwc$",+                  "# Common LISP output files for CLISP and CMUCL",+                  "\\.(fas|fasl|sparcf|x86f)$",+                  "",+                  "### build and packaging systems",+                  "# cabal intermediates",+                  "\\.installed-pkg-config",+                  "\\.setup-config",+                  "# standard cabal build dir, might not be boring for everybody",+                  "# ^dist(/|$)",+                  "# autotools",+                  "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$",+                  "# microsoft web expression, visual studio metadata directories",+                  "\\_vti_cnf$",+                  "\\_vti_pvt$",+                  "# gentoo tools",+                  "\\.revdep-rebuild.*",+                  "# generated dependencies",+                  "^\\.depend$",+                  "",+                  "### version control systems",+                  "# cvs",+                  "(^|/)CVS($|/)","\\.cvsignore$",+                  "# cvs, emacs locks",+                  "^\\.#",+                  "# rcs",+                  "(^|/)RCS($|/)", ",v$",+                  "# subversion",+                  "(^|/)\\.svn($|/)",+                  "# mercurial",+                  "(^|/)\\.hg($|/)",+                  "# git",+                  "(^|/)\\.git($|/)",+                  "# bzr",+                  "\\.bzr$",+                  "# sccs",+                  "(^|/)SCCS($|/)",+                  "# darcs",+                  "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)",+                  "^\\.darcs-temp-mail$",+                  "-darcs-backup[[:digit:]]+$",+                  "# gnu arch",+                  "(^|/)(\\+|,)",+                  "(^|/)vssver\\.scc$",+                  "\\.swp$","(^|/)MT($|/)",+                  "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)",+                  "# bitkeeper",+                  "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)",+                  "",+                  "### miscellaneous",+                  "# backup files",+                  "~$","\\.bak$","\\.BAK$",+                  "# patch originals and rejects",+                  "\\.orig$", "\\.rej$",+                  "# X server",+                  "\\..serverauth.*",+                  "# image spam",+                  "\\#", "(^|/)Thumbs\\.db$",+                  "# vi, emacs tags",+                  "(^|/)(tags|TAGS)$",+                  "#(^|/)\\.[^/]",+                  "# core dumps",+                  "(^|/|\\.)core$",+                  "# partial broken files (KIO copy operations)",+                  "\\.part$",+                  "# waf files, see http://code.google.com/p/waf/",+                  "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)",+                  "(^|/)\\.lock-wscript$",+                  "# mac os finder",+                  "(^|/)\\.DS_Store$" ]++darcsdir_filter :: [FilePath] -> [FilePath]+darcsdir_filter = filter (not.is_darcsdir)+is_darcsdir :: FilePath -> Bool+is_darcsdir ('.':'/':f) = is_darcsdir f+is_darcsdir "." = True+is_darcsdir "" = True+is_darcsdir ".." = True+is_darcsdir "../" = True+is_darcsdir fp = darcsdir `isPrefixOf` fp++-- | The path of the global preference directory; @~/.darcs@ on Unix,+-- and @%APPDATA%/darcs@ on Windows.+global_prefs_dir :: IO (Maybe FilePath)+global_prefs_dir = (getAppUserDataDirectory "darcs" >>= return.Just)+                   `catchall` (return Nothing)++environmentHelpHome :: ([String], [String])+environmentHelpHome = (["HOME", "APPDATA"], [+ "Per-user preferences are set in $HOME/.darcs (on Unix) or",+ "%APPDATA%/darcs (on Windows).  This is also the default location of",+ "the cache."])++get_global :: String -> IO [String]+get_global f = do+  dir <- global_prefs_dir+  case dir of+    (Just d) -> get_preffile $ d </> f+    Nothing -> return []++global_cache_dir :: IO (Maybe FilePath)+global_cache_dir = slash_cache `fmap` global_prefs_dir+  where slash_cache = fmap (</> "cache")++boring_regexps :: IO [Regex]+boring_regexps = do+    borefile <- def_prefval "boringfile" (darcsdir ++ "/prefs/boring")+    bores <- get_lines borefile `catchall` return []+    gbs <- get_global "boring"+    return $ map mkRegex $ bores ++ gbs++boring_file_filter :: IO ([FilePath] -> [FilePath])+boring_file_filter = boring_regexps >>= return . actual_boring_file_filter++noncomments :: [String] -> [String]+noncomments ss = filter is_ok ss+                 where is_ok "" = False+                       is_ok ('#':_) = False+                       is_ok _ = True++get_lines :: ReadableDirectory m => FilePath -> m [String]+get_lines f = (notconflicts . noncomments . map stripCr . lines)+              `fmap` mReadBinFile (fp2fn f)+    where notconflicts = filter nc+          startswith [] _ = True+          startswith (x:xs) (y:ys) | x == y = startswith xs ys+          startswith _ _ = False+          nc l | startswith "v v v v v v v" l = False+          nc l | startswith "*************" l = False+          nc l | startswith "^ ^ ^ ^ ^ ^ ^" l = False+          nc _ = True++-- | From a list of paths, filter out any that are within @_darcs@ or+-- match a boring regexp.+actual_boring_file_filter :: [Regex] -> [FilePath] -> [FilePath]+actual_boring_file_filter regexps files = filter (not . boring . normalize) files+    where boring file = is_darcsdir file ||+                        any (\regexp -> isJust $ matchRegex regexp file) regexps++normalize :: FilePath -> FilePath+normalize ('.':'/':f) = normalize f+normalize f = normalize_helper $ reverse f+              where+              normalize_helper ('/':rf) = normalize_helper rf+              normalize_helper rf = reverse rf+\end{code}++\paragraph{binaries}+The \verb!_darcs/prefs/binaries! file may contain a list of regular+expressions describing files that should be treated as binary files rather+than text files. Darcs automatically treats files containing+\verb!^Z\! or \verb!'\0'! within the first 4096 bytes as being binary files.+You probably will want to have the binaries file under+version control.  To do this you can use darcs setpref to set the value+``binariesfile'' to the name of your desired binaries file+(e.g.\ \verb'darcs setpref binariesfile ./.binaries', where+\verb'.binaries' is a file that has been+darcs added to your repository).  As with the boring file, you can also set+up a \verb!~/.darcs/binaries! file if you like, on MS Windows~\ref{ms_win}.++\begin{code}+data FileType = BinaryFile | TextFile+                deriving (Eq)++{-# NOINLINE default_binaries #-}+-- | The lines that will be inserted into @_darcs/prefs/binaries@ when+-- @darcs init@ is run.  Hence, a list of comments, blank lines and+-- regular expressions (ERE dialect).+--+-- Note that while this matches .gz and .GZ, it will not match .gZ,+-- i.e. it is not truly case insensitive.+default_binaries :: [String]+default_binaries = help +++                   ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ]+    where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso",+                        "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png",+                        "pyc","so","tar","tgz","tiff?","z","zip"]+          help = map ("# "++) binaries_file_help++binaries_file_help :: [String]+binaries_file_help =+  ["This file contains a list of extended regular expressions, one per",+   "line.  A file path matching any of these expressions is assumed to",+   "contain binary data (not text).  The entries in ~/.darcs/binaries (if",+   "it exists) supplement those in this file.",+   "",+   "Blank lines, and lines beginning with an octothorpe (#) are ignored.",+   "See regex(7) for a description of extended regular expressions."]++filetype_function :: IO (FilePath -> FileType)+filetype_function = do+    binsfile <- def_prefval "binariesfile" (darcsdir ++ "/prefs/binaries")+    bins <- get_lines binsfile `catch`+             (\e-> if isDoesNotExistError e then return [] else ioError e)+    gbs <- get_global "binaries"+    regexes <- return (map (\r -> mkRegex r) (bins ++ gbs))+    let isbin f = or $ map (\r -> isJust $ matchRegex r f) regexes+        ftf f = if isbin $ normalize f then BinaryFile else TextFile+        in+        return ftf++-- this avoids a circular dependency with Repository+prefsDirectory :: ReadableDirectory m => m String+prefsDirectory =+    do darcs <- mDoesDirectoryExist $ fp2fn darcsdir+       if darcs+          then return $ darcsdir ++ "/prefs/"+          else fail $ "Directory " ++ darcsdir ++ "/ does not exist!"++withPrefsDirectory :: ReadableDirectory m => (String -> m ()) -> m ()+withPrefsDirectory j = do prefs <- prefsDirectory `mplus` return "x"+                          when (prefs /= "x") $ j prefs++add_to_preflist :: WriteableDirectory m => String -> String -> m ()+add_to_preflist p s = withPrefsDirectory $ \prefs -> do+  hasprefs <- mDoesDirectoryExist $ fp2fn prefs+  unless hasprefs $ mCreateDirectory $ fp2fn prefs+  pl <- get_preflist p+  mWriteBinFile (fp2fn $ prefs ++ p) $ unlines $ union [s] pl++get_preflist :: ReadableDirectory m => String -> m [String]+get_preflist p = do prefs <- prefsDirectory `mplus` return "x"+                    if (prefs /= "x") then get_preffile $ prefs ++ p+                                      else return []++get_preffile :: ReadableDirectory m => FilePath -> m [String]+get_preffile f = do+  hasprefs <- mDoesFileExist (fp2fn f)+  if hasprefs+    then get_lines f+    else return []++set_preflist :: WriteableDirectory m => String -> [String] -> m ()+set_preflist p ls = withPrefsDirectory $ \prefs -> do+  haspref <- mDoesDirectoryExist $ fp2fn prefs+  if haspref+     then mWriteBinFile (fp2fn $ prefs ++ p) (unlines ls)+     else return ()++def_prefval :: String -> String -> IO String+def_prefval p d = do+  pv <- get_prefval p+  case pv of Nothing -> return d+             Just v -> return v++get_prefval :: ReadableDirectory m => String -> m (Maybe String)+get_prefval p =+    do pl <- get_preflist "prefs"+       case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of+           [val] -> case words val of+               [] -> return Nothing+               _ -> return $ Just $ tail val+           _ -> return Nothing++set_prefval :: WriteableDirectory m => String -> String -> m ()+set_prefval p v = do pl <- get_preflist "prefs"+                     set_preflist "prefs" $+                       filter ((/=p).fst.(break (==' '))) pl ++ [p++" "++v]++change_prefval :: WriteableDirectory m => String -> String -> String -> m ()+change_prefval p f t =+    do pl <- get_preflist "prefs"+       ov <- get_prefval p+       newval <- case ov of+                 Nothing -> return t+                 Just old -> if old == f then return t else return old+       set_preflist "prefs" $+                    filter ((/=p).fst.(break(==' '))) pl ++ [p++" "++newval]++defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+defaultrepo opts _ [] =+  do let fixR r | not (is_file r) = return r+                | otherwise = do absr <- ioAbsolute r+                                 return $ toFilePath absr+     case [r | RemoteRepo r <- opts] of+       [] -> do defrepo <- get_preflist "defaultrepo"+                case defrepo of+                  [r] -> (:[]) `fmap` fixR r+                  _ -> return []+       rs -> mapM fixR rs+defaultrepo _ _ r = return r++set_defaultrepo :: String -> [DarcsFlag] -> IO ()+set_defaultrepo r opts = do doit <- if (NoSetDefault `notElem` opts && DryRun `notElem` opts && r_is_not_tmp)+                                    then return True+                                    else do olddef <-+                                                get_preflist "defaultrepo"+                                            return (olddef == [])+                            when doit+                                (set_preflist "defaultrepo" [r])+                            add_to_preflist "repos" r+                         `catchall` return () -- we don't care if this fails!+ where+  r_is_not_tmp = not $ r `elem` [x | RemoteRepo x <- opts]+\end{code}++\paragraph{email}+The \verb!_darcs/prefs/email! file is used to provide the e-mail address for your+repository that others will use when they \verb!darcs send! a patch back to you.+The contents of the file should simply be an e-mail address.+++\paragraph{sources}+The \verb!_darcs/prefs/sources! file is used to indicate alternative+locations from which to download patches when using a ``hashed''+repository.  This file contains lines such as:+\begin{verbatim}+cache:/home/droundy/.darcs/cache+readonly:/home/otheruser/.darcs/cache+repo:http://darcs.net+\end{verbatim}+This would indicate that darcs should first look in+\verb!/home/droundy/.darcs/cache! for patches that might be missing, and if+the patch isn't there, it should save a copy there for future use.  In that+case, darcs will look in \verb!/home/otheruser/.darcs/cache! to see if that+user might have downloaded a copy, but won't try to save a copy there, of+course.  Finally, it will look in \verb!http://darcs.net!.  Note that the+\verb!sources! file can also exist in \verb!~/.darcs/!.  Also note that the+sources mentioned in your \verb!sources! file will be tried \emph{before}+the repository you are pulling from.  This can be useful in avoiding+downloading patches multiple times when you pull from a remote repository+to more than one local repository.++We strongly advise that you enable a global cache directory, which will+allow darcs to avoid re-downloading patches (for example, when doing a+second darcs get of the same repository), and also allows darcs to use hard+links to reduce disk usage.  To do this, simply+\begin{verbatim}+mkdir -p $HOME/.darcs/cache+echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources+\end{verbatim}+Note that the cache directory should reside on the same filesystem as your+repositories, so you may need to vary this.  You can also use multiple+cache directories on different filesystems, if you have several filesystems+on which you use darcs.++On MS Windows~\ref{ms_win})++\begin{code}+getCaches :: [DarcsFlag] -> String -> IO Cache+getCaches opts repodir =+    do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources")+       there <- (parsehs . lines . BC.unpack) `fmap`+                (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable+                 `catchall` return B.empty)+       globalcachedir <- global_cache_dir+       let globalcache = case (nocache,globalcachedir) of+                           (True,_) -> []+                           (_,Just d) -> [Cache Directory Writable d]+                           _ -> []+       globalsources <- parsehs `fmap` get_global "sources"+       thisdir <- getCurrentDirectory+       let thisrepo = if Ephemeral `elem` opts+                      then [Cache Repo NotWritable $ toFilePath thisdir]+                      else [Cache Repo Writable $ toFilePath thisdir]+       return $ Ca $ nub $ thisrepo ++ globalcache ++ globalsources +++                  here ++ [Cache Repo NotWritable repodir] ++ there+      where +            parsehs = catMaybes . map readln . noncomments+            readln l | take 5 l == "repo:" = Just (Cache Repo NotWritable (drop 5 l))+                     | take 9 l == "thisrepo:" = Just (Cache Repo Writable (drop 9 l))+                     | nocache = Nothing+                     | take 6 l == "cache:" = Just (Cache Directory Writable (drop 6 l))+                     | take 9 l == "readonly:" = Just (Cache Directory NotWritable (drop 9 l))+                     | otherwise = Nothing+            nocache = NoCache `elem` opts+            +\end{code}+
+ src/Darcs/Repository/Pristine.hs view
@@ -0,0 +1,198 @@+-- Copyright (C) 2002-2005 David Roundy+-- Copyright (C) 2004 Juliusz Chroboczek+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine,+                 createPristine, removePristine, identifyPristine,+                 slurpPristine,+                 applyPristine, createPristineFromWorking,+                 syncPristine, replacePristineFromSlurpy,+                 getPristinePop,+                 pristineDirectory, pristineToFlagString,+                 easyCreatePristineDirectoryTree,+                 easyCreatePartialsPristineDirectoryTree+               ) where++import Data.Maybe ( isJust )+import Control.Monad ( when, liftM )+import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist,+                   renameDirectory, removeFile )+import Darcs.Lock ( rm_recursive, writeBinFile )+import Darcs.Diff ( sync )+import Workaround ( getCurrentDirectory )+import Darcs.SlurpDirectory ( Slurpy,  mmap_slurp, co_slurp, writeSlurpy )+import Darcs.Utils ( catchall )++import Darcs.PopulationData ( Population, getPopFrom )+import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) )+import Darcs.Repository.Format ( RepoFormat, format_has,+                                 RepoProperty(HashedInventory) )+import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) )+import Darcs.Patch ( Patchy, apply )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.FileName ( fp2fn )+import qualified Data.ByteString as B (empty)+import Darcs.RepoPath ( FilePathLike, toFilePath )+import SHA1 ( sha1PS )+import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )+import Darcs.Repository.InternalTypes ( Pristine(..) )+import Darcs.Global ( darcsdir )+#include "impossible.h"++nopristine :: Pristine+nopristine = NoPristine "aack?"++pristineName :: String+pristineName = "pristine"++identifyPristine :: IO (Pristine)+identifyPristine = do mp <- reallyIdentifyPristine+                      case mp of+                          Nothing -> fail "Pristine tree doesn't exist."+                          Just pristine -> return pristine++reallyIdentifyPristine :: IO (Maybe Pristine)+reallyIdentifyPristine = +    do dir <- findpristine doesDirectoryExist ""+       none <- findpristine doesFileExist ".none"+       hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"+       hashpris <- doesDirectoryExist hashedPristineDirectory+       case (dir, none, hashinv && hashpris) of+           (Nothing, Nothing, False) -> return Nothing+           (Just n, Nothing, False) ->+               return (Just (PlainPristine n))+           (Nothing, Just n, False) ->+               return (Just (NoPristine n))+           (Nothing, Nothing, True) ->+               return (Just HashedPristine)+           _ -> fail "Multiple pristine trees."+    where findpristine fn ext =+              do e1 <- fn n1+                 e2 <- fn n2+                 case (e1, e2) of+                     (False, False) -> return Nothing+                     (True, False) -> return (Just n1)+                     (False, True) -> return (Just n2)+                     (True, True) -> fail "Multiple pristine trees."+              where  n1 = darcsdir++"/pristine" ++ ext+                     n2 = darcsdir++"/current" ++ ext++flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine+flagsToPristine _ rf | format_has HashedInventory rf = HashedPristine+flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none")+flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName)+flagsToPristine (_ : t) rf = flagsToPristine t rf+flagsToPristine [] rf = flagsToPristine [PristinePlain] rf++createPristine :: Pristine -> IO Pristine+createPristine p = +    do oldpristine <- reallyIdentifyPristine+       when (isJust oldpristine) $ fail "Pristine tree already exists."+       case p of+           NoPristine n -> writeBinFile n "Do not delete this file.\n"+           PlainPristine n -> createDirectory n+           HashedPristine -> do createDirectory hashedPristineDirectory+                                writeFile (hashedPristineDirectory++"/"++sha1PS B.empty) ""+       return p++hashedPristineDirectory :: String+hashedPristineDirectory = darcsdir++"/pristine.hashed"++removePristine :: Pristine -> IO ()+removePristine (NoPristine n) = removeFile n+removePristine (PlainPristine n) = rm_recursive n+removePristine HashedPristine = rm_recursive hashedPristineDirectory++slurpPristine :: Pristine -> IO (Maybe Slurpy)+slurpPristine (PlainPristine n) = do cwd <- getCurrentDirectory+                                     slurpy <- mmap_slurp (cwd ++ "/" ++ n)+                                     return (Just slurpy)+slurpPristine (NoPristine _) = return Nothing+slurpPristine HashedPristine =+    bug "HashedPristine is not implemented yet."++applyPristine :: Patchy p => Pristine -> p C(x y) -> IO ()+applyPristine (NoPristine _) _ = return ()+-- We don't need flags for now, since we don't care about+-- SetScriptsExecutable for the pristine cache.+applyPristine (PlainPristine n) p =+    mWithCurrentDirectory (fp2fn n) $ apply [] p+applyPristine HashedPristine _ =+    bug "3 HashedPristine is not implemented yet."++createPristineFromWorking :: Pristine -> IO ()+createPristineFromWorking (NoPristine _) = return ()+createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n+createPristineFromWorking HashedPristine =+    bug "HashedPristine is not implemented yet."++syncPristine :: Pristine -> IO ()+syncPristine (NoPristine _) = return ()+syncPristine (PlainPristine n) =+    do ocur <- mmap_slurp n+       owork <- co_slurp ocur "."+       sync n ocur owork+syncPristine HashedPristine = return () -- FIXME this should be implemented!++replacePristineFromSlurpy :: Slurpy -> Pristine -> IO ()+replacePristineFromSlurpy _ (NoPristine _) = return ()+replacePristineFromSlurpy s (PlainPristine n) =+    do rm_recursive nold+           `catchall` return ()+       writeSlurpy s ntmp+       renameDirectory n nold+       renameDirectory ntmp n+       return ()+           where nold = darcsdir ++ "/" ++ pristineName ++ "-old"+                 ntmp = darcsdir ++ "/" ++ pristineName ++ "-tmp"+replacePristineFromSlurpy _ HashedPristine =+    bug "HashedPristine is not implemented yet."++getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)+getPristinePop pinfo (PlainPristine n) =+    Just `liftM` getPopFrom n pinfo+getPristinePop _ _ = return Nothing++pristineDirectory :: Pristine -> Maybe String+pristineDirectory (PlainPristine n) = Just n+pristineDirectory _ = Nothing++pristineToFlagString :: Pristine -> String+pristineToFlagString (NoPristine _) = "--no-pristine-tree"+pristineToFlagString (PlainPristine _) = "--plain-pristine-tree"+pristineToFlagString HashedPristine =+    bug "HashedPristine is not implemented yet."++easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool+easyCreatePristineDirectoryTree (NoPristine _) _ = return False+easyCreatePristineDirectoryTree (PlainPristine n) p+ = cloneTree n p >> return True+easyCreatePristineDirectoryTree HashedPristine _ =+    bug "HashedPristine is not implemented yet."++easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine+                                        -> FilePath -> IO Bool+easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False+easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p+ = clonePartialsTree n p (map toFilePath prefs) >> return True+easyCreatePartialsPristineDirectoryTree _ HashedPristine _ =+    bug "HashedPristine is not implemented yet."
+ src/Darcs/Repository/Repair.hs view
@@ -0,0 +1,165 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Repository.Repair ( replayRepository,+                                 RepositoryConsistency(..) )+       where+       +import Control.Monad ( when, unless )+import Control.Exception ( finally )+import Data.Maybe ( catMaybes )+import Data.List ( sort )+import System.Directory ( createDirectoryIfMissing )++import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad, syncSlurpy )+import Darcs.Lock( rm_recursive )+import Darcs.Hopefully ( PatchInfoAnd, info )++import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,+                     mapRL )+import Darcs.Patch.Depends ( get_patches_beyond_tag )+import Darcs.Patch.Patchy ( applyAndTryToFix )+import Darcs.Patch.Info ( PatchInfo( .. ), human_friendly )+import Darcs.Patch.Set ( PatchSet )+import Darcs.Patch ( RepoPatch, patch2patchinfo )++import Darcs.Repository.Format ( identifyRepoFormat, +                                 RepoProperty ( HashedInventory ), format_has )+import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) )+import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine,+                                   clean_hashdir )+import Darcs.Repository.HashedRepo ( readHashedPristineRoot )+import Darcs.Repository.Checkpoint ( get_checkpoint_by_default )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository ( Repository, read_repo,+                          checkPristineAgainstSlurpy,+                          makePatchLazy )++import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )+import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )+import Darcs.Utils ( catchall )+import Darcs.Global ( darcsdir )+import Darcs.Flags ( compression )+import Printer ( Doc, putDocLn, text )+import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )+#include "impossible.h"++run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a)+run_slurpy s f =+    case withSlurpy s f of+      Left err -> fail err+      Right x -> return x++update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy+update_slurpy r c opts s = do+  current <- readHashedPristineRoot r+  h <- writeHashedPristine c (compression opts) s+  s' <- slurpHashedPristine c (compression opts) h+  clean_hashdir c HashedPristineDir $ catMaybes [Just h, current]+  return s'++replaceInFL :: FL (PatchInfoAnd a)+            -> [(PatchInfo, PatchInfoAnd a)]+            -> FL (PatchInfoAnd a)+replaceInFL orig [] = orig+replaceInFL NilFL _ = impossible+replaceInFL (o:>:orig) ch@((o',c):ch_rest)+    | info o == o' = c:>:replaceInFL orig ch_rest+    | otherwise = o:>:replaceInFL orig ch++applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy, Bool)+applyAndFix _ _ s _ NilFL = return (NilFL, s, True)+applyAndFix c opts s_ r psin =+    do beginTedious k+       tediousSize k $ lengthFL psin+       (repaired, slurpy, ok) <- aaf s_ psin+       endTedious k+       orig <- (reverseRL . concatRL) `fmap` read_repo r+       return (replaceInFL orig repaired, slurpy, ok)+    where k = "Replaying patch"+          aaf s NilFL = return ([], s, True)+          aaf s (p:>:ps) = do+            (s', mp') <- run_slurpy s $ applyAndTryToFix p+            let !infp = info p -- assure that 'p' can be garbage collected.+            finishedOneIO k $ show $ human_friendly $ infp+            s'' <- syncSlurpy (update_slurpy r c opts) s'+            (ps', s''', restok) <- aaf s'' ps+            case mp' of+              Nothing -> return (ps', s''', restok)+              Just (e,pp) -> do putStrLn e+                                p' <- makePatchLazy r pp+                                return ((infp, p'):ps', s''', False)++data RepositoryConsistency p =+    RepositoryConsistent+  | BrokenPristine Slurpy+  | BrokenPatches Slurpy (PatchSet p)++check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO ()+check_uniqueness putVerbose putInfo repository =+    do putVerbose $ text "Checking that patch names are unique..."+       r <- read_repo repository+       case has_duplicate $ mapRL info $ concatRL r of+         Nothing -> return ()+         Just pinf -> do putInfo $ text "Error! Duplicate patch name:"+                         putInfo $ human_friendly pinf+                         fail "Duplicate patches found."++has_duplicate :: Ord a => [a] -> Maybe a+has_duplicate li = hd $ sort li+    where hd [_] = Nothing+          hd [] = Nothing+          hd (x1:x2:xs) | x1 == x2 = Just x1+                        | otherwise = hd (x2:xs)+replayRepository' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO (RepositoryConsistency p)+replayRepository' repo opts = do+  let putVerbose s = when (Verbose `elem` opts) $ putDocLn s+      putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s+  check_uniqueness putVerbose putInfo repo+  maybe_chk <- get_checkpoint_by_default repo+  let c = extractCache repo+  createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"+  rooth <- writeHashedPristine c (compression opts) empty_slurpy+  s <- slurpHashedPristine c (compression opts) rooth+  putVerbose $ text "Applying patches..."+  patches <- read_repo repo+  (s', newpatches, patches_ok) <- case maybe_chk of+    Just (Sealed chk) ->+        do let chtg = patch2patchinfo chk+           putVerbose $ text "I am repairing from a checkpoint."+           (s'', _) <- run_slurpy s $ applyAndTryToFix chk+           (_, s_, ok) <- applyAndFix c opts s'' repo+                      (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches)+           return (s_, patches, ok)+    Nothing -> do debugMessage "Fixing any broken patches..."+                  let psin = reverseRL $ concatRL patches+                  (ps, s_, ok) <- applyAndFix c opts s repo psin+                  debugMessage "Done fixing broken patches..."+                  return (s_, (reverseFL ps :<: NilRL), ok)+  debugMessage "Checking pristine against slurpy"+  is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False+  -- TODO is the latter condition needed? Does a broken patch imply pristine+  -- difference? Why, or why not?+  return (if is_same && patches_ok+     then RepositoryConsistent+     else if patches_ok+            then BrokenPristine s'+            else BrokenPatches s' newpatches)++cleanupRepositoryReplay :: Repository p -> IO ()+cleanupRepositoryReplay r = do+  let c = extractCache r+  rf_or_e <- identifyRepoFormat "."+  rf <- case rf_or_e of Left e -> fail e+                        Right x -> return x+  unless (format_has HashedInventory rf) $+         rm_recursive $ darcsdir ++ "/pristine.hashed" +  when (format_has HashedInventory rf) $ do+       current <- readHashedPristineRoot r+       clean_hashdir c HashedPristineDir $ catMaybes [current]++replayRepository :: (RepoPatch p) => Repository p -> [DarcsFlag] -> (RepositoryConsistency p -> IO a) -> IO a+replayRepository r opt f = run `finally` cleanupRepositoryReplay r+    where run = do+            st <- replayRepository' r opt+            f st
+ src/Darcs/Resolution.lhs view
@@ -0,0 +1,240 @@+%  Copyright (C) 2003,2005 David Roundy+%+%  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.++\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Resolution ( standard_resolution,+                          external_resolution,+                          patchset_conflict_resolutions,+                        ) where++import System.FilePath.Posix ( (</>) )+import System.Exit ( ExitCode( ExitSuccess ) )+import System.Directory ( setCurrentDirectory, getCurrentDirectory )+import Data.List ( zip4 )+import Control.Monad ( when )++import Darcs.Patch ( RepoPatch, Prim, joinPatches, resolve_conflicts,+                     effect,+                     apply_to_filepaths, patchcontents,+                     invert, list_conflicted_files, commute )+import Darcs.RepoPath ( toFilePath )+import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (+>+),+                             mapFL_FL, reverseRL, lengthFL )++import CommandLine ( parseCmd )+import Darcs.Hopefully ( hopefully )+import Darcs.Utils ( askUser )+import Darcs.SlurpDirectory ( Slurpy, slurp, write_files )+import Darcs.Patch.Set ( PatchSet )+import Darcs.Diff ( unsafeDiff )+import Darcs.Sealed ( Sealed(..) )+import Darcs.Repository.Prefs ( filetype_function )+import Exec ( exec, Redirect(..) )+import Darcs.Lock ( withTempDir )+import Darcs.External ( cloneTree )+import Darcs.Patch.Apply ( apply_to_slurpy )++--import Darcs.ColorPrinter ( traceDoc )+--import Printer ( greenText, ($$), Doc )+--import Darcs.Patch ( showPatch )++standard_resolution :: RepoPatch p => p C(x y) -> Sealed (FL Prim C(y))+standard_resolution p = merge_list $ map head $ resolve_conflicts p++merge_list :: [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x))+merge_list patches = doml NilFL patches+    where doml :: FL Prim C(x y) -> [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x))+          doml mp (Sealed p:ps) =+              case commute (invert p :> mp) of+              Just (mp' :> _) -> doml (effect p +>+ effect mp') ps+              Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.+          doml mp [] = Sealed mp+\end{code}++\paragraph{Resolution of conflicts}\label{resolution}++To resolve conflicts using an external tool, you need to specify a command+to use, e.g.+\begin{verbatim}+--external-merge 'opendiff %1 %2 -ancestor %a -merge %o'+\end{verbatim}+The \verb!%1! and \verb!%2!  are replaced with the two versions to be+merged, \verb!%a! is replaced with the common ancestor of the two versions.+Most importantly, \verb!%o! is replaced with the name of the output file+that darcs will require to be created holding the merged version.  The+above example works with the FileMerge.app tool that comes with Apple's+developer tools.  To use xxdiff, you would use+\begin{verbatim}+--external-merge 'xxdiff -m -O -M %o %1 %a %2'+\end{verbatim}+To use \verb!kdiff3!, you can use+\begin{verbatim}+--external-merge 'kdiff3 --output %o %a %1 %2'+\end{verbatim}+To use \verb!tortoiseMerge!, you can use+\begin{verbatim}+--external-merge 'tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"'+\end{verbatim}+(\verb!tortoiseMerge! is a nice merge tool that comes with TortoiseSVN and works well+on Windows.)++% Fixme: Is it actually a shell command on MS Windows?+Note that the command is split into space-separated words and the first one is+\verb!exec!ed with the rest as arguments---it is not a shell command. In particular,+on Windows this means that the first command path should not contain spaces and+you should make sure the command is in your \verb!PATH!. ++The substitution of the \verb!%! escapes is done everywhere. If you need to prevent+substitution you can use a double percentage sign, i.e. \verb!%%a! is substituted with+\verb!%a!. Here is an example script to use the Emacs' Ediff package for merging.+% This is indented so that the leading #s don't confuse the preprocessor.+\begin{verbatim}+ #! /bin/sh+ # External merge command for darcs, using Emacs Ediff, via server if possible.+ # It needs args %1 %2 %a %o, i.e. the external merge command is, say,+ # `emerge3 %1 %2 %a %o'.+ test $# -eq 4 || exit 1+ form="(ediff-merge-files-with-ancestor"+ while test $# -gt 0; do+     count=$count.+     if [ $count = .... ]; then+         form=$form\ nil         # Lisp STARTUP-HOOKS arg+     fi+     case $1 in                  # Worry about quoting -- escape " and \+         *[\"\\]* ) form=$form\ \"$(echo $1 | sed -e's/["\\]/\\\0/g')\" ;;+         *) form=$form\ \"$1\" ;;+     esac+     shift+ done+ form=$form')'+ ( emacsclient --eval "$form" || # Emacs 22 server+   gnudoit "$form" ||            # XEmacs/Emacs 21 server+   emacs --eval "$form" ||       # Relatively slow to start up+   xemacs -eval "$form"          # Horribly slow to start up+ ) 2>/dev/null+\end{verbatim}+It would be invoked like:+\begin{verbatim}+--external-merge 'emerge3 %1 %2 %a %o'+\end{verbatim}++If you figure out how to use darcs with another merge tool, please let me+know what flags you used so I can mention it here.++Note that if you do use an external merge tool, most likely you will want+to add to your defaults file+(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults}, +on MS Windows~\ref{ms_win})+a line such as+\begin{verbatim}+ALL external-merge kdiff3 --output %o %a %1 %2+\end{verbatim}+or+\begin{verbatim}+ALL external-merge tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"+\end{verbatim}++Note that the defaults file does not want quotes around the command.++\begin{code}+external_resolution :: RepoPatch p => Slurpy -> String -> FL Prim C(x y) -> FL Prim C(x z)+                    -> p C(y a)+                    -> IO (Sealed (FL Prim C(a)))+external_resolution s1 c p1 p2 pmerged = do+ sa <- apply_to_slurpy (invert p1) s1+ sm <- apply_to_slurpy pmerged s1+ s2 <- apply_to_slurpy p2 sa+ let nms = list_conflicted_files pmerged+     nas = apply_to_filepaths (invert pmerged) nms+     n1s = apply_to_filepaths p1 nas+     n2s = apply_to_filepaths p2 nas+     ns = zip4 nas n1s n2s nms+  in do+   former_dir <- getCurrentDirectory+   withTempDir "version1" $ \absd1 -> do+     let d1 = toFilePath absd1+     write_files s1 n1s+     setCurrentDirectory former_dir+     withTempDir "ancestor" $ \absda -> do+       let da = toFilePath absda+       write_files sa nas+       setCurrentDirectory former_dir+       withTempDir "merged" $ \absdm -> do+         let dm = toFilePath absdm+         write_files sm nms+         setCurrentDirectory former_dir+         withTempDir "cleanmerged" $ \absdc -> do+           let dc = toFilePath absdc+           cloneTree dm "."+           setCurrentDirectory former_dir+           withTempDir "version2" $ \absd2 -> do+             let d2 = toFilePath absd2+             write_files s2 n2s+             mapM_ (externally_resolve_file c da d1 d2 dm) ns+             sc <- slurp dc+             sfixed <- slurp dm+             ftf <- filetype_function+             case unsafeDiff [] ftf sc sfixed of+               di -> lengthFL di `seq` return (Sealed di)+               -- The `seq` above forces the two slurpies to be read before+               -- we delete their directories.++externally_resolve_file :: String -> String -> String -> String -> String+                        -> (FilePath, FilePath, FilePath, FilePath)+                        -> IO ()+externally_resolve_file c da d1 d2 dm (fa, f1, f2, fm) = do+    putStrLn $ "Merging file "++fm++" by hand."+    ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]+    when (ec /= ExitSuccess) $+         putStrLn $ "External merge command exited with " ++ show ec+    askUser "Hit return to move on, ^C to abort the whole operation..."+    return ()++run :: String -> [(Char,String)] -> IO ExitCode+run c replacements =+    case parseCmd replacements c of+    Left err     -> fail $ show err+    Right (c2,_) -> rr c2+    where rr (command:args) = do putStrLn $ "Running command '" +++                                            unwords (command:args) ++ "'"+                                 exec command args (Null,Null,Null)+          rr [] = return ExitSuccess++patchset_conflict_resolutions :: RepoPatch p => PatchSet p C(x) -> Sealed (FL Prim C(x))+patchset_conflict_resolutions (NilRL:<:_) = --traceDoc (greenText "no conflicts A") $+                                            Sealed NilFL+patchset_conflict_resolutions NilRL = --traceDoc (greenText "no conflicts B") $+                                      Sealed NilFL+patchset_conflict_resolutions (xs:<:_)+    = --traceDoc (greenText "looking at resolutions" $$+      --         (sh $ resolve_conflicts $ joinPatches $+      --              mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $+      merge_list $ map head $ resolve_conflicts $ joinPatches $+      mapFL_FL (patchcontents . hopefully) $ reverseRL xs+    --where sh :: [[Sealed (FL Prim)]] -> Doc+    --      sh [] = greenText "no more conflicts"+    --      sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps+    --      sh1 :: [Sealed (FL Prim)] -> Doc+    --      sh1 [] = greenText "end of unravellings"+    --      sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$+    --                          sh1 ps+\end{code}
+ src/Darcs/RunCommand.hs view
@@ -0,0 +1,185 @@+-- Copyright (C) 2002,2003,2005 David Roundy+--+-- 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.++module Darcs.RunCommand ( run_the_command ) where++import Control.Monad ( unless, when )+import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),+                              OptDescr( Option ),+                              getOpt )+import System.Exit ( ExitCode ( ExitSuccess ), exitWith )++import Darcs.Arguments ( DarcsFlag(..),+                         help,+                         option_from_darcsoption,+                         list_options )+import Darcs.ArgumentDefaults ( get_default_flags )+import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),+                        DarcsCommand,+                        command_name,+                        command_command,+                        command_prereq,+                        command_extra_arg_help,+                        command_extra_args,+                        command_argdefaults,+                        command_get_arg_possibilities,+                        command_options, command_alloptions,+                        disambiguate_commands,+                        get_command_help, get_command_mini_help,+                        get_subcommands,+                        extract_commands,+                        super_name,+                        subusage, chomp_newline )+#ifdef HAVE_HASKELL_ZLIB+import Darcs.Commands.GZCRCs ( doCRCWarnings )+import Darcs.Global ( atexit )+#endif+import Darcs.Commands.Help ( command_control_list )+import Darcs.External ( viewDoc )+import Darcs.Global ( setDebugMode, setSshControlMasterDisabled,+                      setTimingsMode, setVerboseMode )+import Darcs.Match ( checkMatchSyntax )+import Progress ( setProgressMode )+import Darcs.RepoPath ( getCurrentDirectory )+import Darcs.Test ( run_posthook, run_prehook )+import Darcs.Utils ( formatPath )+import Printer ( text )+import URL ( setDebugHTTP, setHTTPPipelining )++run_the_command :: String -> [String] -> IO ()+run_the_command cmd args =+  either fail rtc $ disambiguate_commands command_control_list cmd args+ where+  rtc (CommandOnly c, as)       = run_command Nothing c  as+  rtc (SuperCommandOnly c,  as) = run_raw_supercommand c as+  rtc (SuperCommandSub c s, as) = run_command (Just c) s as++-- This is the actual heavy lifter code, which is responsible for parsing the+-- arguments and then running the command itself.++run_command :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()++run_command _ _ args -- Check for "dangerous" typoes...+    | "-all" `elem` args = -- -all indicates --all --look-for-adds!+        fail $ "Are you sure you didn't mean -" ++ "-all rather than -all?"+run_command msuper cmd args = do+   cwd <- getCurrentDirectory+   let options = opts1 ++ opts2+       (opts1, opts2) = command_options cwd cmd+   case getOpt Permute+             (option_from_darcsoption cwd list_options++options) args of+    (opts,extra,[])+      | Help `elem` opts -> viewDoc $ text $ get_command_help msuper cmd+      | ListOptions `elem` opts  -> do+           setProgressMode False+           command_prereq cmd opts+           file_args <- command_get_arg_possibilities cmd+           putStrLn $ get_options_options (opts1++opts2) ++ unlines file_args+      | otherwise -> consider_running msuper cmd (addVerboseIfDebug opts) extra+    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)+    where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts+                                 | otherwise = opts++consider_running :: Maybe DarcsCommand -> DarcsCommand+                 -> [DarcsFlag] -> [String] -> IO ()+consider_running msuper cmd opts old_extra = do+ cwd <- getCurrentDirectory+ location <- command_prereq cmd opts+ case location of+   Left complaint -> fail $ "Unable to " +++                     formatPath ("darcs " ++ super_name msuper ++ command_name cmd) +++                     " here.\n\n" ++ complaint+   Right () -> do+    specops <- add_command_defaults cmd opts+    extra <- (command_argdefaults cmd) specops cwd old_extra+    when (Disable `elem` specops) $+      fail $ "Command "++command_name cmd++" disabled with --disable option!"+    if command_extra_args cmd < 0+      then runWithHooks specops extra+      else if length extra > command_extra_args cmd+           then fail $ "Bad argument: `"++unwords extra++"'\n"+++                       get_command_mini_help msuper cmd+           else if length extra < command_extra_args cmd+                then fail $ "Missing argument:  " +++                            nth_arg (length extra + 1) +++                            "\n" ++ get_command_mini_help msuper cmd+                else runWithHooks specops extra+       where nth_arg n = nth_of n (command_extra_arg_help cmd)+             nth_of 1 (h:_) = h+             nth_of n (_:hs) = nth_of (n-1) hs+             nth_of _ [] = "UNDOCUMENTED"+             runWithHooks os ex = do+               here <- getCurrentDirectory+               checkMatchSyntax os+               -- set any global variables+               when (Timings `elem` os) setTimingsMode+               when (Debug `elem` os) setDebugMode+               when (DebugHTTP `elem` os) setDebugHTTP+               when (Verbose `elem` os) setVerboseMode+               when (Quiet `elem` os) $ setProgressMode False+               when (HTTPPipelining `elem` os) $ setHTTPPipelining True+               when (NoHTTPPipelining `elem` os) $ setHTTPPipelining False+               unless (SSHControlMaster `elem` os) setSshControlMasterDisabled+#ifdef HAVE_HASKELL_ZLIB+               unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os)+#endif+               -- actually run the command and its hooks+               preHookExitCode <- run_prehook os here+               if preHookExitCode /= ExitSuccess+                  then exitWith preHookExitCode+                  else do let fixFlag = FixFilePath here cwd+                          (command_command cmd) (fixFlag : os) ex+                          postHookExitCode <- run_posthook os here+                          exitWith postHookExitCode++add_command_defaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]+add_command_defaults cmd already = do+  let (opts1, opts2) = command_alloptions cmd+  defaults <- get_default_flags (command_name cmd) (opts1 ++ opts2) already+  return $ already ++ defaults++get_options_options :: [OptDescr DarcsFlag] -> String+get_options_options [] = ""+get_options_options (o:os) =+    get_long_option o ++"\n"++ get_options_options os++get_long_option :: OptDescr DarcsFlag -> String+get_long_option (Option _ [] _ _) = ""+get_long_option (Option a (o:os) b c) = "--"++o+++                 get_long_option (Option a os b c)++run_raw_supercommand :: DarcsCommand -> [String] -> IO ()+run_raw_supercommand super [] =+    fail $ "Command '"++ command_name super ++"' requires subcommand!\n\n"+             ++ subusage super+run_raw_supercommand super args = do+  cwd <- getCurrentDirectory+  case getOpt RequireOrder+             (option_from_darcsoption cwd help+++              option_from_darcsoption cwd list_options) args of+    (opts,_,[])+      | Help `elem` opts ->+            viewDoc $ text $ get_command_help Nothing super+      | ListOptions `elem` opts -> do+            putStrLn "--help"+            mapM_ (putStrLn . command_name) (extract_commands $ get_subcommands super)+      | otherwise ->+            if Disable `elem` opts+            then fail $ "Command " ++ (command_name super) +++                      " disabled with --disable option!"+            else fail $ "Invalid subcommand!\n\n" ++ subusage super+    (_,_,ermsgs) -> do fail $ chomp_newline(unlines ermsgs)
+ src/Darcs/Sealed.hs view
@@ -0,0 +1,103 @@+-- Copyright (C) 2007 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , MagicHash, GADTs #-}++#include "gadts.h"++module Darcs.Sealed ( Sealed(..), seal, unseal, mapSeal,+#ifndef GADT_WITNESSES+                      unsafeUnseal, unsafeUnflippedseal, unsafeUnseal2,+#endif+                      Sealed2(..), seal2, unseal2, mapSeal2,+                      FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped,+                      unsealM, liftSM+                    ) where++import GHC.Base ( unsafeCoerce# )+import Darcs.Show++data Sealed a where+    Sealed :: a C(x ) -> Sealed a++seal :: a C(x ) -> Sealed a+seal = Sealed++data Sealed2 a where+    Sealed2 :: !(a C(x y )) -> Sealed2 a++seal2 :: a C(x y ) -> Sealed2 a+seal2 = Sealed2++data FlippedSeal a C(y) where+    FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y)++flipSeal :: a C(x y) -> FlippedSeal a C(y)+flipSeal = FlippedSeal++#ifndef GADT_WITNESSES+unsafeUnseal :: Sealed a -> a+unsafeUnseal (Sealed a) = a++unsafeUnflippedseal :: FlippedSeal a -> a+unsafeUnflippedseal (FlippedSeal a) = a++unsafeUnseal2 :: Sealed2 a -> a+unsafeUnseal2 (Sealed2 a) = a+#endif++seriouslyUnsafeUnseal :: Sealed a -> a C(())+seriouslyUnsafeUnseal (Sealed a) = unsafeCoerce# a++unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b+unseal f x = f (seriouslyUnsafeUnseal x)++-- laziness property:+-- unseal (const True) undefined == True++unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b+unsealM m1 m2 = do sx <- m1+                   unseal m2 sx++liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b+liftSM f m = do sx <- m+                return (unseal f sx)++mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b+mapSeal f = unseal (seal . f)++mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z)+mapFlipped f (FlippedSeal x) = FlippedSeal (f x)++seriouslyUnsafeUnseal2 :: Sealed2 a -> a C(() ())+seriouslyUnsafeUnseal2 (Sealed2 a) = unsafeCoerce# a++unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b+unseal2 f a = f (seriouslyUnsafeUnseal2 a)++mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b+mapSeal2 f = unseal2 (seal2 . f)++unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b+unsealFlipped f (FlippedSeal a) = f a++instance Show1 a => Show (Sealed a) where+    showsPrec d (Sealed x) = showParen (d > app_prec) $ showString "Sealed " . showsPrec1 (app_prec + 1) x+instance Show2 a => Show (Sealed2 a) where+    showsPrec d (Sealed2 x) = showParen (d > app_prec) $ showString "Sealed2 " . showsPrec2 (app_prec + 1) x
+ src/Darcs/SelectChanges.hs view
@@ -0,0 +1,620 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-- , ScopedTypeVariables, TypeOperators, PatternGuards #-}++#include "gadts.h"++module Darcs.SelectChanges ( with_selected_changes',+                             with_selected_changes_to_files',+                             with_selected_last_changes_to_files',+                             with_selected_last_changes_reversed',+                       with_selected_changes,+                       with_selected_changes_to_files,+                       with_selected_changes_reversed,+                       with_selected_last_changes_to_files,+                       with_selected_last_changes_to_files_reversed,+                       with_selected_last_changes_reversed,+                       view_changes,+                       with_selected_patch_from_repo,+                     ) where+import System.IO+import Data.List ( intersperse )+import Data.Maybe ( catMaybes, isJust )+import Data.Char ( toUpper )+import Control.Monad ( when )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )++import English ( Noun(..), englishNum  )+import Darcs.Arguments ( showFriendly )+import Darcs.Hopefully ( PatchInfoAnd, hopefully )+import Darcs.Repository ( Repository, read_repo )+import Darcs.Patch ( RepoPatch, Patchy, Prim, summary,+                     invert, list_touched_files,+                     commuteFL )+import qualified Darcs.Patch ( thing, things )+import Darcs.Ordered ( FL(..), RL(..), (:>)(..),+                       (+>+), lengthFL, lengthRL, concatRL, mapFL_FL,+                       spanFL, reverseFL, (+<+), mapFL,+                       unsafeCoerceP )+import Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,+                             force_first, force_last, make_uncertain, tag,+                      get_choices,+                      separate_first_middle_from_last,+                      separate_first_from_middle_last,+                      patch_slot,+                      select_all_middles,+                      force_matching_last,+                      force_matching_first, make_everything_later,+                             TaggedPatch, tp_patch, Slot(..),+                    )+import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching )+import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager )+import Darcs.Match ( have_nonrange_match, match_a_patch, match_a_patchread )+import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies), isInteractive )+import Darcs.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2 )+import Darcs.Utils ( askUser, promptCharFancy )+import Printer ( prefix, putDocLn )+#include "impossible.h"++data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)++type MatchCriterion p = FORALL(u v) WhichChanges -> [DarcsFlag] -> (p C(u v)) -> Bool++type WithPatches p a C(x y) =+        String              -- jobname+     -> [DarcsFlag]         -- opts+     -> FL p C(x y)         -- patches to select among+     -> ((FL p :> FL p) C(x y) -> IO a) -- job+     -> IO a                -- result of running job++-- | The only difference with 'WithPatches' is the [FilePath] argument+type WithPatchesToFiles p a C(x y) =+        String              -- jobname+     -> [DarcsFlag]         -- opts+     -> [FilePath]          -- files+     -> FL p C(x y)         -- patches to select among+     -> ((FL p :> FL p) C(x y) -> IO a) -- job+     -> IO a                -- result of running job++with_selected_changes'+  :: WithPatches Prim a C(x y)+with_selected_changes_to_files'+  :: WithPatchesToFiles Prim a C(x y)+with_selected_last_changes_to_files'+  :: WithPatchesToFiles Prim a C(x y)+with_selected_last_changes_reversed'+  :: WithPatches Prim a C(x y)++-- Common match criteria+triv :: MatchCriterion p+triv _ _ _ = True++iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p)+iswanted First opts p = match_a_patch opts . hopefully $ p+iswanted LastReversed opts p = match_a_patch opts . hopefully . invert $ p+iswanted Last _ _ = bug "don't support patch matching with Last in wasp"+iswanted FirstReversed _ _ = bug "don't support patch matching with FirstReversed in wasp"++with_selected_changes'               = wasc  First triv+with_selected_changes_to_files'      = wasc_ First triv+with_selected_last_changes_to_files' = wasc_ Last triv+with_selected_last_changes_reversed' = wasc  LastReversed triv++with_selected_changes               :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y)+with_selected_changes_to_files      :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y)+with_selected_changes_reversed      :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y)+with_selected_last_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y)+with_selected_last_changes_to_files_reversed :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a C(x y)+with_selected_last_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a C(x y)++with_selected_changes               = wasc  First iswanted+with_selected_changes_to_files      = wasc_ First iswanted+with_selected_changes_reversed      = wasc  FirstReversed iswanted+with_selected_last_changes_to_files = wasc_ Last iswanted+with_selected_last_changes_to_files_reversed = wasc_ LastReversed iswanted+with_selected_last_changes_reversed = wasc LastReversed iswanted++-- | wasc and wasc_ are just shorthand for with_any_selected_changes+wasc  :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatches p a C(x y)+wasc mwch crit j o = wasc_ mwch crit j o []+wasc_ :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y)+wasc_ = with_any_selected_changes++with_any_selected_changes :: Patchy p => WhichChanges -> MatchCriterion p -> WithPatchesToFiles p a C(x y)+with_any_selected_changes Last crit jn opts fs =+    with_any_selected_changes_last+        (patches_to_consider_last' fs opts crit)+        crit jn opts fs+with_any_selected_changes First crit jn opts fs =+    with_any_selected_changes_first+       (patches_to_consider_first' fs opts crit)+       crit jn opts fs+with_any_selected_changes FirstReversed crit jn opts fs =+    with_any_selected_changes_first_reversed+       (patches_to_consider_first_reversed' fs opts crit)+       crit jn opts fs+with_any_selected_changes LastReversed crit jn opts fs =+    with_any_selected_changes_last_reversed+        (patches_to_consider_last_reversed' fs opts crit)+        crit jn opts fs+++view_changes :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()+view_changes opts ps = do+  text_view opts Nothing 0 NilRL init_tps init_pc+  return ()+    where (init_pc, init_tps) = patch_choices_tps ps++data KeyPress a = KeyPress { kp     :: Char+                           , kpHelp :: String }++helpFor :: String -> [[KeyPress a]] -> String+helpFor jobname options =+  unlines $ [ "How to use "++jobname++":" ]+            ++ (concat $ intersperse [""] $ map (map help) options)+            ++ [ ""+               , "?: show this help"+               , ""+               , "<Space>: accept the current default (which is capitalized)"+               ]+  where help i = kp i:(": "++kpHelp i)++keysFor :: [[KeyPress a]] -> [Char]+keysFor = concatMap (map kp)++with_selected_patch_from_repo :: forall p C(r u t). RepoPatch p => String -> Repository p C(r u t) -> [DarcsFlag]+                              -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO ()+with_selected_patch_from_repo jn repository opts job = do+    p_s <- read_repo repository+    sp <- wspfr jn (match_a_patchread opts)+                              (concatRL p_s) NilFL+    case sp of+     Just (FlippedSeal (skipped :> selected)) -> job (skipped :> selected)+     Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected."++-- | This ensures that the selected patch commutes freely with the skipped patches, including pending+-- and also that the skipped sequences has an ending context that matches the recorded state, z,+-- of the repository.+wspfr :: RepoPatch p => String -> (FORALL(a b) (PatchInfoAnd p) C(a b) -> Bool)+      -> RL (PatchInfoAnd p) C(x y) -> FL (PatchInfoAnd p) C(y u)+      -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> (PatchInfoAnd p)) C(u)))+wspfr _ _ NilRL _ = return Nothing+wspfr jn matches (p:<:pps) skipped+    | not $ matches p = wspfr jn matches pps (p:>:skipped)+    | otherwise =+    case commuteFL (p :> skipped) of+    Left _  -> do putStrLn "\nSkipping depended-upon patch:"+                  printFriendly [] p+                  wspfr jn matches pps (p:>:skipped)+    Right (skipped' :> p') -> do+      printFriendly [] p+      let repeat_this  = wspfr jn matches (p:<:pps) skipped+          options = [[ KeyPress 'y' (jn++" this patch")+                     , KeyPress 'n' ("don't "++jn++" it")+                     , KeyPress 'v' "view this patch in full"+                     , KeyPress 'p' "view this patch in full with pager"+                     , KeyPress 'x' "view a summary of this patch"+                     , KeyPress 'q' ("cancel "++jn)+                    ]]+      let prompt  = "Shall I "++jn++" this patch?"+      yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h"+      case yorn of+        'y' -> return $ Just $ flipSeal $ skipped' :> p'+        'n' -> wspfr jn matches pps (p:>:skipped)+        'v' -> printPatch p >> repeat_this+        'p' -> printPatchPager p >> repeat_this+        'x' -> do putDocLn $ prefix "    " $ summary p+                  repeat_this+        'q' -> do putStrLn $ jn_cap++" cancelled."+                  exitWith $ ExitSuccess+        _   -> do putStrLn $ helpFor jn options+                  repeat_this+  where jn_cap = (toUpper $ head jn) : tail jn++with_any_selected_changes_last :: forall p a C(x y). Patchy p+                               => (FL p C(x y) -> (FL p :> FL p) C(x y))+                               -> MatchCriterion p+                               -> WithPatchesToFiles p a C(x y)+with_any_selected_changes_last p2c crit jobname opts _ ps job =+ case p2c ps of+ ps_to_consider :> other_ps ->+         if not $ isInteractive opts+         then job $ ps_to_consider :> other_ps+         else do pc <- tentatively_text_select "" jobname (Noun "patch") Last crit+                                              opts ps_len 0 NilRL init_tps init_pc+                 job $ selected_patches_last rejected_ps pc+         where rejected_ps = ps_to_consider+               ps_len = lengthFL init_tps+               (init_pc, init_tps) = patch_choices_tps $ other_ps++with_any_selected_changes_first :: forall p a C(x y). Patchy p+                                => (FL p C(x y) -> (FL p :> FL p) C(x y))+                                -> MatchCriterion p+                                -> WithPatchesToFiles p a C(x y)+with_any_selected_changes_first p2c crit jobname opts _ ps job =+ case p2c ps of+ ps_to_consider :> other_ps ->+         if not $ isInteractive opts+         then job $ ps_to_consider :> other_ps+         else do pc <- tentatively_text_select "" jobname (Noun "patch") First crit+                                              opts ps_len 0 NilRL init_tps init_pc+                 job $ selected_patches_first rejected_ps pc+         where rejected_ps = other_ps+               ps_len = lengthFL init_tps+               (init_pc, init_tps) = patch_choices_tps $ ps_to_consider++with_any_selected_changes_first_reversed :: forall p a C(x y). Patchy p+                                => (FL p C(x y) -> (FL p :> FL p) C(y x))+                                -> MatchCriterion p+                                -> WithPatchesToFiles p a C(x y)+with_any_selected_changes_first_reversed p2c crit jobname opts _ ps job =+ case p2c ps of+ ps_to_consider :> other_ps ->+         if not $ isInteractive opts+         then job $ invert other_ps :> invert ps_to_consider+         else do pc <- tentatively_text_select "" jobname (Noun "patch") FirstReversed crit+                                             opts ps_len 0 NilRL init_tps init_pc+                 job $ selected_patches_first_reversed rejected_ps pc+         where rejected_ps = ps_to_consider+               ps_len = lengthFL init_tps+               (init_pc, init_tps) = patch_choices_tps other_ps++with_any_selected_changes_last_reversed :: forall p a C(x y). Patchy p+                                => (FL p C(x y) -> (FL p :> FL p) C(y x))+                                -> MatchCriterion p+                                -> WithPatchesToFiles p a C(x y)+with_any_selected_changes_last_reversed p2c crit jobname opts _ ps job =+ case p2c ps of+ ps_to_consider :> other_ps ->+         if not $ isInteractive opts+         then job $ invert other_ps :> invert ps_to_consider+         else do pc <- tentatively_text_select "" jobname (Noun "patch") LastReversed crit+                                             opts ps_len 0 NilRL init_tps init_pc+                 job $ selected_patches_last_reversed rejected_ps pc+         where rejected_ps = other_ps+               ps_len = lengthFL init_tps+               (init_pc, init_tps) = patch_choices_tps ps_to_consider+++patches_to_consider_first' :: Patchy p+                     => [FilePath]  -- ^ files+                     -> [DarcsFlag] -- ^ opts+                     -> MatchCriterion  p+                     -> FL p C(x y) -- ^ patches+                     -> (FL p :> FL p) C(x y)+patches_to_consider_first' fs opts crit ps =+  let deselect_unwanted pc =+        if have_nonrange_match opts+        then if DontGrabDeps `elem` opts+                  then force_matching_last (not.iswanted_) pc+                  else make_everything_later $ force_matching_first iswanted_ pc+        else pc+      iswanted_ = crit First opts . tp_patch+  in if null fs && not (have_nonrange_match opts)+     then ps :> NilFL+     else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs+                     $ deselect_unwanted $ patch_choices ps++patches_to_consider_last' :: Patchy p+                     => [FilePath]  -- ^ files+                     -> [DarcsFlag] -- ^ opts+                     -> MatchCriterion p+                     -> FL p C(x y) -- ^ patches+                     -> (FL p :> FL p) C(x y)+patches_to_consider_last' fs opts crit ps =+  let deselect_unwanted pc =+        if have_nonrange_match opts+        then if DontGrabDeps `elem` opts+                  then force_matching_last (not.iswanted_) pc+                  else make_everything_later $ force_matching_first iswanted_ pc+        else pc+      iswanted_ = crit Last opts . tp_patch+  in if null fs && not (have_nonrange_match opts)+     then NilFL :> ps+     else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices ps of+           fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc++patches_to_consider_first_reversed' :: Patchy p+                     => [FilePath]  -- ^ files+                     -> [DarcsFlag] -- ^ opts+                     -> MatchCriterion p+                     -> FL p C(x y) -- ^ patches+                     -> (FL p :> FL p) C(y x)+patches_to_consider_first_reversed' fs opts crit ps =+  let deselect_unwanted pc =+        if have_nonrange_match opts+        then if DontGrabDeps `elem` opts+                  then force_matching_last (not.iswanted_) pc+                  else make_everything_later $ force_matching_first iswanted_ pc+        else pc+      iswanted_ = crit FirstReversed opts . tp_patch+  in if null fs && not (have_nonrange_match opts)+     then NilFL :> (invert ps)+     else case get_choices $ select_not_touching fs $ deselect_unwanted $ patch_choices $ invert ps of+           fc :> mc :> lc -> tp_patches $ fc :> mc +>+ lc++patches_to_consider_last_reversed' :: Patchy p+                     => [FilePath]  -- ^ files+                     -> [DarcsFlag] -- ^ opts+                     -> MatchCriterion p+                     -> FL  p C(x y) -- ^ patches+                     -> (FL p :> FL p) C(y x)+patches_to_consider_last_reversed' fs opts crit ps =+  let deselect_unwanted pc =+        if have_nonrange_match opts+        then if DontGrabDeps `elem` opts+             then force_matching_last (not.iswanted_) pc+             else make_everything_later $ force_matching_first iswanted_ pc+        else pc+      iswanted_ = crit LastReversed opts . tp_patch+  in+    if null fs && not (have_nonrange_match opts)+    then (invert ps) :> NilFL+    else tp_patches $ separate_first_middle_from_last $ deselect_not_touching fs+                     $ deselect_unwanted $ patch_choices $ invert ps++-- | Returns the results of a patch selection user interaction+selected_patches_last :: Patchy p => FL p C(x y) -> PatchChoices p C(y z)+                      -> (FL p :> FL p) C(x z)+selected_patches_last other_ps pc =+  case get_choices pc of+   fc :> mc :> lc -> other_ps +>+ mapFL_FL tp_patch (fc +>+ mc) :> mapFL_FL tp_patch lc++selected_patches_first :: Patchy p => FL p C(y z) -> PatchChoices p C(x y)+                       -> (FL p :> FL p) C(x z)+selected_patches_first other_ps pc =+  case separate_first_from_middle_last pc of+  xs :> ys -> mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys +>+ other_ps++selected_patches_last_reversed :: Patchy p => FL p C(y x) -> PatchChoices p C(z y)+                               -> (FL p :> FL p) C(x z)+selected_patches_last_reversed other_ps pc =+  case separate_first_from_middle_last pc of+  xs :> ys -> invert (mapFL_FL tp_patch ys +>+ other_ps) :> invert (mapFL_FL tp_patch xs)++selected_patches_first_reversed :: Patchy p => FL p C(z y) -> PatchChoices p C(y x)+                                -> (FL p :> FL p) C(x z)+selected_patches_first_reversed other_ps pc =+  case get_choices pc of+  fc :> mc :> lc -> invert (mapFL_FL tp_patch lc) :> invert (other_ps +>+ mapFL_FL tp_patch (fc +>+ mc))++text_select :: forall p C(x y z). Patchy p => String -> WhichChanges+            ->  MatchCriterion p -> [DarcsFlag] -> Int -> Int+            -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z) -> PatchChoices p C(x z)+            -> IO ((PatchChoices p) C(x z))++text_select _ _ _ _ _ _ _ NilFL pc = return pc+text_select jn whichch crit opts n_max n+            tps_done tps_todo@(tp:>:tps_todo') pc = do+      (printFriendly opts) `unseal2` viewp+      repeat_this -- prompt the user+    where+        do_next_action ja je = tentatively_text_select ja jn je whichch crit opts+                                          n_max+                                          (n+1) (tp:<:tps_done) tps_todo'+        do_next = do_next_action "" (Noun "patch")+        helper :: PatchChoices p C(a b) -> p C(a b)+        helper = undefined+        thing  = Darcs.Patch.thing (helper pc)+        things = Darcs.Patch.things (helper pc)+        options_basic =+           [ KeyPress 'y' (jn++" this "++thing)+           , KeyPress 'n' ("don't "++jn++" it")+           , KeyPress 'w' ("wait and decide later, defaulting to no") ]+        options_file =+           [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")+           , KeyPress 'f' (jn++" the rest of the changes to this file") ]+        options_view =+           [ KeyPress 'v' ("view this "++thing++" in full")+           , KeyPress 'p' ("view this "++thing++" in full with pager")+           , KeyPress 'l' ("list all selected "++things) ]+        options_summary =+           [ KeyPress 'x' ("view a summary of this "++thing) ]+        options_quit =+           [ KeyPress 'd' (jn++" selected "++things++", skipping all the remaining "++things)+           , KeyPress 'a' (jn++" all the remaining "++things)+           , KeyPress 'q' ("cancel "++jn) ]+        options_nav =+           [ KeyPress 'j' ("skip to next "++thing)+           , KeyPress 'k' ("back up to previous "++thing) ]+        options = [options_basic]+                  ++ (if is_single_file_patch then [options_file] else [])+                  ++ [options_view +++                      if Summary `elem` opts then [] else options_summary]+                  ++ [options_quit]+                  ++ [options_nav ]+        prompt = "Shall I "++jn++" this "++thing++"? "+               ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "+        repeat_this :: IO ((PatchChoices p) C(x z))+        repeat_this = do+          yorn <- promptCharFancy prompt (keysFor options) (Just the_default) "?h"+          case yorn of+            'y' -> do_next $ force_yes (tag tp) pc+            'n' -> do_next $ force_no (tag tp) pc+            'w' -> do_next $ make_uncertain (tag tp) pc+            's' -> do_next_action "Skipped"  (Noun "change") $ skip_file+            'f' -> do_next_action "Included" (Noun "change") $ do_file+            'v' -> printPatch `unseal2` viewp >> repeat_this+            'p' -> printPatchPager `unseal2` viewp >> repeat_this+            'l' -> do let selected = case get_choices pc of+                                          (first_chs:>_:>last_chs) ->+                                             if whichch == Last || whichch == FirstReversed+                                                then map_patches last_chs+                                                else map_patches first_chs+                          map_patches = mapFL (\a ->+                                           (showFriendly opts) `unseal2` (seal2 $ tp_patch a))+                      putStrLn $ "---- Already selected "++things++" ----"+                      mapM_ putDocLn $ selected+                      putStrLn $ "---- end of already selected "++things++" ----"+                      (printFriendly opts) `unseal2` viewp+                      repeat_this+            'x' -> do (putDocLn . prefix "    " . summary) `unseal2` viewp+                      repeat_this+            'd' -> return pc+            'a' -> do ask_confirmation+                      return $ select_all_middles (whichch == Last || whichch == FirstReversed) pc+            'q' -> do putStrLn $ jn_cap++" cancelled."+                      exitWith $ ExitSuccess+            'j' -> case tps_todo' of+                       NilFL -> -- May as well work out the length now we have all+                                -- the patches in memory+                                text_select jn whichch crit opts+                                    n_max n tps_done tps_todo pc+                       _ -> text_select jn whichch crit opts+                                n_max (n+1) (tp:<:tps_done) tps_todo' pc+            'k' -> case tps_done of+                        NilRL -> repeat_this+                        (tp':<:tps_done') ->+                           text_select jn whichch crit opts+                               n_max (n-1) tps_done' (tp':>:tps_todo) pc+            'c' -> text_select jn whichch crit opts+                                        n_max n tps_done tps_todo pc+            _   -> do putStrLn $ helpFor jn options+                      repeat_this+        force_yes = if whichch == Last || whichch == FirstReversed then force_last else force_first+        force_no  = if whichch == Last || whichch == FirstReversed then force_first else force_last+        patches_to_skip = (tag tp:) $ catMaybes+                        $ mapFL (\tp' -> if list_touched_files tp' == touched_files+                                         then Just (tag tp')+                                         else Nothing) tps_todo'+        skip_file = foldr force_no pc patches_to_skip+        do_file = foldr force_yes pc patches_to_skip+        the_default = get_default (whichch == Last || whichch == FirstReversed) $ patch_slot tp pc+        jn_cap = (toUpper $ head jn) : tail jn+        touched_files = list_touched_files $ tp_patch tp+        is_single_file_patch = length touched_files == 1+        viewp = if whichch == LastReversed || whichch == FirstReversed then seal2 $ invert (tp_patch tp) else seal2 $ tp_patch tp+        ask_confirmation =+            if jn `elem` ["unpull", "unrecord", "obliterate"]+            then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "+                    case yorn of+                     ('y':_) -> return ()+                     _ -> exitWith $ ExitSuccess+            else return ()++text_view :: forall p C(x y u r s). Patchy p => [DarcsFlag] -> Maybe Int -> Int+            -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y u) -> PatchChoices p C(r s)+            -> IO ((PatchChoices p) C(r s))+text_view _ _ _ _ NilFL _ = return $ patch_choices $ unsafeCoerceP NilFL --return pc+text_view opts n_max n+            tps_done tps_todo@(tp:>:tps_todo') pc = do+      printFriendly opts (tp_patch tp)+      putStr "\n"+      repeat_this -- prompt the user+    where+        prev_patch :: IO ((PatchChoices p) C(r s))+        prev_patch = case tps_done of+                       NilRL -> repeat_this+                       (tp':<:tps_done') ->+                         text_view opts+                            n_max (n-1) tps_done' (tp':>:tps_todo) pc+        next_patch :: IO ((PatchChoices p) C(r s))+        next_patch = case tps_todo' of+                         NilFL -> -- May as well work out the length now we have all+                                  -- the patches in memory+                               text_view opts n_max+                                   n tps_done NilFL pc+                         _ -> text_view opts n_max+                                  (n+1) (tp:<:tps_done) tps_todo' pc+        options_yn =+          [ KeyPress 'y' "view this patch and go to the next"+          , KeyPress 'n' "skip to the next patch" ]+        options_view =+          [ KeyPress 'v' "view this patch in full"+          , KeyPress 'p' "view this patch in full with pager" ]+        options_summary =+          [ KeyPress 'x' "view a summary of this patch" ]+        options_nav =+          [ KeyPress 'q' ("quit view changes")+          , KeyPress 'k' "back up to previous patch"+          , KeyPress 'j' "skip to next patch"+          , KeyPress 'c' "count total patch number" ]+        options = [ options_yn ]+                  ++ [ options_view +++                       if Summary `elem` opts then [] else options_summary ]+                  ++ [ options_nav ]+        prompt = "Shall I view this patch? "+               ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"+        repeat_this :: IO ((PatchChoices p) C(r s))+        repeat_this = do+          yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h"+          case yorn of+            'y' -> printPatch (tp_patch tp) >> next_patch+            'n' -> next_patch+            'v' -> printPatch (tp_patch tp) >> repeat_this+            'p' -> printPatchPager (tp_patch tp) >> repeat_this+            'x' -> do putDocLn $ prefix "    " $ summary (tp_patch tp)+                      repeat_this+            'q' -> exitWith ExitSuccess+            'k' -> prev_patch+            'j' -> next_patch+            'c' -> text_view opts+                       count_n_max n tps_done tps_todo pc+            _   -> do putStrLn $ helpFor "view changes" options+                      repeat_this+        count_n_max | isJust n_max = n_max+                    | otherwise    = Just $ lengthFL tps_todo + lengthRL tps_done+tentatively_text_select :: Patchy p => String -> String -> Noun -> WhichChanges+                        -> MatchCriterion p -> [DarcsFlag]+                        -> Int -> Int -> RL (TaggedPatch p) C(x y) -> FL (TaggedPatch p) C(y z)+                        -> PatchChoices p C(x z)+                        -> IO ((PatchChoices p) C(x z))+tentatively_text_select _ _ _ _ _ _ _ _ _ NilFL pc = return pc+tentatively_text_select jobaction jobname jobelement whichch crit+                        opts n_max n ps_done ps_todo pc =+  case spanFL (\p -> decided $ patch_slot p pc) ps_todo of+  skipped :> unskipped -> do+   when (numSkipped > 0) show_skipped+   let (boringThenInteresting) =+                          if DontPromptForDependencies `elem` opts+                          then spanFL (not.(crit whichch opts).tp_patch) unskipped+                          else NilFL :> unskipped+   case boringThenInteresting of+     boring :> interesting -> do+     let numNotConsidered = lengthFL boring + numSkipped+     text_select jobname whichch crit opts n_max (n + numNotConsidered)+                 (reverseFL boring +<+ reverseFL skipped +<+ ps_done) interesting pc+   where+   numSkipped  = lengthFL skipped+   show_skipped = do putStrLn $ _doing_ ++ _with_ ++ "."+                     when (Verbose `elem` opts) $ showskippedpatch skipped+    where+      _doing_  = _action_ ++ " " ++ jobname+      _with_   = " of " ++ show numSkipped ++ " " ++ _elem_ ""+      _action_ = if (length jobaction) == 0 then "Skipped" else jobaction+      _elem_ = englishNum numSkipped jobelement+      showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO ()+      showskippedpatch (tp:>:tps) = (putDocLn $ prefix "    " $ summary (tp_patch tp)) >> showskippedpatch tps+      showskippedpatch NilFL = return ()++decided :: Slot -> Bool+decided InMiddle = False+decided _ = True++get_default :: Bool -> Slot -> Char+get_default _ InMiddle = 'w'+get_default True InFirst  = 'n'+get_default True InLast   = 'y'+get_default False InFirst = 'y'+get_default False InLast  = 'n'++tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)+           -> (FL p :> FL p) C(x y)+tp_patches (x:>y) = mapFL_FL tp_patch x :> mapFL_FL tp_patch y
+ src/Darcs/Show.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++module Darcs.Show(Show1(..), Show2(..), showOp2, app_prec) where++#include "gadts.h"++class Show1 a where+    show1 :: a C(x) -> String+    show1 x = showsPrec1 0 x ""+    showsPrec1 :: Int -> a C(x) -> ShowS+    showsPrec1 _ x s = show1 x ++ s++class Show2 a where+    show2 :: a C(x y) -> String+    show2 x = showsPrec2 0 x ""+    showsPrec2 :: Int -> a C(x y) -> ShowS+    showsPrec2 _ x s = show2 x ++ s++showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String+showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                          showString opstr . showsPrec2 (prec + 1) y++app_prec :: Int+app_prec = 10
+ src/Darcs/SignalHandler.hs view
@@ -0,0 +1,132 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+-- , DeriveDataTypeable #-}++module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked,+                             catchInterrupt, catchNonSignal,+                             tryNonSignal, stdout_is_a_pipe ) where++import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )+import Control.Exception ( dynExceptions, ioErrors, catchJust, Exception ( IOException ) )+import System.Exit ( exitWith, ExitCode ( ExitFailure ) )+import Control.Concurrent ( ThreadId, myThreadId )+import Control.Exception ( catchDyn, throwDyn, throwDynTo, block )+import System.Posix.Files ( getFdStatus, isNamedPipe )+import System.Posix.IO ( stdOutput )+import Data.Dynamic ( Typeable, fromDynamic )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( when )++import Workaround ( installHandler, raiseSignal, Handler(..), Signal,+                    sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )+#ifdef WIN32+import CtrlC ( withCtrlCHandler )+#endif++stdout_is_a_pipe :: IO Bool+stdout_is_a_pipe+ = catchJust ioErrors+        (do stat <- getFdStatus stdOutput+            return (isNamedPipe stat))+        (\_ -> return False)++withSignalsHandled :: IO a -> IO a+newtype SignalException = SignalException Signal deriving (Typeable)++withSignalsHandled job = do+    thid <- myThreadId+    mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]+    catchJust just_usererrors (job' thid `catchSignal` defaults)+              die_with_string+    where defaults s | s == sigINT = ew s "Interrupted!"+                     | s == sigHUP = ew s "HUP"+                     | s == sigABRT = ew s "ABRT"+                     | s == sigTERM = ew s "TERM"+                     | s == sigPIPE = exitWith $ ExitFailure $ 1+                     | otherwise = ew s "Unhandled signal!"+          ew sig s = do hPutStrLn stderr $ ("withSignalsHandled: " ++ s)+                        resethandler sig+                        raiseSignal sig -- ensure that our caller knows how we died+                        exitWith $ ExitFailure $ 1+          die_with_string e | take 6 e == "STDOUT" =+                do is_pipe <- stdout_is_a_pipe+                   when (not is_pipe) $+                        hPutStrLn stderr $ "\ndarcs failed:  "++drop 6 e+                   exitWith $ ExitFailure $ 2+          die_with_string e = do hPutStrLn stderr $ "\ndarcs failed:  "++e+                                 exitWith $ ExitFailure $ 2+#ifdef WIN32+          job' thid =+             withCtrlCHandler (throwDynTo thid $ SignalException sigINT) job+#else+          job' _ = job+#endif++resethandler :: Signal -> IO ()+resethandler s = do installHandler s Default Nothing+                    return ()++ih :: ThreadId -> Signal -> IO ()+ih thid s =+  do installHandler s (Catch $ throwDynTo thid $ SignalException s) Nothing+     return ()++catchSignal :: IO a -> (Signal -> IO a) -> IO a+catchSignal job handler =+    job `Control.Exception.catchDyn` (\(SignalException sig) -> handler sig)++-- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows+-- us to catch anything but a signal.  Useful for situations where we want+-- don't want to inhibit ctrl-C.++catchNonSignal :: IO a -> (Control.Exception.Exception -> IO a) -> IO a+catchNonSignal = Control.Exception.catchJust notSig+    where notSig x = case dynExceptions x of+                     Nothing -> Just x+                     Just d -> case fromDynamic d :: Maybe SignalException of+                               Just _ -> Nothing+                               Nothing -> Just x++catchInterrupt :: IO a -> IO a -> IO a+catchInterrupt job handler =+    job `catchSignal` h+        where h s | s == sigINT = handler+                  | otherwise   = throwDyn (SignalException s)++tryNonSignal :: IO a -> IO (Either Control.Exception.Exception a)+tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)++just_usererrors :: Control.Exception.Exception -> Maybe String+just_usererrors (IOException e) | isUserError e = Just $ ioeGetErrorString e+just_usererrors (IOException e) | ioeGetFileName e == Just "<stdout>"+                                      = Just $ "STDOUT"++ioeGetErrorString e+just_usererrors _ = Nothing++withSignalsBlocked :: IO () -> IO ()+withSignalsBlocked job = (block job) `catchSignal` couldnt_do+    where couldnt_do s | s == sigINT = oops "interrupt"+                       | s ==  sigHUP = oops "HUP"+                       | s ==  sigABRT = oops "ABRT"+                       | s ==  sigALRM = oops "ALRM"+                       | s ==  sigTERM = oops "TERM"+                       | s ==  sigPIPE = return ()+                       | otherwise = oops "unknown signal"+          oops s = hPutStrLn stderr $ "Couldn't handle " ++ s +++                   " since darcs was in a sensitive job."
+ src/Darcs/SlurpDirectory.hs view
@@ -0,0 +1,36 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++module Darcs.SlurpDirectory+ (Slurpy, empty_slurpy, slurp,+  mmap_slurp, co_slurp, slurp_unboring,+  FileContents,+  undefined_time, undefined_size,+  doesFileReallyExist, doesDirectoryReallyExist, isFileReallySymlink,+  wait_a_moment,+  is_dir, is_file,+  get_slurp, slurp_name,+  slurp_has, slurp_has_anycase, slurp_hasfile, slurp_hasdir,+  list_slurpy, list_slurpy_files, list_slurpy_dirs, get_path_list,+  get_filecontents, get_dircontents, get_mtime, get_length,+  slurp_modfile, slurp_remove, slurp_removefile, slurp_removedir,+  write_files,+  SlurpMonad, withSlurpy, writeSlurpy, syncSlurpy+ )+ where++import Darcs.SlurpDirectory.Internal
+ src/Darcs/SlurpDirectory/Internal.hs view
@@ -0,0 +1,677 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++-- | SlurpDirectory is intended to give a nice lazy way of traversing directory+-- trees.+module Darcs.SlurpDirectory.Internal+                      ( Slurpy(..), SlurpyContents(..), slurpies_to_map, map_to_slurpies,+                        FileContents, empty_slurpy,+                        slurp, mmap_slurp, slurp_unboring, co_slurp,+                        slurp_name, is_file, is_dir,+                        get_filecontents, get_dircontents, get_mtime,+                        get_length, get_slurp,+                        slurp_removefile, slurp_removedir,+                        slurp_remove,+                        slurp_modfile, slurp_hasfile, slurp_hasdir,+                        slurp_has_anycase, wait_a_moment, undefined_time,+                        undefined_size,+                        slurp_has, list_slurpy, list_slurpy_files,+                        get_path_list,+                        list_slurpy_dirs,+                        isFileReallySymlink,+                        doesFileReallyExist, doesDirectoryReallyExist,+                        SlurpMonad, withSlurpy, write_files,+                        writeSlurpy, syncSlurpy+                      ) where++import System.IO+import System.Directory hiding ( getCurrentDirectory, renameFile )+import Workaround ( getCurrentDirectory )+import Darcs.Utils ( withCurrentDirectory, formatPath )+import Darcs.RepoPath ( FilePathLike, toPath )+import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.List ( isPrefixOf )+import Control.Monad ( MonadPlus(..), when )+import Data.Char ( toLower )+import System.Posix.Types ( EpochTime )+import System.Posix.Files+        ( getSymbolicLinkStatus, modificationTime,+          fileSize,+          isRegularFile, isDirectory, isSymbolicLink+        )+import System.Posix ( sleep )+import Data.Maybe ( catMaybes, isJust, maybeToList )+import Data.Map (Map)+import qualified Data.Map as Map++import Darcs.SignalHandler ( tryNonSignal )+import Darcs.CheckFileSystem ( can_I_use_mmap )+import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )++import ByteStringUtils+import qualified Data.ByteString as B++import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir,+                              own_name, super_name )+#if mingw32_HOST_OS+import Data.Int ( Int64 )+#else+import System.Posix.Types ( FileOffset )+#endif++#include "impossible.h"++#if mingw32_HOST_OS+type FileOffset = Int64+#endif++data Slurpy = Slurpy !FileName !SlurpyContents++slurpy_to_pair :: Slurpy -> (FileName, SlurpyContents)+slurpy_to_pair (Slurpy fn sc) = (fn, sc)++pair_to_slurpy :: (FileName, SlurpyContents) -> Slurpy+pair_to_slurpy = uncurry Slurpy++type SlurpyMap = Map FileName SlurpyContents++slurpies_to_map :: [Slurpy] -> SlurpyMap+slurpies_to_map = Map.fromList . map slurpy_to_pair++map_to_slurpies :: SlurpyMap -> [Slurpy]+map_to_slurpies = map pair_to_slurpy . Map.toList++data SlurpyContents = SlurpDir (Maybe String) SlurpyMap+                    | SlurpFile (Maybe String,EpochTime,FileOffset) FileContents+type FileContents = B.ByteString++instance Show Slurpy where+    show (Slurpy fn (SlurpDir _ l)) =+        "Dir " ++ (fn2fp fn) ++ "\n" +++              concat (map show $ map_to_slurpies l) ++ "End Dir " ++ (fn2fp fn) ++ "\n"+    show (Slurpy fn (SlurpFile _ _)) = "File " ++ (fn2fp fn) ++ "\n"++mapSlurpyNames :: (FileName -> FileName) -> Slurpy -> Slurpy+mapSlurpyNames f = onSlurpy+  where onSlurpy (Slurpy fn sc) = Slurpy (f fn) (onSlurpyContents sc)+        onSlurpyContents sf@(SlurpFile _ _) = sf+        onSlurpyContents (SlurpDir x sm) = SlurpDir x . slurpies_to_map . map onSlurpy . map_to_slurpies $ sm++slurp :: FilePathLike p => p -> IO Slurpy+mmap_slurp :: FilePath -> IO Slurpy+slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy+empty_slurpy :: Slurpy+empty_slurpy = Slurpy (fp2fn ".") (SlurpDir Nothing Map.empty)+slurp_name :: Slurpy -> FilePath+is_file :: Slurpy -> Bool+is_dir :: Slurpy -> Bool++get_filecontents :: Slurpy -> FileContents+get_dircontents :: Slurpy -> [Slurpy]+get_mtime :: Slurpy -> EpochTime+get_length :: Slurpy -> FileOffset++instance Eq Slurpy where+    s1 == s2 = (slurp_name s1) == (slurp_name s2)+instance Ord Slurpy where+    s1 <= s2 = (slurp_name s1) <= (slurp_name s2)++data SlurpMonad a = SM ((Either String Slurpy)+                        -> Either String (Slurpy, a))+mksm :: (Slurpy -> Either String (Slurpy, a)) -> SlurpMonad a+mksm x = SM sm where sm (Left e) = Left e+                     sm (Right s) = x s++instance Functor SlurpMonad where+    fmap f m = m >>= return . f++instance Monad SlurpMonad where+    (SM p) >>= k  =  SM sm+        where sm e = case p e of+                     Left er -> Left er+                     Right (s, a) -> case k a of+                                     (SM q) -> q (Right s)+    return a = SM ( \s -> case s of+                          Left e -> Left e+                          Right x -> Right (x, a) )+    fail e = SM ( \s -> case s of+                        Left x -> Left x+                        _ -> Left e )++instance MonadPlus SlurpMonad where+    mzero = fail "SlurpMonad mzero"+    (SM p) `mplus` (SM q) = SM sm+        where sm e = case p e of+                     Left _ -> q e+                     okay -> okay++instance ReadableDirectory SlurpMonad where+    mDoesDirectoryExist d = smDoesDirectoryExist d+    mDoesFileExist f = smDoesFileExist f+    mInCurrentDirectory = smInSlurpy+    mGetDirectoryContents = smGetDirContents+    mReadFilePS = smReadFilePS+    mReadFilePSs = smReadFilePSs++instance WriteableDirectory SlurpMonad where+    mWithCurrentDirectory = modifySubSlurpy+    mSetFileExecutable _ _ = return ()+    mWriteFilePS = smWriteFilePS+    mCreateDirectory = smCreateDirectory+    mRename = smRename+    mRemoveDirectory = smRemoveDirectory+    mRemoveFile = smRemoveFile++write_file :: Slurpy -> FileName -> IO ()+write_file s fn = case withSlurpy s $ smReadFilePS fn of+                     Left err -> fail err+                     Right (_, c) -> do+                       ensureDirectories (super_name fn)+                       mWriteFilePS fn c+                       +try_write_file :: Slurpy -> FilePath -> IO ()+try_write_file s fp = let fn = fp2fn fp in+  if slurp_hasfile fn s+      then write_file s fn+      else if slurp_hasdir fn s+               then ensureDirectories fn+               else return ()++ensureDirectories :: WriteableDirectory m => FileName -> m ()+ensureDirectories d = do+          isPar <- mDoesDirectoryExist d+          if isPar +            then return ()+            else ensureDirectories (super_name d) >> (mCreateDirectory d)++write_files ::  Slurpy -> [FilePath] -> IO ()+write_files s fps = mapM_ (try_write_file s) fps++-- don't overwrite non-empty directories unless explicitly asked by+-- being passed "." (which always exists)+writeSlurpy :: Slurpy -> FilePath -> IO ()+writeSlurpy s d = do+  when (d /= ".") $ createDirectory d+  withCurrentDirectory d $ write_files s (list_slurpy s)++withSlurpy :: Slurpy -> SlurpMonad a -> Either String (Slurpy, a)+withSlurpy s (SM f) = f (Right s)++smDoesDirectoryExist :: FileName -> SlurpMonad Bool+smDoesDirectoryExist d = mksm $ \s -> (Right (s, slurp_hasdir d s))++smDoesFileExist :: FileName -> SlurpMonad Bool+smDoesFileExist f = mksm $ \s -> (Right (s, slurp_hasfile f s))++-- smInSlurpy doesn't make any changes to the subdirectory.+smInSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a+smInSlurpy d job = mksm sm+    where sm s = case get_slurp d s of+                 Just s' | is_dir s' -> case withSlurpy s' job of+                                        Left e -> Left e+                                        Right (_,a) -> Right (s, a)+                 _ -> Left $ "smInSlurpy:  Couldn't find directory " +++                             formatPath (fn2fp d)++fromSlurpFile :: FileName -> (Slurpy -> a) -> SlurpMonad a+fromSlurpFile f job = mksm sm+    where sm s = case get_slurp f s of+                 Just s' | is_file s' -> Right (s, job s')+                 _ -> Left $ "fromSlurpFile:  Couldn't find file " +++                             formatPath (fn2fp f)++modifySubSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a+modifySubSlurpy d job = mksm sm+    where sm s = case get_slurp_context d s of+                 Just (ctx, sub@(Slurpy _ (SlurpDir _ _))) ->+                     case withSlurpy sub job of+                     Left e -> Left e+                     Right (sub',a) -> Right (ctx sub', a)+                 _ -> Left $ "modifySubSlurpy:  Couldn't find directory " +++                             formatPath (fn2fp d)++modifyFileSlurpy :: FileName -> (Slurpy -> Slurpy) -> SlurpMonad ()+modifyFileSlurpy f job = mksm sm+    where sm s = case get_slurp_context f s of+                 Just (ctx, sf@(Slurpy _ (SlurpFile _ _))) -> Right (ctx $ job sf, ())+                 _ -> Left $ "modifyFileSlurpy:  Couldn't find file " +++                             formatPath (fn2fp f)++insertSlurpy :: FileName -> Slurpy -> SlurpMonad ()+insertSlurpy f news = mksm $ \s ->+                      if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)+                      then Left $ "Error creating file "++fn2fp f+                      else Right (addslurp f news s, ())++smReadFilePS :: FileName -> SlurpMonad B.ByteString+smReadFilePS f = fromSlurpFile f get_filecontents++smReadFilePSs :: FileName -> SlurpMonad [B.ByteString]+smReadFilePSs f = fromSlurpFile f (linesPS . get_filecontents)++smGetDirContents :: SlurpMonad [FileName]+smGetDirContents = mksm $ \s -> Right (s, map slurp_fn $ get_dircontents s)++smWriteFilePS :: FileName -> B.ByteString -> SlurpMonad ()+smWriteFilePS f ps = -- this implementation could be made rather more direct+                     -- and limited to a single pass down the Slurpy+                     modifyFileSlurpy f (\_ -> sl)+                     `mplus` insertSlurpy f sl+    where sl = Slurpy (own_name f) (SlurpFile undef_time_size ps)++smCreateDirectory :: FileName -> SlurpMonad ()+smCreateDirectory a = mksm sm+    where sm s = case slurp_adddir a s of+                 Just s' -> Right (s', ())+                 Nothing -> Left $ "Error creating directory "++fn2fp a++smRename :: FileName -> FileName -> SlurpMonad ()+smRename a b = mksm sm+    where sm s = case slurp_move a b s of+                 Just s' -> Right (s', ())+                 Nothing -> +                     -- Workaround for some old patches having moves when the source file doesn't exist.+                     if (slurp_has (fn2fp a) s)+                         then Left $ "Error moving "++fn2fp a++" to "++fn2fp b+                         else Right (s, ())++smRemove :: FileName -> SlurpMonad ()+smRemove f = mksm sm+    where sm s = case slurp_remove f s of+                 Nothing -> Left $ fn2fp f++" does not exist."+                 Just s' -> Right (s', ())++smRemoveFile :: FileName -> SlurpMonad ()+smRemoveFile f =+    do exists <- mDoesFileExist f+       if exists then smRemove f+                 else fail $ "File "++fn2fp f++" does not exist."++smRemoveDirectory :: FileName -> SlurpMonad ()+smRemoveDirectory f =+    do exists <- mDoesDirectoryExist f+       if exists then smRemove f+                 else fail $ "Directory "++fn2fp f++" does not exist."++-- | Here are a few access functions.+slurp_name (Slurpy n _) = fn2fp n+slurp_fn :: Slurpy -> FileName+slurp_fn (Slurpy n _) = n+slurp_setname :: FileName -> Slurpy -> Slurpy+slurp_setname f (Slurpy _ s) = Slurpy f s++is_file (Slurpy _ (SlurpDir _ _)) = False+is_file (Slurpy _ (SlurpFile _ _)) = True++is_dir (Slurpy _ (SlurpDir _ _)) = True+is_dir (Slurpy _ (SlurpFile _ _)) = False++get_filecontents (Slurpy _ (SlurpFile _ c)) = c+get_filecontents _ = bug "Can't get_filecontents on SlurpDir."++get_dircontents (Slurpy _ (SlurpDir _ c)) = map_to_slurpies c+get_dircontents _ = bug "Can't get_dircontents on SlurpFile."++get_mtime (Slurpy _ (SlurpFile (_,t,_) _)) = t+get_mtime _ = bug "can't get_mtime on SlurpDir."+get_length (Slurpy _ (SlurpFile (_,_,l) _)) = l+get_length _ = bug "can't get_length on SlurpDir."++undefined_time :: EpochTime+undefined_time = -1+undefined_size :: FileOffset+undefined_size = -1+undef_time_size :: (Maybe String, EpochTime, FileOffset)+undef_time_size = (Nothing, undefined_time, undefined_size)++wait_a_moment :: IO ()+wait_a_moment = do { sleep 1; return () }+    -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it+    -- returns an integer just like sleep(3) does. To stay compatible+    -- with older versions, though, we just ignore sleep's return+    -- value. Hackery, like I said.++isFileReallySymlink :: FilePath -> IO Bool+isFileReallySymlink f = do fs <- getSymbolicLinkStatus f+                           return (isSymbolicLink fs)++doesFileReallyExist :: FilePath -> IO Bool+doesFileReallyExist f = do fs <- getSymbolicLinkStatus f+                           return (isRegularFile fs)++doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f+                                return (isDirectory fs)++-- |slurp is how we get a slurpy in the first place\ldots+slurp = slurp_unboring (\_->True) . toPath+mmap_slurp d = do canmmap <- can_I_use_mmap+                  if canmmap then genslurp True (\_->True) d+                             else genslurp False (\_->True) d+slurp_unboring = genslurp False+genslurp :: Bool -> (FilePath -> Bool)+         -> FilePath -> IO Slurpy+genslurp usemm nb dirname = do+    isdir <- doesDirectoryExist dirname+    ms <- if isdir+          then withCurrentDirectory dirname $+               do actualname <- getCurrentDirectory+                  genslurp_helper usemm nb (reverse actualname) "" "."+          else do former_dir <- getCurrentDirectory+                  genslurp_helper usemm nb (reverse former_dir) "" dirname+    case ms of+      Just s -> return s+      Nothing -> fail $ "Unable to read directory " ++ dirname +++                 " (it appears to be neither file nor directory)"++unsafeInterleaveMapIO :: (a -> IO b) -> [a] -> IO [b]+unsafeInterleaveMapIO _ [] = return []+unsafeInterleaveMapIO f (x:xs)+ = do x' <- f x+      xs' <- unsafeInterleaveIO $ unsafeInterleaveMapIO f xs+      return (x':xs')++genslurp_helper :: Bool -> (FilePath -> Bool)+                -> FilePath -> String -> String -> IO (Maybe Slurpy)+genslurp_helper usemm nb formerdir fullpath dirname = do+    fs <- getSymbolicLinkStatus fulldirname+    if isRegularFile fs+     then do let mtime = (Nothing, modificationTime fs, fileSize fs)+             ls <- unsafeInterleaveIO $ myReadFileLinesPSetc fulldirname+             return $ Just $ Slurpy (fp2fn dirname) $ SlurpFile mtime ls+     else if isDirectory fs || (isSymbolicLink fs && dirname == ".")+          then do sl <- unsafeInterleaveIO $+                        do fnames <- getDirectoryContents fulldirname+                           unsafeInterleaveMapIO+                                             (\f -> genslurp_helper usemm nb fulldirname'+                                              (fullpath///f) f)+                                             $ filter (nb . (fullpath///)) $ filter not_hidden fnames+                  return $ Just $ Slurpy (fp2fn dirname) $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl+          else return Nothing+    where fulldirname' = formerdir\\\dirname+          fulldirname = reverse fulldirname'+          myReadFileLinesPSetc = if usemm then mmapFilePS+                                          else B.readFile++not_hidden :: FilePath -> Bool+not_hidden "." = False+not_hidden ".." = False+not_hidden _ = True++(\\\) :: FilePath -> FilePath -> FilePath+(\\\) "" d = d+(\\\) d "." = d+(\\\) d subdir = reverse subdir ++ "/" ++ d++(///) :: FilePath -> FilePath -> FilePath+(///) "" d = d+(///) d "." = d+(///) d subdir = d ++ "/" ++ subdir++co_slurp :: Slurpy -> FilePath -> IO Slurpy+co_slurp guide dirname = do+    isdir <- doesDirectoryExist dirname+    if isdir+       then withCurrentDirectory dirname $ do+              actualname <- getCurrentDirectory+              Just slurpy <- co_slurp_helper (reverse actualname) guide+              return slurpy+       else error "Error coslurping!!! Please report this."++co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy)+co_slurp_helper former_dir (Slurpy d (SlurpDir _ c)) = unsafeInterleaveIO $ do+    let d' = fn2fp d+        fn' = former_dir\\\d'+        fn = reverse fn'+    efs <- tryNonSignal $ getSymbolicLinkStatus fn+    case efs of+        Right fs+         | isDirectory fs || (isSymbolicLink fs && d' == ".") ->+            do sl <- unsafeInterleaveIO+                   $ unsafeInterleaveMapIO (co_slurp_helper fn') (map_to_slurpies c)+               return $ Just $ Slurpy d $ SlurpDir Nothing $ slurpies_to_map $ catMaybes sl+        _ -> return Nothing+co_slurp_helper former_dir (Slurpy f (SlurpFile _ _)) = unsafeInterleaveIO $ do+   let fn' = former_dir\\\fn2fp f+       fn = reverse fn'+   efs <- tryNonSignal $ getSymbolicLinkStatus fn+   case efs of+       Right fs+        | isRegularFile fs ->+           do let mtime = (Nothing, modificationTime fs, fileSize fs)+              ls <- unsafeInterleaveIO $ B.readFile fn+              return $ Just $ Slurpy f $ SlurpFile mtime ls+       _ -> return Nothing++get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy)+get_slurp_context_generic h1 h2 fn0 s0 =+    let norm_fn0 = norm_path fn0 in+    if norm_fn0 == empty+        then Just (id, s0)+        else slurp_context_private norm_fn0 id s0+  where+    slurp_context_private f ctx s@(Slurpy f' (SlurpFile _ _)) =+        if f == f' then Just (ctx, s)+        else Nothing+    slurp_context_private f ctx s@(Slurpy d (SlurpDir _ c))+      | f == d = Just (ctx, s)+      | d == dot =+            case break_on_dir f of+                Just (dn,fn) | dn == dot ->+                    descend fn+                _ ->+                    descend f+      | otherwise =+            case break_on_dir f of+                Just (dn,fn) ->+                    if dn == d+                        then descend fn+                        else Nothing+                _ -> Nothing+      where+        descend fname =+            case findSubSlurpy fname c of+                  Nothing -> Nothing+                  Just this -> slurp_context_private+                                   fname+                                   (ctx . h1 . Slurpy d . SlurpDir Nothing . foldr (uncurry Map.insert) (Map.delete (slurp_fn this) c) . map slurpy_to_pair . h2)+                                   this++    dot = fp2fn "."+    empty = fp2fn ""++-- |get_slurp_context navigates to a specified filename in the given slurpy,+-- and returns the child slurpy at that point together with a update function that can be used+-- to reconstruct the original slurpy from a replacement value for the child slurpy.+get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy)+get_slurp_context = get_slurp_context_generic id return++-- |A variant of 'get_slurp_context' that allows for removing the child slurpy+-- altogether by passing in 'Nothing' to the update function.+-- If the child slurpy happened to be at the top level and 'Nothing' was passed in,+-- then the result of the update function will also be 'Nothing', otherwise it will always+-- be a 'Just' value.+get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy)+get_slurp_context_maybe = get_slurp_context_generic Just maybeToList++-- |A variant of 'get_slurp_context' that allows for replacing the child slurpy by+-- a list of slurpies. The result of the update function will always be a singleton+-- list unless the child slurpy was at the top level.+-- Currently unused.+-- get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy)+-- get_slurp_context_list = get_slurp_context_generic return id++-- | It is important to be able to readily modify a slurpy.+slurp_remove :: FileName -> Slurpy -> Maybe Slurpy+slurp_remove fname s@(Slurpy _ (SlurpDir _ _)) =+    case get_slurp_context_maybe fname s of+        Just (ctx, _) -> ctx Nothing+        Nothing -> Nothing+slurp_remove _ _ = bug "slurp_remove only acts on SlurpDirs"++slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy+slurp_removefile f s =+  if slurp_hasfile f s+  then case slurp_remove f s of+       s'@(Just (Slurpy _ (SlurpDir _ _))) -> s'+       _ -> impossible+  else Nothing++slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy+slurp_move f f' s =+    if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s+    then case get_slurp f s of+         Nothing -> Nothing+         Just sf ->+             case slurp_remove f s of+             Nothing -> Nothing+             Just (s'@(Slurpy _ (SlurpDir _ _))) ->+                 Just $ addslurp f' (slurp_setname (own_name f') sf) s'+             _ -> impossible+    else Nothing++addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy+addslurp fname s s' =+    case get_slurp_context (super_name fname) s' of+        Just (ctx, Slurpy d (SlurpDir _ c)) -> ctx (Slurpy d (SlurpDir Nothing (uncurry Map.insert (slurpy_to_pair s) c)))+        _ -> s'++get_slurp :: FileName -> Slurpy -> Maybe Slurpy+get_slurp f s = fmap snd (get_slurp_context f s)++slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy+slurp_removedir f s =+    case get_slurp f s of+    Just (Slurpy _ (SlurpDir _ l)) | Map.null l ->+        case slurp_remove f s of+        s'@(Just (Slurpy _ (SlurpDir _ _))) -> s'+        _ -> impossible+    _ -> Nothing++slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy+slurp_adddir f s =+  if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)+  then Nothing+  else Just $ addslurp f (Slurpy (own_name f) (SlurpDir Nothing Map.empty)) s++-- |Code to modify a given file in a slurpy.+slurp_modfile :: FileName -> (FileContents -> Maybe FileContents)+              -> Slurpy -> Maybe Slurpy+slurp_modfile fname modify sl =+    case get_slurp_context fname sl of+        Just (ctx, Slurpy ff (SlurpFile _ c)) ->+            case modify c of+                Nothing -> Nothing+                Just c' -> Just (ctx (Slurpy ff (SlurpFile undef_time_size c')))+        _ -> +            Nothing++slurp_hasfile :: FileName -> Slurpy -> Bool+slurp_hasfile f s =+    case get_slurp f s of+        Just s' | is_file s' -> True+        _ -> False++slurp_has :: FilePath -> Slurpy -> Bool+slurp_has f s = isJust (get_slurp (fp2fn f) s)++slurp_has_anycase :: FilePath -> Slurpy -> Bool+slurp_has_anycase fname s =+  seq normed_name $ isJust $ get_slurp normed_name $ mapSlurpyNames tolower s+  where normed_name = norm_path $ fp2fn $ map toLower fname++tolower :: FileName -> FileName+tolower = fp2fn . (map toLower) . fn2fp++findSubSlurpy :: FileName -> SlurpyMap -> Maybe Slurpy+findSubSlurpy fn sm =+  let topname = case break_on_dir fn of+                   Just (dn, _) -> dn+                   Nothing -> fn+  in fmap (Slurpy topname) (Map.lookup topname sm)++slurp_hasdir :: FileName -> Slurpy -> Bool+slurp_hasdir d _ | norm_path d == fp2fn "" = True+slurp_hasdir f (Slurpy _ (SlurpDir _ c)) =+    seq f $ let f' = norm_path f+            in case findSubSlurpy f' c of+                Just s -> slurp_hasdir_private f' s+                Nothing -> False+slurp_hasdir _ _ = False++slurp_hasdir_private :: FileName -> Slurpy -> Bool+slurp_hasdir_private _ (Slurpy _ (SlurpFile _ _)) = False+slurp_hasdir_private f (Slurpy d (SlurpDir _ c))+  | f == d = True+  | otherwise =+       case break_on_dir f of+       Just (dn,fn) ->+           if dn == d+           then case findSubSlurpy fn c of+                   Just s -> slurp_hasdir_private fn s+                   Nothing -> False+           else False+       _ -> False++get_path_list :: Slurpy -> FilePath -> [FilePath]+get_path_list s fp = get_path_list' s ("./" ++ fp)++get_path_list' :: Slurpy -> FilePath -> [FilePath]+get_path_list' s "" = list_slurpy s+get_path_list' (Slurpy f (SlurpFile _ _)) fp+ | f' == fp = [f']+    where f' = fn2fp f+get_path_list' (Slurpy d (SlurpDir _ ss)) fp+ | (d' ++ "/") `isPrefixOf` (fp ++ "/")+    = let fp' = drop (length d' + 1) fp+      in map (d' ///) $ concatMap (\s -> get_path_list' s fp') $ map_to_slurpies ss+    where d' = fn2fp d+get_path_list' _ _ = []++list_slurpy :: Slurpy -> [FilePath]+list_slurpy (Slurpy f (SlurpFile _ _)) = [fn2fp f]+list_slurpy (Slurpy dd (SlurpDir _ ss)) = d : map (d ///) (concatMap list_slurpy (map_to_slurpies ss))+    where d = fn2fp dd++list_slurpy_files :: Slurpy -> [FilePath]+list_slurpy_files (Slurpy f (SlurpFile _ _)) = [fn2fp f]+list_slurpy_files (Slurpy dd (SlurpDir _ ss)) =+    map ((fn2fp dd) ///) (concatMap list_slurpy_files (map_to_slurpies ss))++list_slurpy_dirs :: Slurpy -> [FilePath]+list_slurpy_dirs (Slurpy _ (SlurpFile _ _)) = []+list_slurpy_dirs (Slurpy dd (SlurpDir _ ss)) =+    d : map (d ///) (concatMap list_slurpy_dirs (map_to_slurpies ss))+    where d = fn2fp dd++unsyncedSlurpySize :: Slurpy -> Int+unsyncedSlurpySize (Slurpy _ (SlurpFile (_,_,size) ps))+    | size == undefined_size = B.length ps+    | otherwise = 0+unsyncedSlurpySize (Slurpy _ (SlurpDir _ ss)) =+    sum $ map unsyncedSlurpySize (map_to_slurpies ss)++slurp_sync_size :: Int+slurp_sync_size = 100 * 1000000++syncSlurpy :: (Slurpy -> IO Slurpy) -> Slurpy -> IO Slurpy+syncSlurpy put s = if unsyncedSlurpySize s > slurp_sync_size+                   then put s+                   else return s
+ src/Darcs/Test.lhs view
@@ -0,0 +1,119 @@+%  Copyright (C) 2002-2005 David Roundy+%+%  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.++\begin{code}+module Darcs.Test ( get_test,+                    run_posthook, run_prehook )+where+import Darcs.RepoPath ( AbsolutePath )+import Darcs.Utils ( withCurrentDirectory )+import System.Exit ( ExitCode(..) )+import System.Cmd ( system )+import Control.Monad ( when )++import Darcs.Arguments ( DarcsFlag( Quiet,+                                    AskPosthook, AskPrehook ),+                        get_posthook_cmd, get_prehook_cmd )+import Darcs.Repository.Prefs ( get_prefval )+import Darcs.Utils ( askUser )+import System.IO ( hPutStrLn, stderr )+\end{code}++If you like, you can configure your repository to be able to run a test+suite of some sort.  You can do this by using ``setpref'' to set the+``test'' value to be a command to run, e.g.+\begin{verbatim}+% darcs setpref test "sh configure && make && make test"+\end{verbatim}+Or, if you want to define a test specific to one copy of the repository,+you could do this by editing the file \verb!_darcs/prefs/prefs!.++\begin{options}+--leave-test-directory, --remove-test-directory+\end{options}++Normally darcs deletes the directory in which the test was run afterwards.+Sometimes (especially when the test fails) you'd prefer to be able to be+able to examine the test directory after the test is run.  You can do this+by specifying the \verb!--leave-test-directory! flag.  Alas, there is no+way to make darcs leave the test directory only if the test fails.  The+opposite of \verb!--leave-test-directory! is+\verb!--remove-test-directory!, which could come in handy if you choose to+make \verb!--leave-test-directory! the default (see+section~\ref{defaults}).++\begin{code}+get_test :: [DarcsFlag] -> IO (IO ExitCode)+get_test opts =+ let putInfo s = when (not $ Quiet `elem` opts) $ putStr s+ in do+ testline <- get_prefval "test"+ return $+   case testline of+   Nothing -> return ExitSuccess+   Just testcode -> do+     putInfo "Running test...\n"+     ec <- system testcode+     if ec == ExitSuccess+       then putInfo "Test ran successfully.\n"+       else putInfo "Test failed!\n"+     return ec++run_posthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode+run_posthook opts repodir = do ph <- get_posthook opts+                               withCurrentDirectory repodir $ run_hook opts "Posthook" ph++get_posthook :: [DarcsFlag] -> IO (Maybe String)+get_posthook opts = case get_posthook_cmd opts of+                    Nothing -> return Nothing+                    Just command ->+                       if AskPosthook `elem` opts+                       then do yorn <- askUser ("\nThe following command is set to execute.\n"+++                                                "Execute the following command now (yes or no)?\n"+++                                                command++"\n")+                               case yorn of ('y':_) -> return $ Just command+                                            _ -> do putStrLn "Posthook cancelled..."+                                                    return Nothing+                       else return $ Just command++run_prehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode+run_prehook opts repodir = do ph <- get_prehook opts+                              withCurrentDirectory repodir $ run_hook opts "Prehook" ph++get_prehook :: [DarcsFlag] -> IO (Maybe String)+get_prehook opts = case get_prehook_cmd opts of+                   Nothing -> return Nothing+                   Just command ->+                       if AskPrehook `elem` opts+                       then do yorn <- askUser ("\nThe following command is set to execute.\n"+++                                                "Execute the following command now (yes or no)?\n"+++                                                command++"\n")+                               case yorn of ('y':_) -> return $ Just command+                                            _ -> do putStrLn "Prehook cancelled..."+                                                    return Nothing+                       else return $ Just command++run_hook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode+run_hook _ _ Nothing = return ExitSuccess+run_hook opts cname (Just command) =+    do ec <- system command+       when (Quiet `notElem` opts) $+         if ec == ExitSuccess+         then putStrLn $ cname++" ran successfully."+         else hPutStrLn stderr $ cname++" failed!"+       return ec+\end{code}
+ src/Darcs/TheCommands.hs view
@@ -0,0 +1,106 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.++module Darcs.TheCommands ( command_control_list ) where++import Darcs.Commands.Add ( add )+import Darcs.Commands.AmendRecord ( amendrecord )+import Darcs.Commands.Annotate ( annotate )+import Darcs.Commands.Apply ( apply )+import Darcs.Commands.Changes ( changes )+import Darcs.Commands.Check ( check )+import Darcs.Commands.Convert ( convert )+import Darcs.Commands.Diff+import Darcs.Commands.Dist ( dist )+import Darcs.Commands.Get ( get, clone )+#ifdef HAVE_HASKELL_ZLIB+import Darcs.Commands.GZCRCs ( gzcrcs )+#else+-- import just to check it compiles+import Darcs.Commands.GZCRCs ()+#endif+import Darcs.Commands.Init ( initialize )+import Darcs.Commands.Show ( show_command, list, query )+import Darcs.Commands.MarkConflicts ( markconflicts, resolve )+import Darcs.Commands.Move ( move, mv )+import Darcs.Commands.Optimize ( optimize )+import Darcs.Commands.Pull ( pull )+import Darcs.Commands.Push ( push )+import Darcs.Commands.Put ( put )+import Darcs.Commands.Record ( record, commit )+import Darcs.Commands.Remove ( remove, rm, unadd )+import Darcs.Commands.Repair ( repair )+import Darcs.Commands.Replace ( replace )+import Darcs.Commands.Revert ( revert )+import Darcs.Commands.Rollback ( rollback )+import Darcs.Commands.Send ( send )+import Darcs.Commands.SetPref ( setpref )+import Darcs.Commands.Tag ( tag )+import Darcs.Commands.TrackDown ( trackdown )+import Darcs.Commands.TransferMode ( transfer_mode )+import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate )+import Darcs.Commands.Unrevert ( unrevert )+import Darcs.Commands.WhatsNew ( whatsnew )+import Darcs.Commands ( CommandControl(Command_data,Hidden_command,Group_name) )++-- | The commands that darcs knows about (e.g. whatsnew, record),+--   organized into thematic groups.  Note that hidden commands+--   are also listed here.+command_control_list :: [CommandControl]+command_control_list = [Group_name "Changing and querying the working copy:",+                Command_data add,+                Command_data remove, Hidden_command unadd, Hidden_command rm,+                Command_data move, Hidden_command mv,+                Command_data replace,+                Command_data revert,+                Command_data unrevert,+                Command_data whatsnew,+                Group_name "Copying changes between the working copy and the repository:",+                Command_data record, Hidden_command commit,+                Command_data unrecord,+                Command_data amendrecord,+                Command_data markconflicts, Hidden_command resolve,+                Group_name "Direct modification of the repository:",+                Command_data tag,+                Command_data setpref,+                Group_name "Querying the repository:",+                Command_data diff_command,+                Command_data changes,+                Command_data annotate,+                Command_data dist,+                Command_data trackdown,+                Command_data show_command, Hidden_command list, Hidden_command query,+                Hidden_command transfer_mode,+                Group_name "Copying patches between repositories with working copy update:",+                Command_data pull,+                Command_data obliterate, Hidden_command unpull,+                Command_data rollback,+                Command_data push,+                Command_data send,+                Command_data apply,+                Command_data get, Hidden_command clone,+                Command_data put,+                Group_name "Administrating repositories:",+                Command_data initialize,+                Command_data optimize,+                Command_data check,+                Command_data repair,+                Command_data convert+#ifdef HAVE_HASKELL_ZLIB+                ,Hidden_command gzcrcs+#endif+               ]
+ src/Darcs/URL.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++{-+Copyright (C) 2004 David Roundy++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.+-}++{-|++  Path resolving:++    * A URL contains the sequence @\":\/\/\"@.++    * A local filepath does not contain colons, except+      as second character (windows drives).++    * A path that is neither a URL nor a local file+      is an ssh-path.++  Examples:++  > /usr/repo/foo                 -- local file+  > c:/src/darcs                  -- local file+  > http://darcs.net/             -- URL+  > peter@host:/path              -- ssh+  > droundy@host:                 -- ssh+  > host:/path                    -- ssh++  This means that single-letter hosts in ssh-paths do not work,+  unless a username is provided.++  Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead?+-}++module Darcs.URL (+    is_file, is_url, is_ssh, is_relative, is_absolute,+    is_ssh_nopath+  ) where++#include "impossible.h"++is_relative :: String -> Bool+is_relative (_:':':_) = False+is_relative f@(c:_) = is_file f && c /= '/' && c /= '~'+is_relative "" = bug "Empty filename in is_relative"++is_absolute :: String -> Bool+is_absolute "" = bug "is_absolute called with empty filename"+is_absolute f = is_file f && (not $ is_relative f)++is_file :: String -> Bool+is_file (_:_:fou) = ':' `notElem` fou+is_file _ = True++is_url :: String -> Bool+is_url (':':'/':'/':_:_) = True+is_url (_:x) = is_url x+is_url "" = False++is_ssh :: String -> Bool+is_ssh s = not (is_file s || is_url s)++is_ssh_nopath :: String -> Bool+is_ssh_nopath s = case reverse s of+                  ':':x@(_:_:_) -> ':' `notElem` x+                  _ -> False
+ src/Darcs/Utils.hs view
@@ -0,0 +1,258 @@+-- Various utility functions that do not belong anywhere else.++{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,+                     clarify_errors, prettyException, prettyError,+                    putStrLnError, putDocLnError,+                    withCurrentDirectory,+                    withUMask, askUser, stripCr,+                    showHexLen, add_to_error_loc,+                    maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,+                    isUnsupportedOperationError, isHardwareFaultError,+                    get_viewer, edit_file, promptYorn, promptCharFancy,+                    environmentHelpEditor, environmentHelpPager,+                    formatPath ) where++import Prelude hiding ( catch )+import Control.Exception ( bracket, bracket_, catch, Exception(IOException), try )+import GHC.IOBase ( IOException(ioe_location),+                    IOErrorType(UnsupportedOperation, HardwareFault) )+import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString )++import Darcs.SignalHandler ( catchNonSignal )+import Numeric ( showHex )+import System.Directory ( doesFileExist )+import System.Exit ( exitWith, ExitCode(..) )+import System.Environment ( getEnv )+import System.IO ( hPutStrLn, stderr )+import Data.Char ( toUpper )+import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )+import Data.Maybe ( listToMaybe, isJust )+import Data.List ( group, sort )+import Control.Monad ( when )+import Exec ( exec_interactive )+import Printer ( Doc, hPutDocLn )+import Foreign.C.String ( CString, withCString )+import Foreign.C.Error ( throwErrno )+import Foreign.C.Types ( CInt )++import Progress ( withoutProgress )++import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,+                                  getInputChar, outputStrLn )+import System.Console.Haskeline.Encoding ( encode )+import qualified Data.ByteString as B ( readFile )+import qualified Data.ByteString.Char8 as B ( unpack )++showHexLen :: (Integral a) => Int -> a -> String+showHexLen n x = let s = showHex x ""+                 in replicate (n - length s) ' ' ++ s++add_to_error_loc :: Exception -> String -> Exception+add_to_error_loc (IOException ioe) s+    = IOException $ ioe { ioe_location = s ++ ": " ++ ioe_location ioe }+add_to_error_loc e _ = e++isUnsupportedOperationError :: IOError -> Bool+isUnsupportedOperationError = isUnsupportedOperationErrorType . ioeGetErrorType++isUnsupportedOperationErrorType :: IOErrorType -> Bool+isUnsupportedOperationErrorType UnsupportedOperation = True+isUnsupportedOperationErrorType _ = False++isHardwareFaultError :: IOError -> Bool+isHardwareFaultError = isHardwareFaultErrorType . ioeGetErrorType++isHardwareFaultErrorType :: IOErrorType -> Bool+isHardwareFaultErrorType HardwareFault = True+isHardwareFaultErrorType _ = False++catchall :: IO a -> IO a -> IO a+a `catchall` b = a `catchNonSignal` (\_ -> b)++maybeGetEnv :: String -> IO (Maybe String)+maybeGetEnv s = (getEnv s >>= return.Just) `catchall` return Nothing -- err can only be isDoesNotExist+++-- |The firstJustM returns the first Just entry in a list of monadic operations.  This is close to+--  `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the+--  list before passing it along (i.e. sequence is strict).  The firstJustM is lazy in that list+--  member monads are only evaluated up to the point where the first Just entry is obtained.+firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)+firstJustM [] = return Nothing+firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)++-- |The firstJustIO is a slight modification to firstJustM: the+--  entries in the list must be IO monad operations and the+--  firstJustIO will silently turn any monad call that throws an+--  exception into Nothing, basically causing it to be ignored.+firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)+firstJustIO = firstJustM . map (\o -> o `catchall` return Nothing)+++clarify_errors :: IO a -> String -> IO a+clarify_errors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])++prettyException :: Control.Exception.Exception -> String+prettyException (IOException e) | isUserError e = ioeGetErrorString e+prettyException e = show e++prettyError :: IOError -> String+prettyError e | isUserError e = ioeGetErrorString e+              | otherwise = show e++-- | Given two shell commands as arguments, execute the former.  The+-- latter is then executed if the former failed because the executable+-- wasn't found (code 127), wasn't executable (code 126) or some other+-- exception occurred.  Other failures (such as the user holding ^C)+-- do not cause the second command to be tried.+ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode+a `ortryrunning` b = do+  ret <- try a+  case ret of+    (Right (ExitFailure 126)) -> b -- command not executable+    (Right (ExitFailure 127)) -> b -- command not found+    (Right x) -> return x          -- legitimate success/failure+    (Left _) -> b                  -- an exception++putStrLnError :: String -> IO ()+putStrLnError = hPutStrLn stderr++putDocLnError :: Doc -> IO ()+putDocLnError = hPutDocLn stderr++withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a+withCurrentDirectory name m =+    bracket+        (do cwd <- getCurrentDirectory+            when (toFilePath name /= "") (setCurrentDirectory name)+            return cwd)+        (\oldwd -> setCurrentDirectory oldwd `catchall` return ())+        (const m)++foreign import ccall unsafe "umask.h set_umask" set_umask+    :: CString -> IO CInt+foreign import ccall unsafe "umask.h reset_umask" reset_umask+    :: CInt -> IO CInt++withUMask :: String -> IO a -> IO a+withUMask umask job =+    do rc <-withCString umask set_umask+       when (rc < 0) (throwErrno "Couldn't set umask")+       bracket_+           (return ())+           (reset_umask rc)+           job++askUser :: String -> IO String+askUser prompt = withoutProgress $ runInputT defaultSettings $+                    getInputLine prompt+                        >>= maybe (error "askUser: unexpected end of input") return+            -- Return the input as encoded, 8-bit Chars (same as the+            -- non-Haskeline backend).+                        >>= fmap B.unpack . encode++stripCr :: String -> String+stripCr ""     = ""+stripCr "\r"   = ""+stripCr (c:cs) = c : stripCr cs++-- |Returns Just l where l is first non-blank string in input array; Nothing if no non-blank entries+firstNotBlank :: [String] -> Maybe String+firstNotBlank = listToMaybe . filter (not . null)+++-- Format a path for screen output,+-- so that the user sees where the path begins and ends.+-- Could (should?) also warn about unprintable characters here.+formatPath :: String -> String+formatPath path = "\"" ++ quote path ++ "\""+    where quote "" = ""+          quote (c:cs) = if c=='\\' || c=='"'+                         then '\\':c:quote cs+                         else c:quote cs++breakCommand :: String -> (String, [String])+breakCommand s = case words s of+                   (arg0:args) -> (arg0,args)+                   [] -> (s,[])++nubsort :: Ord a => [a] -> [a]+nubsort = map head . group . sort+++edit_file :: FilePathLike p => p -> IO ExitCode+edit_file ff = do+  ed <- get_editor+  old_content <- file_content+  ec <- exec_interactive ed f+             `ortryrunning` exec_interactive "emacs" f+             `ortryrunning` exec_interactive "emacs -nw" f+             `ortryrunning` exec_interactive "nano" f+#ifdef WIN32+             `ortryrunning` exec_interactive "edit" f+#endif+  new_content <- file_content+  when (new_content == old_content) $ do+    yorn <- promptYorn "File content did not change. Continue anyway?"+    when (yorn == 'n') $ do putStrLn "Aborted."+                            exitWith ExitSuccess+  return ec+      where f = toFilePath ff+            file_content = do+              exists <- doesFileExist f+              if exists then do content <- B.readFile f+                                return $ Just content+                        else return Nothing++get_editor :: IO String+get_editor = getEnv "DARCS_EDITOR" `catchall`+             getEnv "DARCSEDITOR" `catchall`+             getEnv "VISUAL" `catchall`+             getEnv "EDITOR" `catchall` return "vi"++environmentHelpEditor :: ([String], [String])+environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[+ "To edit a patch description of email comment, Darcs will invoke an",+ "external editor.  Your preferred editor can be set as any of the",+ "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",+ "If none of these are set, vi(1) is used.  If vi crashes or is not",+ "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",+ "each tried in turn."])++get_viewer :: IO String+get_viewer = getEnv "DARCS_PAGER" `catchall`+             getEnv "PAGER" `catchall` return "less"++environmentHelpPager :: ([String], [String])+environmentHelpPager = (["DARCS_PAGER", "PAGER"],[+ "Darcs will sometimes invoke a pager if it deems output to be too long",+ "to fit onscreen.  Darcs will use the pager specified by $DARCS_PAGER",+ "or $PAGER.  If neither are set, `less' will be used."])++promptYorn :: [Char] -> IO Char+promptYorn p = promptCharFancy p "yn" Nothing []++promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char+promptCharFancy p chs md help_chs = withoutProgress $ runInputT defaultSettings $+                                        loopChar+ where+ loopChar = do+    let prompt = p ++ " [" ++ setDefault chs ++ "]" ++ helpStr+    a <- getInputChar prompt >>= maybe (error "promptCharFancy: unexpected end of input")+                                    return+    case () of +     _ | a `elem` chs                   -> return a+       | a == ' ' -> case md of Nothing -> tryAgain +                                Just d  -> return d+       | a `elem` help_chs              -> return a+       | otherwise                      -> tryAgain+ helpStr = case help_chs of+           []    -> ""+           (h:_) -> ", or " ++ (h:" for help: ")+ tryAgain = do outputStrLn "Invalid response, try again!"+               loopChar+ setDefault s = case md of Nothing -> s+                           Just d  -> map (setUpper d) s+ setUpper d c = if d == c then toUpper c else c
+ src/DateMatcher.hs view
@@ -0,0 +1,168 @@+-- Copyright (C) 2004 David Roundy+--+-- 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.+++{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE ExistentialQuantification #-}++module DateMatcher ( parseDateMatcher+                   -- for debugging only+                   , DateMatcher(..), getMatchers ) where++import Control.Exception ( catchJust, userErrors )+import Data.Maybe ( isJust )+import System.Time+import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601_interval,+                 resetCalendar, subtractFromMCal, getLocalTz,+                 MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime,+                 unsetTime,+               )+import Text.ParserCombinators.Parsec ( eof, parse, ParseError )++-- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@+-- Note that this converts the two dates to @ClockTime@ to avoid+-- any timezone-related errors+withinDay :: CalendarTime -> CalendarTime -> Bool+withinDay a b = within (Just $ toClockTime a)+                       (Just (addToClockTime day $ toClockTime a))+                       (toClockTime b)+ where day = TimeDiff 0 0 1 0 0 0 0++-- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@+--   Since @x1@ and @x2@ can be underspecified, we simply assume the+--   first date that they could stand for.+dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool+dateRange a b c = cDateRange (fmap unsafeToCalendarTime a)+                             (fmap unsafeToCalendarTime b) c++-- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@+cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool+cDateRange a b c = within (fmap toClockTime a)+                          (fmap toClockTime b) (toClockTime c)++-- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@+within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool+within (Just start) (Just end) time = start <= time && time < end+within Nothing (Just end) time = time < end+within (Just start) Nothing time = start <= time+within _ _ _ = undefined++-- | 'samePartialDate' @range exact@ is true if @exact@ falls+--   within the a range of dates represented by @range@.+--   The purpose of this function is to support matching on partially+--   specified dates.  That is, if you only specify the date 2007,+--   this function should match any dates within that year.  On the+--   other hand, if you specify 2007-01, this function will match any+--   dates within that month.  This function only matches up to the+--   second.+samePartialDate :: MCalendarTime -> CalendarTime -> Bool+samePartialDate a b_ =+ within (Just clockA)+        (Just $ addToClockTime interval clockA)+        (toClockTime calB)+ where interval+         | isJust (mctSec a)   = second+         | isJust (mctMin a)   = minute+         | isJust (mctHour a)  = hour+         | isJust (mctYDay a)  = day+         | mctWeek a = maybe week (const day) (mctWDay a)+         | isJust (mctDay a)   = day+         | isJust (mctMonth a) = month+         | otherwise           = year+       year  = TimeDiff 1 0 0 0 0 0 0+       month = TimeDiff 0 1 0 0 0 0 0+       week  = TimeDiff 0 0 7 0 0 0 0+       day   = TimeDiff 0 0 1 0 0 0 0+       hour   = TimeDiff 0 0 0 1 0 0 0+       minute = TimeDiff 0 0 0 0 1 0 0+       second = TimeDiff 0 0 0 0 0 1 0+       --+       clockA = toClockTime $ unsafeToCalendarTime a+       calB   = resetCalendar b_++-- | A 'DateMatcher' combines a potential parse for a date string+--   with a "matcher" function that operates on a given date.+--   We use an existential type on the matcher to allow+--   the date string to either be interpreted as a point in time+--   or as an interval.+data DateMatcher = forall d . (Show d) =>+       DM String --  name+          (Either ParseError d) --  parser+          (d -> CalendarTime -> Bool) --  matcher++-- | 'parseDateMatcher' @s@ return the first  matcher in+--    'getMatchers' that can parse 's'+parseDateMatcher :: String -> IO (CalendarTime -> Bool)+parseDateMatcher d = + do matcher <- tryMatchers `fmap` getMatchers d+    -- Hack: test the matcher against the current date and discard the results.+    -- We just want to make sure it won't throw any exceptions when we use it for real.+    matcher `fmap` now >>= (`seq` return matcher)+ `catchUserError`+    -- If the user enters a date > maxint seconds ago, the toClockTime+    -- function cannot work.+    \e -> if e == "Time.toClockTime: invalid input"+          then error "Can't handle dates that far back!"+          else error e+ where+   catchUserError = catchJust userErrors++-- | 'getMatchers' @d@ returns the list of matchers that will be+--   applied on @d@.  If you wish to extend the date parsing code,+--   this will likely be the function that you modify to do so.+getMatchers :: String -> IO [DateMatcher]+getMatchers d =+ do rightNow <- now+    let midnightToday = unsetTime rightNow+        mRightNow = toMCalendarTime rightNow+        matchIsoInterval (Left dur) = dateRange (Just $ dur `subtractFromMCal` mRightNow) (Just mRightNow)+        matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)+    tzNow <- getLocalTz+    return -- note that the order of these is quite important as some matchers+           -- can match the same date.+          [ DM "from English date"+                (parseDateWith $ englishLast midnightToday)+                (\(a,_) -> cDateRange (Just a) Nothing)+          , DM "specific English date"+                (parseDateWith $ englishDateTime midnightToday)+                withinDay+          , DM "English interval"+                (parseDateWith $ englishInterval rightNow)+                (uncurry cDateRange)+          , DM "ISO 8601 interval"+                (parseDateWith $ iso8601_interval tzNow)+                matchIsoInterval+          , DM "CVS, ISO 8601, or old style date"+                (parseDate tzNow d)+                samePartialDate ]+ where+   tillEof p = do { x <- p; eof; return x }+   parseDateWith p = parse (tillEof p) "" d++-- | 'tryMatchers' @ms@ returns the first successful match in @ms@+--   It is an error if there are no matches+tryMatchers :: [DateMatcher] -> (CalendarTime -> Bool)+tryMatchers (DM _ parsed matcher : ms) =+  case parsed of+  Left _   -> tryMatchers ms+  Right  d -> matcher d+tryMatchers [] = error "Can't support fancy dates."++-- darcs-doc: self-explanatory+now :: IO CalendarTime+now = getClockTime >>= toCalendarTime+
+ src/English.hs view
@@ -0,0 +1,76 @@+-- Copyright (C) 2008 Eric Kow+--+-- 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.++-- | This modules provides rudimentary natural language generation+-- (NLG) utilities.  That is, generating natural language from a+-- machine representation.  Initially, only English is supported at+-- all.  Representations are implemented for:+--+--  * countable nouns (plurality); and+--  * lists of clauses (foo, bar and/or baz).+module English where++import Data.List (isSuffixOf, intersperse)++-- | > englishNum 0 (Noun "watch") "" == "watches"+--   > englishNum 1 (Noun "watch") "" == "watch"+--   > englishNum 2 (Noun "watch") "" == "watches"+englishNum :: Countable n => Int -> n -> ShowS+englishNum x = if x == 1 then singular else plural++-- | Things that have a plural and singular spelling+class Countable a where+  plural :: a -> ShowS+  singular :: a -> ShowS++-- | This only distinguishes between nouns with a final -ch,+--   and nouns which do not.+--   More irregular nouns will just need to have their own type+--+--   > plural (Noun "batch") "" == "batches"+--   > plural (Noun "bat")   "" == "bats"+--   > plural (Noun "mouse") "" == "mouses" -- :-(+newtype Noun = Noun String++instance Countable Noun where+  -- more irregular nouns will just need to have their own type+  plural (Noun s) | "ch" `isSuffixOf` s = showString s .  showString "es"+  plural (Noun s) = showString s . showChar 's'+  singular (Noun s) =  showString s++-- | > singular This (Noun "batch") "" == "this batch"+--   > plural   This (Noun "batch") "" == "these batches"+data This = This Noun++instance Countable This where+  plural (This s)   = showString "these "  . plural s+  singular (This s) = showString "this "   . singular s++-- | Given a list of things, combine them thusly:+--+--   > orClauses ["foo", "bar", "baz"] == "foo, bar or baz"+andClauses, orClauses :: [String] -> String+andClauses = intersperseLast ", " " and "+orClauses  = intersperseLast ", " " or "++-- | As 'intersperse', with a different separator for the last+-- | interspersal.+intersperseLast :: String -> String -> [String] -> String+intersperseLast _ _ [] = ""+intersperseLast _ _ [clause] = clause+intersperseLast sep sepLast clauses =+    concat (intersperse sep $ init clauses) ++ sepLast ++ last clauses
+ src/Exec.hs view
@@ -0,0 +1,180 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.+++{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-- , DeriveDataTypeable #-}++module Exec ( exec, exec_interactive,+              withoutNonBlock,+              Redirects, Redirect(..),+              ExecException(..)+            ) where++import Data.Typeable ( Typeable )++#ifndef WIN32+import Control.Exception ( bracket )+import System.Posix.Env ( setEnv, getEnv, unsetEnv )+import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )+import System.IO	( stdin )+#else+import Control.Exception ( catchJust, Exception(IOException) )+import Data.List ( isInfixOf )+#endif++import System.Exit ( ExitCode (..) )+import System.Cmd ( system )+import System.IO	( IOMode(..), openBinaryFile, stdout )+import System.Process   ( runProcess, terminateProcess, waitForProcess )+import GHC.Handle	( hDuplicate )+        -- urgh.  hDuplicate isn't available from a standard place.+import Control.Exception ( bracketOnError )++import Darcs.Global ( whenDebugMode )+import Progress ( withoutProgress )++{-+   A redirection is a three-tuple of values (in, out, err).+   The most common values are:++     AsIs    don't change it+     Null    /dev/null on Unix, NUL on Windows+     File    open a file for reading or writing++   There is also the value Stdout, which is only meaningful for+   redirection of errors, and is performed AFTER stdout is+   redirected so that output and errors mix together. StdIn and+   StdErr could be added as well if they are useful.++   NOTE: Lots of care must be taken when redirecting stdin, stdout+   and stderr to one of EACH OTHER, since the ORDER in which they+   are changed have a significant effect on the result.+-}++type Redirects = (Redirect, Redirect, Redirect)+data Redirect = AsIs | Null | File FilePath+              | Stdout+                deriving Show++{-+  ExecException is thrown by exec if any system call fails,+  for example because the executable we're trying to run+  doesn't exist.+-}+--                   ExecException cmd    args     redirecs  errorDesc+data ExecException = ExecException String [String] Redirects String+                     deriving (Typeable,Show)+++_dev_null :: FilePath+#ifdef WIN32+_dev_null = "NUL"+#else+_dev_null = "/dev/null"+#endif++{-+  We use System.Process, which does the necessary quoting+  and redirection for us behind the scenes.+-}++exec  :: String -> [String] -> Redirects -> IO ExitCode+exec cmd args (inp,out,err) = withoutProgress $ do+  h_stdin  <- redirect inp ReadMode+  h_stdout <- redirect out WriteMode+  h_stderr <- redirect err WriteMode+--  putStrLn (unwords (cmd:args ++ map show [inp,out,err]))+  withExit127 $ bracketOnError+    (do whenDebugMode $ putStrLn $ unwords $ cmd:args ++ ["; #"] ++ map show [inp,out,err]+        runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)+    (terminateProcess)+    (waitForProcess)+  where+    redirect AsIs               _    = return Nothing+    redirect Null               mode = Just `fmap` openBinaryFile _dev_null mode+    redirect (File "/dev/null") mode = redirect Null mode+    redirect (File f)           mode = Just `fmap` openBinaryFile f mode+    redirect Stdout             _    = Just `fmap` hDuplicate stdout+        -- hDuplicate stdout rather than passing stdout itself,+        -- because runProcess closes the Handles we pass it.++exec_interactive :: String -> String -> IO ExitCode++#ifndef WIN32+{-+This should handle arbitrary commands interpreted by the shell on Unix since+that's what people expect. But we don't want to allow the shell to interpret+the argument in any way, so we set an environment variable and call+cmd "$DARCS_ARGUMENT"+-}+exec_interactive cmd arg = withoutProgress $ do+  let var = "DARCS_ARGUMENT"+  stdin `seq` return ()+  withoutNonBlock $ bracket+    (do oldval <- getEnv var+        setEnv var arg True+        return oldval)+    (\oldval ->+       do case oldval of+            Nothing -> unsetEnv var+            Just val -> setEnv var val True)+    (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")++#else++exec_interactive cmd arg = withoutProgress $ do+  system $ cmd ++ " " ++ arg+#endif++withoutNonBlock :: IO a -> IO a++#ifndef WIN32+{-+Do IO without NonBlockingRead on stdInput.++This is needed when running unsuspecting external commands with interactive+mode - if read from terminal is non-blocking also write to terminal is+non-blocking.+-}+withoutNonBlock x =+    do nb <- queryFdOption stdInput NonBlockingRead+       if nb+          then bracket+                   (do setFdOption stdInput NonBlockingRead False)+                   (\_ -> setFdOption stdInput NonBlockingRead True)+                   (\_ -> x)+          else do x+#else+withoutNonBlock x = do x+#endif++{-+Ensure that we exit 127 if the thing we are trying to run does not exist+(Only needed under Windows)+-}+withExit127 :: IO ExitCode -> IO ExitCode+#ifdef WIN32+withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)++notFoundError :: Exception -> Maybe ()+notFoundError (IOException e) | "runProcess: does not exist" `isInfixOf` show e = Just ()+notFoundError _ = Nothing+#else+withExit127 = id+#endif
+ src/HTTP.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module HTTP( fetchUrl, postUrl, request_url, wait_next_url ) where++import Darcs.Global ( debugFail )++#ifdef HAVE_HTTP+import Control.Monad ( when )+import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+import Network.HTTP+import Network.URI+import System.Environment ( getEnv )+import System.IO.Error ( ioeGetErrorString )+import System.IO.Unsafe ( unsafePerformIO )+import Darcs.Global ( debugMessage )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+#endif++fetchUrl :: String -> IO String+postUrl+    :: String     -- ^ url+    -> String     -- ^ body+    -> String     -- ^ mime type+    -> IO ()  -- ^ result++request_url :: String -> FilePath -> a -> IO String+wait_next_url :: IO (String, String)++#ifdef HAVE_HTTP++headers :: [Header]+headers =  [Header HdrUserAgent $ "darcs-HTTP/" ++ PACKAGE_VERSION]++fetchUrl url = case parseURI url of+    Nothing -> fail $ "Invalid URI: " ++ url+    Just uri -> do debugMessage $ "Fetching over HTTP:  "++url+                   proxy <- getProxy+                   when (not $ null proxy) $+                     debugFail "No proxy support for HTTP package yet (try libcurl)!"+                   resp <- simpleHTTP $ Request { rqURI = uri,+                                                  rqMethod = GET,+                                                  rqHeaders = headers,+                                                  rqBody = "" }+                   case resp of+                     Right res@Response { rspCode = (2,0,0) } -> return (rspBody res)+                     Right Response { rspCode = (x,y,z) } ->+                         debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri+                     Left err -> debugFail $ show err++postUrl url body mime = case parseURI url of+    Nothing -> fail $ "Invalid URI: " ++ url+    Just uri -> do debugMessage $ "Posting to HTTP:  "++url+                   proxy <- getProxy+                   when (not $ null proxy) $+                     debugFail "No proxy support for HTTP package yet (try libcurl)!"+                   resp <- simpleHTTP $ Request { rqURI = uri,+                                                  rqMethod = POST,+                                                  rqHeaders = headers ++ [Header HdrContentType mime,+                                                                          Header HdrAccept "text/plain",+                                                                          Header HdrContentLength+                                                                                     (show $ length body) ],+                                                  rqBody = body }+                   case resp of+                     Right res@Response { rspCode = (2,y,z) } -> do+                        putStrLn $ "Success 2" ++ show y ++ show z+                        putStrLn (rspBody res)+                        return ()+                     Right res@Response { rspCode = (x,y,z) } -> do+                        putStrLn $ rspBody res+                        debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri+                     Left err -> debugFail $ show err++requestedUrl :: IORef (String, FilePath)+requestedUrl = unsafePerformIO $ newIORef ("", "")++request_url u f _ = do+  (u', _) <- readIORef requestedUrl+  if null u'+     then do writeIORef requestedUrl (u, f)+             return ""+     else return "URL already requested"++wait_next_url = do+  (u, f) <- readIORef requestedUrl+  if null u+     then return ("", "No URL requested")+     else do writeIORef requestedUrl ("", "")+             e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h+             return (u, e)+    where h = return . ioeGetErrorString++getProxy :: IO String+getProxy =+  getEnv "http_proxy"+  `catch` \_ -> getEnv "HTTP_PROXY"+  `catch` \_ -> return ""+#else++fetchUrl _ = debugFail "Network.HTTP does not exist"+postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP."++request_url _ _ _ = debugFail "Network.HTTP does not exist"+wait_next_url = debugFail "Network.HTTP does not exist"++#endif
+ src/IsoDate.hs view
@@ -0,0 +1,844 @@+-- Copyright (C) 2003 Peter Simons+-- Copyright (C) 2003 David Roundy+--+-- 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.+++module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate,+                 parseDate, getLocalTz,+                 englishDateTime, englishInterval, englishLast,+                 iso8601_interval, iso8601_duration,+                 cleanLocalDate, resetCalendar,+                 MCalendarTime(..), subtractFromMCal, addToMCal,+                 toMCalendarTime, unsafeToCalendarTime,+                 unsetTime, TimeInterval+               ) where++import Text.ParserCombinators.Parsec+import System.Time+import System.IO.Unsafe ( unsafePerformIO )+import Data.Char ( toUpper, isDigit )+import Data.Maybe ( fromMaybe )+import Control.Monad ( liftM, liftM2 )+import qualified Data.ByteString.Char8 as B++type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)++-- | Read/interpret a date string, assuming UTC if timezone+--   is not specified in the string (see 'readDate')+--   Warning! This errors out if we fail to interpret the+--   date+readUTCDate :: String -> CalendarTime+readUTCDate = readDate 0++-- | Convert a date string into ISO 8601 format (yyyymmdd variant)+--   assuming local timezone if not specified in the string+--   Warning! This errors out if we fail to interpret the date+cleanLocalDate :: String -> String+cleanLocalDate = showIsoDateTime . resetCalendar+                 . readDate (unsafePerformIO getLocalTz)++-- | Read/interpret a date string, assuming local timezone if not+--   specified in the string+readLocalDate :: String -> CalendarTime+readLocalDate = readDate (unsafePerformIO getLocalTz)++-- | Return the local timezone offset from UTC in seconds+getLocalTz :: IO Int+getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)++-- | Parse a date string with 'parseDate'+--   Warning! This errors out if we fail to interpret the date+--   Uses its first argument as the default time zone.+readDate :: Int -> String -> CalendarTime+readDate tz d =+             case parseDate tz d of+             Left e -> error $ "bad date: "++d++" - "++show e+             Right ct -> resetCalendar $ unsafeToCalendarTime ct++-- | Parse a date string, assuming a default timezone if+--   the date string does not specify one.  The date formats+--   understood are those of 'showIsoDateTime' and 'date_time'+parseDate :: Int -> String -> Either ParseError MCalendarTime+parseDate tz d =+              if length d >= 14 && B.all isDigit bd+              then Right $ toMCalendarTime $+                   CalendarTime (readI $ B.take 4 bd)+                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)+                                (readI $ B.take 2 $ B.drop 6 bd) -- Day+                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour+                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute+                                (readI $ B.take 2 $ B.drop 12 bd) -- Second+                                0 Sunday 0 -- Picosecond, weekday and day of year unknown+                                "GMT" 0 False+              else let dt = do { x <- date_time tz; eof; return x }+                   in parse dt "" d+  where bd = B.pack (take 14 d)+        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)++-- | Display a 'CalendarTime' in the ISO 8601 format without any+--   separators, e.g. 20080825142503+showIsoDateTime :: CalendarTime -> String+showIsoDateTime ct = concat [ show $ ctYear ct+                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct+                            , twoDigit . show $ ctDay ct+                            , twoDigit . show $ ctHour ct+                            , twoDigit . show $ ctMin ct+                            , twoDigit . show $ ctSec ct+                            ]+    where twoDigit []          = undefined+          twoDigit x@(_:[])    = '0' : x+          twoDigit x@(_:_:[])  = x+          twoDigit _           = undefined++-- | The current time in the format returned by 'showIsoDateTime'+getIsoDateTime          :: IO String+getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime++----- Parser Combinators ---------------------------------------------++-- | Case-insensitive variant of Parsec's 'char' function.+caseChar        :: Char -> GenParser Char a Char+caseChar c       = satisfy (\x -> toUpper x == toUpper c)++-- | Case-insensitive variant of Parsec's 'string' function.+caseString      :: String -> GenParser Char a ()+caseString cs    = mapM_ caseChar cs <?> cs++-- | Match a parser at least @n@ times.+manyN           :: Int -> GenParser a b c -> GenParser a b [c]+manyN n p+    | n <= 0     = return []+    | otherwise  = liftM2 (++) (count n p) (many p)++-- | Match a parser at least @n@ times, but no more than @m@ times.+manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]+manyNtoM n m p+    | n < 0      = return []+    | n > m      = return []+    | n == m     = count n p+    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))+    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)+++----- Date/Time Parser -----------------------------------------------++-- | Try each of these date parsers in the following order+--+--    (1) 'cvs_date_time'+--+--    (2) 'iso8601_date_time'+--+--    (3) 'old_date_time+date_time :: Int -> CharParser a MCalendarTime+date_time tz =+            choice [try $ toMCalendarTime `fmap` cvs_date_time tz,+                    try $ iso8601_date_time tz,+                    toMCalendarTime `fmap` old_date_time]++-- | CVS-style date/times, e.g.+--   2007/08/25 14:25:39 GMT+--   Note that time-zones are optional here.+cvs_date_time :: Int -> CharParser a CalendarTime+cvs_date_time tz =+                do y <- year+                   char '/'+                   mon <- month_num +                   char '/'+                   d <- day+                   my_spaces+                   h <- hour+                   char ':'+                   m <- minute+                   char ':'+                   s <- second+                   z <- option tz $ my_spaces >> zone+                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)++-- | \"Old\"-style dates, e.g.+--   Tue Jan 3 14:08:07 EST 1999+-- darcs-doc: Question (what does the "old" stand for really?)+old_date_time   :: CharParser a CalendarTime+old_date_time    = do wd <- day_name+                      my_spaces+                      mon <- month_name+                      my_spaces+                      d <- day+                      my_spaces+                      h <- hour+                      char ':'+                      m <- minute+                      char ':'+                      s <- second+                      my_spaces+                      z <- zone+                      my_spaces+                      y <- year+                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)++-- | ISO 8601 dates and times.  Please note the following flaws:+--+--   I am reluctant to implement:+--+--      * years > 9999+--+--      * truncated representations with implied century (89 for 1989) +--+--   I have not implemented:+--+--      * repeated durations (not relevant)+--+--      * lowest order component fractions in intervals+--+--      * negative dates (BC)+--+--   I have not verified or have left too relaxed:+--+--      * the difference between 24h and 0h+--+--      * allows stuff like 2005-1212; either you use the hyphen all the way +--        (2005-12-12) or you don't use it at all (20051212), but you don't use+--        it halfway, likewise with time+--+--      * No bounds checking whatsoever on intervals!+--        (next action: read iso doc to see if bounds-checking required?) -}+iso8601_date_time   :: Int -> CharParser a MCalendarTime+iso8601_date_time localTz = try $ +  do d <- iso8601_date+     t <- option id $ try $ do optional $ oneOf " T" +                               iso8601_time  +     return $ t $ d { mctTZ = Just localTz }++-- | Three types of ISO 8601 date:+--+--     * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997+--+--     * week+day in year, e.g.,  1997-W32-4+--+--     * day in year, e.g, 1997-273+iso8601_date :: CharParser a MCalendarTime+iso8601_date = +  do d <- calendar_date <|> week_date <|> ordinal_date+     return $ foldr ($) nullMCalendar d+  where +    calendar_date = -- yyyy-mm-dd+      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]+               -- allow other variants to be parsed correctly +               notFollowedBy (digit <|> char 'W')+               return d+    week_date = --yyyy-Www-d+      try $ do yfn <- year_+               optional dash+               char 'W'+               -- offset human 'week 1' -> computer 'week 0'+               w'  <- (\x -> x-1) `liftM` two_digits+               mwd  <- option Nothing $ do { optional dash; Just `fmap` n_digits 1 }+               let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }+                   firstDay = ctWDay y+               -- things that make this complicated+               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday+               -- 2. the first week is the one that contains at least Thursday+               --    if the year starts after Thursday, then some days of the year+               --    will have already passed before the first week+               let afterThursday = firstDay == Sunday || firstDay > Thursday+                   w  = if afterThursday then w'+1 else w'+                   yday = (7 * w) + fromMaybe 1 mwd+                   diff c = c { mctWeek = True+                              , mctWDay = toEnum `fmap` mwd+                              , mctDay  = Just yday }+               return [(diff.yfn)]+    ordinal_date = -- yyyy-ddd+      try $ optchain year_ [ (dash, yearDay_) ]+    --+    year_  = try $ do y <- four_digits <?> "year (0000-9999)"+                      return $ \c -> c { mctYear = Just y }+    month_ = try $ do m <- two_digits <?> "month (1 to 12)"+                      return $ \c -> c { mctMonth = Just $ intToMonth m }+    day_   = try $ do d <- two_digits <?> "day in month (1 to 31)"+                      return $ \c -> c { mctDay = Just d }+    yearDay_ = try $ do d <- n_digits 3 <?> "day in year (001 to 366)"+                        return $ \c -> c { mctDay = Just d+                                         , mctYDay = Just (d - 1) }+    dash = char '-'++-- | Note that this returns a function which sets the time on+--   another calendar (see 'iso8601_date_time' for a list of+--   flaws+iso8601_time :: CharParser a (MCalendarTime -> MCalendarTime)+iso8601_time = try $+  do ts <- optchain hour_ [ (colon     , min_)+                          , (colon     , sec_)+                          , (oneOf ",.", pico_) ] +     z  <- option id $ choice [ zulu , offset ]+     return $ foldr (.) id (z:ts)+  where +    hour_ = do h <- two_digits+               return $ \c -> c { mctHour = Just h }+    min_  = do m <- two_digits+               return $ \c -> c { mctMin = Just m }+    sec_  = do s <- two_digits+               return $ \c -> c { mctSec = Just s }+    pico_ = do digs <- many digit+               let picoExp = 12+                   digsExp = length digs+               let frac | null digs = 0+                        | digsExp > picoExp = read $ take picoExp digs+                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)+               return $ \c -> c { mctPicosec = Just $ frac }+    zulu   = do { char 'Z'; return (\c -> c { mctTZ = Just 0 }) }+    offset = do sign <- choice [ do { char '+' >> return   1  }+                               , do { char '-' >> return (-1) } ]+                h <- two_digits+                m <- option 0 $ do { optional colon; two_digits }+                return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }+    colon = char ':'++-- | Intervals in ISO 8601, e.g.,+--+--    * 2008-09/2012-08-17T16:30+--+--    * 2008-09/P2Y11MT16H30M+--+--    * P2Y11MT16H30M/2012-08-17T16:30+--+--   See 'iso8601_duration'+iso8601_interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))+iso8601_interval localTz = leftDur <|> rightDur where+  leftDur  = +    do dur <- iso8601_duration +       end <- option Nothing $ do { char '/'; Just `liftM` isoDt }+       return $ case end of +                Nothing -> Left dur+                Just e  -> Right (dur `subtractFromMCal` e, e)+  rightDur =+    do start <- isoDt+       char '/'+       durOrEnd <- Left `liftM` iso8601_duration <|> Right `liftM` isoDt+       return $ case durOrEnd of+                Left dur  -> Right (start, dur `addToMCal` start)+                Right end -> Right (start, end)+  isoDt   = iso8601_date_time localTz+   +-- | Durations in ISO 8601, e.g.,+--+--    * P4Y (four years)+--+--    * P5M (five months)+--+--    * P4Y5M (four years and five months)+--+--    * P4YT3H6S (four years, three hours and six seconds)+iso8601_duration :: CharParser a TimeDiff+iso8601_duration = +  do char 'P'+     y   <- block 0 'Y'+     mon <- block 0 'M'+     d   <- block 0 'D'+     (h,m,s) <- option (0,0,0) $ +       do char 'T'+          h' <- block (-1) 'H'+          m' <- block (-1) 'M'+          s' <- block (-1) 'S'+          let unset = (== (-1))+          if all unset [h',m',s'] +             then fail "T should be omitted if time is unspecified"+             else let clear x = if (unset x) then 0 else x+                  in return (clear h', clear m', clear s')+     --+     return $ TimeDiff y mon d h m s 0+  where block d c = option d $ try $+          do n <- many1 digit+             char c +             return $ read n++-- | 'optchain' @p xs@ parses a string with the obligatory+--   parser @p@.  If this suceeds, it continues on to the+--   rest of the input using the next parsers down the+--   chain.  Each part of the chain consists of a parser+--   for a separator and for the content itself.  The+--   separator is optional.+--+--   A good use of this function is to help in parsing ISO+--   ISO 8601 dates and times.  For example, the parser+--   @optchain year [(dash, month), (dash, day)]@ accepts+--   dates like 2007 (only the year is used), 2007-07 (only+--   the year and month), 200707 (only the year and month+--   with no separator), 2007-07-19 (year, month and day).+optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]+optchain p next = try $ +  do r1 <- p+     r2 <- case next of +           [] -> return []+           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }+     return (r1:r2)++n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit++two_digits, four_digits :: CharParser a Int+two_digits = n_digits 2+four_digits = n_digits 4++-- | One or more space.+--   WARNING! This only matches on the space character, not on+--   whitespace in general+my_spaces :: CharParser a String+my_spaces = manyN 1 $ char ' '++-- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)+day_name        :: CharParser a Day+day_name         = choice+                       [ caseString "Mon"       >> return Monday+                       , try (caseString "Tue") >> return Tuesday+                       , caseString "Wed"       >> return Wednesday+                       , caseString "Thu"       >> return Thursday+                       , caseString "Fri"       >> return Friday+                       , try (caseString "Sat") >> return Saturday+                       , caseString "Sun"       >> return Sunday+                       ]++-- | Four-digit year+year            :: CharParser a Int+year             = four_digits++-- | One or two digit month (e.g. 3 for March, 11 for November)+month_num       :: CharParser a Month+month_num = do mn <- manyNtoM 1 2 digit +               return $ intToMonth $ (read mn :: Int)++-- | January is 1, February is 2, etc+intToMonth :: Int -> Month+intToMonth 1 = January+intToMonth 2 = February+intToMonth 3 = March+intToMonth 4 = April+intToMonth 5 = May+intToMonth 6 = June+intToMonth 7 = July+intToMonth 8 = August+intToMonth 9 = September+intToMonth 10 = October+intToMonth 11 = November+intToMonth 12 = December+intToMonth _  = error "invalid month!"++-- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)+month_name      :: CharParser a Month+month_name       = choice+                       [ try (caseString "Jan") >> return January+                       , caseString "Feb"       >> return February+                       , try (caseString "Mar") >> return March+                       , try (caseString "Apr") >> return April+                       , caseString "May"       >> return May+                       , try (caseString "Jun") >> return June+                       , caseString "Jul"       >> return July+                       , caseString "Aug"       >> return August+                       , caseString "Sep"       >> return September+                       , caseString "Oct"       >> return October+                       , caseString "Nov"       >> return November+                       , caseString "Dec"       >> return December+                       ]++-- | day in one or two digit notation+day             :: CharParser a Int+day              = do d <- manyNtoM 1 2 digit+                      return (read d :: Int)++-- | hour in two-digit notation+hour            :: CharParser a Int+hour             = two_digits++-- | minute in two-digit notation+minute          :: CharParser a Int+minute           = two_digits++-- | second in two-digit notation+second          :: CharParser a Int+second           = two_digits++-- | limited timezone support+--+--   * +HHMM or -HHMM+--+--   * Universal timezones: UTC, UT+--+--   * Zones from GNU coreutils/lib/getdate.y, less half-hour ones --+--     sorry Newfies.+--+--   * any sequence of alphabetic characters (WARNING! treated as 0!)+zone            :: CharParser a Int+zone             = choice+                       [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }+                       , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }+                       , mkZone "UTC"  0+                       , mkZone "UT"  0+                       , mkZone "GMT" 0+                       , mkZone "WET" 0+                       , mkZone "WEST" 1+                       , mkZone "BST" 1+                       , mkZone "ART" (-3)+                       , mkZone "BRT" (-3)+                       , mkZone "BRST" (-2)+                       , mkZone "AST" (-4)+                       , mkZone "ADT" (-3)+                       , mkZone "CLT" (-4)+                       , mkZone "CLST" (-3)+                       , mkZone "EST" (-5)+                       , mkZone "EDT" (-4)+                       , mkZone "CST" (-6)+                       , mkZone "CDT" (-5)+                       , mkZone "MST" (-7)+                       , mkZone "MDT" (-6)+                       , mkZone "PST" (-8)+                       , mkZone "PDT" (-7)+                       , mkZone "AKST" (-9)+                       , mkZone "AKDT" (-8)+                       , mkZone "HST" (-10)+                       , mkZone "HAST" (-10)+                       , mkZone "HADT" (-9)+                       , mkZone "SST" (-12)+                       , mkZone "WAT" 1+                       , mkZone "CET" 1+                       , mkZone "CEST" 2+                       , mkZone "MET" 1+                       , mkZone "MEZ" 1+                       , mkZone "MEST" 2+                       , mkZone "MESZ" 2+                       , mkZone "EET" 2+                       , mkZone "EEST" 3+                       , mkZone "CAT" 2+                       , mkZone "SAST" 2+                       , mkZone "EAT" 3+                       , mkZone "MSK" 3+                       , mkZone "MSD" 4+                       , mkZone "SGT" 8+                       , mkZone "KST" 9+                       , mkZone "JST" 9+                       , mkZone "GST" 10+                       , mkZone "NZST" 12+                       , mkZone "NZDT" 13+                         -- if we don't understand it, just give a GMT answer...+                       , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])+                                       (lookAhead space_digit);+                              return 0 }+                       ]+     where mkZone n o  = try $ do { caseString n; return (o*60*60) }+           space_digit = try $ do { char ' '; oneOf ['0'..'9'] }++----- English dates and intervals -----------------------------------------------++-- | In English, either a date followed by a time, or vice-versa, e.g,+--+--    * yesterday at noon+--+--    * yesterday tea time+--+--    * 12:00 yesterday+--+--   See 'englishDate' and 'englishTime'+--   Uses its first argument as "now", i.e. the time relative to which+--   "yesterday", "today" etc are to be interpreted+englishDateTime :: CalendarTime -> CharParser a CalendarTime+englishDateTime now = +  try $ dateMaybeAtTime <|> timeThenDate      +  where +   -- yesterday (at) noon+   dateMaybeAtTime = try $ +     do ed <- englishDate now+        t  <- option Nothing $ try $+                do { space; optional $ caseString "at "; Just `liftM` englishTime }+        return $ fromMaybe id t $ ed+   -- tea time 2005-12-04+   timeThenDate = try $+     do t  <- englishTime +        optional $ char ','+        space+        ed <- englishDate now+        return $ t $ unsetTime $ ed++-- | Specific dates in English as specific points of time, e.g,+--+--    * today+--+--    * yesterday+--+--    * last week (i.e. the beginning of that interval)+--+--    * 4 months ago (via 'englishAgo')+--+--   The first argument is "now".+englishDate :: CalendarTime -> CharParser a CalendarTime+englishDate now = try $ +      (caseString "today"     >> (return $ resetCalendar now))+  <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) )+  <|> fst `fmap` englishLast now+  <|> englishAgo now+  where oneDay    = TimeDiff 0 0 1 0 0 0 0++-- | English expressions for points in the past, e.g.+--+--    * 4 months ago+--+--    * 1 day ago+--+--    * day before yesterday+--+--   See 'englishDuration'+englishAgo :: CalendarTime -> CharParser a CalendarTime+englishAgo now =+  try $ do p <- englishDuration+           try $ do space+           (m,ref) <- (try $ caseString "ago" >> return ((-1), now))+                   <|> do m <- beforeMod <|> afterMod+                          space+                          d <- englishDate now+                               <|> fst `fmap` englishLast now+                               <|> unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now)+                          return (m,d)+           return $ multiplyDiff m p `addToCal` ref+  where+    beforeMod = try $ caseString "before" >> return (-1)+    afterMod  = try $ caseString "after"  >> return 1++-- | English expressions for intervals of time,+--+--    * before tea time (i.e. from the beginning of time)+--+--    * after 14:00 last month (i.e. till now)+--+--    * between last year and last month+--+--    * in the last three months (i.e. from then till now)+--+--    * 4 months ago (i.e. till now; see 'englishAgo')+englishInterval :: CalendarTime -> CharParser a TimeInterval+englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc+  where +   englishDT = (unsafeToCalendarTime `fmap` iso8601_date_time (ctTZ now)+                <|> englishDateTime now)+   before = try $+     do caseString "before"+        space+        end <- englishDT +        return (Just theBeginning, Just end)+   after = try $+     do caseString "after"+        space+        start <- englishDT+        return (Just start, Nothing)+   twixt = try $ +     do caseString "between"+        space+        start <- englishDT+        space+        caseString "and" +        space+        end <- englishDT +        return (Just start, Just end)+   inTheLast = try $+     do caseString "in the last"+        space+        dur <- englishDuration+        return (Just $ dur `subtractFromCal` now, Just now)+   lastetc =+     do l <- englishAgo now+        return (Just l, Just now)++-- | Durations in English that begin with the word \"last\",+--   E.g. \"last 4 months\" is treated as the duration between+--   4 months ago and now+englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)+englishLast now =+    -- last year, last week, last 3 years, etc+    try $ do caseString "last"+             space+             d <- englishDuration+             return (d `subtractFromCal` now, now)++-- | Either an 'iso8601_time' or one of several common+--   English time expressions like 'noon' or 'tea time'+englishTime :: CharParser a (CalendarTime->CalendarTime)+englishTime = try $ +  choice [ wrapM `fmap` iso8601_time+         , namedTime "noon"            12  0 +         , namedTime "midnight"         0  0+         , namedTime "tea time"        16 30+         , namedTime "bed time"         2 30    +         , namedTime "proper bed time" 21 30 ]+  where namedTime name h m = try $ +          do caseString name+             return $ \c -> c { ctHour = h, ctMin = m }+        wrapM f = unsafeToCalendarTime . f . toMCalendarTime++-- | Some English durations, e.g.+--+--    * day+--+--    * 4 score+--+--    * 7 years+--+--    * 12 months+--+-- This is not particularly strict about what it accepts.+-- For example, "7 yeares", "4 scores" or "1 days" are+-- just fine.+englishDuration :: CharParser a TimeDiff+englishDuration = try $+  do n <- option 1 $ do { x <- many1 digit; space; (return $ read x) }+     b <- base+     optional (caseString "es" <|> caseString "s")+     let current = multiplyDiff n b+     next <- option noTimeDiff $ try $ do +              { optional space; char ',' ; optional space ; englishDuration }+     return $ addDiff current next +  where +  base = choice +         [ try $ caseString "score"      >> (return $ TimeDiff 20 0  0 0 0 0 0) -- why not?+         ,       caseString "year"       >> (return $ TimeDiff  1 0  0 0 0 0 0)+         , try $ caseString "month"      >> (return $ TimeDiff  0 1  0 0 0 0 0)+         ,       caseString "fortnight"  >> (return $ TimeDiff  0 0 14 0 0 0 0)+         ,       caseString "week"       >> (return $ TimeDiff  0 0  7 0 0 0 0)+         ,       caseString "day"        >> (return $ TimeDiff  0 0  1 0 0 0 0)+         ,       caseString "hour"       >> (return $ TimeDiff  0 0  0 1 0 0 0)+         ,       caseString "minute"     >> (return $ TimeDiff  0 0  0 0 1 0 0) +         ,       caseString "second"     >> (return $ TimeDiff  0 0  0 0 0 1 0) ]+   +----- Calendar and TimeDiff manipulation ---------------------------------------------++-- | The very beginning of time, i.e. 1970-01-01+theBeginning :: CalendarTime+theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0++-- | An 'MCalenderTime' is an underspecified 'CalendarTime'+--   It is used for parsing dates.  For example, if you want to parse+--   the date '4 January', it may be useful to underspecify the year+--   by setting it to 'Nothing'.  This uses almost the same fields as+--   'System.Time.CalendarTime', a notable exception being that we+--   introduce 'mctWeek' to indicate if a weekday was specified or not+data MCalendarTime = MCalendarTime+ { mctYear  :: Maybe Int+ , mctMonth :: Maybe Month+ , mctDay   :: Maybe Int+ , mctHour  :: Maybe Int+ , mctMin   :: Maybe Int+ , mctSec   :: Maybe Int+ , mctPicosec :: Maybe Integer+ , mctWDay     :: Maybe Day+ , mctYDay     :: Maybe Int+ , mctTZName   :: Maybe String+ , mctTZ       :: Maybe Int+ , mctIsDST    :: Maybe Bool+ , mctWeek     :: Bool -- is set or not+} deriving Show++-- | Trivially convert a 'CalendarTime' to a fully specified+--   'MCalendarTime' (note that this sets the 'mctWeek' flag to+--   @False@+toMCalendarTime :: CalendarTime -> MCalendarTime+toMCalendarTime (CalendarTime a b c d e f g h i j k l) =+  MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)+                (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)+                False++-- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'+--   This is only unsafe in the sense that it plugs in default values+--   for fields that have not been set, e.g. @January@ for the month+--   or @0@ for the seconds field.+--   Maybe we should rename it something happier.+--   See also 'resetCalendar'+unsafeToCalendarTime :: MCalendarTime -> CalendarTime+unsafeToCalendarTime m =+ CalendarTime+  { ctYear = fromMaybe 0 $ mctYear m+  , ctMonth = fromMaybe January $ mctMonth m+  , ctDay = fromMaybe 1 $ mctDay m+  , ctHour = fromMaybe 0 $ mctHour m+  , ctMin = fromMaybe 0 $ mctMin m+  , ctSec = fromMaybe 0 $ mctSec m+  , ctPicosec = fromMaybe 0 $ mctPicosec m+  , ctWDay = fromMaybe Sunday $ mctWDay m+  , ctYDay = fromMaybe 0 $ mctYDay m+  , ctTZName = fromMaybe "" $ mctTZName m+  , ctTZ = fromMaybe 0 $ mctTZ m+  , ctIsDST = fromMaybe False $ mctIsDST m+ }++addToCal :: TimeDiff -> CalendarTime -> CalendarTime+addToCal td = toUTCTime . addToClockTime td . toClockTime++subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime+subtractFromCal = addToCal . multiplyDiff (-1)++addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+addToMCal td mc =+ copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc++subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+subtractFromMCal = addToMCal . multiplyDiff (-1)++-- surely there is a more concise way to express these+addDiff :: TimeDiff -> TimeDiff -> TimeDiff+addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =+  TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)++-- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@+--+-- FIXME; this seems like a terrible idea! it seems like+-- we should get rid of it if at all possible, maybe adding an+-- invertDiff function+multiplyDiff :: Int -> TimeDiff -> TimeDiff+multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =+  TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m))++nullMCalendar :: MCalendarTime+nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              False++-- | Set a calendar to UTC time any eliminate any inconsistencies within+--   (for example, where the weekday is given as @Thursday@, but this does not+--   match what the numerical date would lead one to expect)+resetCalendar :: CalendarTime -> CalendarTime+resetCalendar = toUTCTime . toClockTime++-- | 'copyCalendar' @c mc@ replaces any field which is+--   specified in @mc@ with the equivalent field in @c@+--   @copyCalendar c nullMCalendar == nullMCalendar@+copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime+copyCalendar c mc = mc+  { mctYear  = mctYear mc  >> Just (ctYear c)+  , mctMonth = mctMonth mc >> Just (ctMonth c)+  , mctDay   = mctDay mc   >> Just (ctDay c)+  , mctHour  = mctHour mc  >> Just (ctHour c)+  , mctMin   = mctMin mc   >> Just (ctMin c)+  , mctSec   = mctSec mc   >> Just (ctSec c)+  , mctPicosec = mctPicosec mc >> Just (ctPicosec c)+  , mctWDay = mctWDay mc   >> Just (ctWDay c)+  , mctYDay = mctYDay mc   >> Just (ctYDay c)+  , mctTZName = mctTZName mc >> Just (ctTZName c)+  , mctTZ     = mctTZ mc    >> Just (ctTZ c)+  , mctIsDST  = mctIsDST mc >> Just (ctIsDST c)+  }++-- | Zero the time fields of a 'CalendarTime'+unsetTime :: CalendarTime -> CalendarTime+unsetTime mc = mc+  { ctHour  = 0+  , ctMin   = 0+  , ctSec   = 0+  , ctPicosec = 0+  }
+ src/Lcs.hs view
@@ -0,0 +1,478 @@+-- Copyright (C) 2002 David Roundy+-- Copyright (C) 2005 Benedikt Schmidt+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++-- | LCS stands for Longest Common Subsequence, and it is a relatively+-- challenging problem to find an LCS efficiently.  This module implements+-- the algorithm described in:+--+--   "An O(ND) Difference Algorithm and its Variations", Eugene Myers,+--   Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;+--   especially the variation described in section 4.2 and most refinements+--   implemented in GNU diff (D is the edit-distance).+--+-- There is currently no heuristic to reduce the running time and produce+-- suboptimal output for large inputs with many differences. It behaves like+-- GNU diff with the -d option in this regard.+--+-- In the first step, a hash value for every line is calculated and collisions+-- are marked with a special value. This reduces a string comparison to an+-- int comparison for line tuples where at least one of the hash values is+-- not equal to the special value. After that, lines which only exists in one+-- of the files are removed and marked as changed which reduces the running+-- time of the following difference algorithm. GNU diff additionally removes+-- lines that appear very often in the other file in some cases.+-- The last step tries to create longer changed regions and line up deletions+-- in the first file to insertions in the second by shifting changed lines+-- forward and backward.+module Lcs ( getChanges, aLen,+             BArray, PArray, BSTArray,+             shiftBoundaries ) where++import Control.Monad+import Data.Int+import Control.Monad.ST+import Data.Maybe+import ByteStringUtils (hashPS)+import qualified Data.ByteString as B (empty, ByteString)+import Data.Array.Base+import Data.Array.Unboxed+import qualified Data.Map as Map ( lookup, empty, insertWith )+#include "impossible.h"++-- | create a list of changes between a and b, each change has the form+--   (starta, lima, startb, limb) which means that a[starta, lima)+--   has to be replaced by b[startb, limb)+getChanges ::  [B.ByteString] -> [B.ByteString]+           -> [(Int,[B.ByteString],[B.ByteString])]+getChanges a b = dropStart (initP a) (initP b) 1++dropStart ::  PArray -> PArray -> Int+           -> [(Int,[B.ByteString],[B.ByteString])]+dropStart a b off+  | off > (aLen a) = [(off - 1, [], getSlice b off (aLen b))]+  | off > (aLen b) = [(off - 1, getSlice a off (aLen a), [])]+  | a!off == b!off = dropStart a b (off + 1)+  | otherwise      = dropEnd a b off 0++dropEnd ::  PArray -> PArray -> Int -> Int+        -> [(Int,[B.ByteString],[B.ByteString])]+dropEnd a b off end+    | off > alast        = [(off - 1, [], getSlice b off blast)]+    | off > blast        = [(off - 1, getSlice a off alast, [])]+    | a!alast == b!blast = dropEnd a b off (end + 1)+    | otherwise          = getChanges' (a, (off, alast)) (b, (off, blast))+  where alast = aLen a - end+        blast = aLen b - end++getSlice :: PArray -> Int -> Int -> [B.ByteString]+getSlice a from to+  | from > to = []+  | otherwise = (a!(from)):(getSlice a (from + 1) to)++getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int))+            -> [(Int,[B.ByteString],[B.ByteString])]+getChanges' (a, abounds) (b, bbounds) =+    map (convertPatch 0 a b) $ createPatch c_a c_b+  where+        -- If the last few characters of two lines are the same, the lines are+        -- probably the same. The choice of 20 is plucked out of the air.+        toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds]+        ah = toHash a abounds :: HArray+        mkAMap m (i:is) =+            let ins (_,_,_,new) (collision,_,_,old) =+                    (collision || not (new == old), True, False, old)+                m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m+            in mkAMap m' is+        mkAMap m _ = m+        hm_a = mkAMap Map.empty (range abounds)+        --+        bh = toHash b bbounds :: HArray+        mkBMap m (i:is) =+            let ins (_,_,_,new) (collision,in_a,_,old) =+                    (collision || not (new == old), in_a, True, old)+                m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m+            in mkBMap m' is+        mkBMap m _ = m+        hm = mkBMap hm_a (range bbounds)+        -- take care of collisions, if there are different lines with the+        -- same hash in both files, then set the hash to markColl,+        -- PackedStrings are compared for two lines with the hash markColl+        get (i, h) = case Map.lookup h hm of+                      Just (_,False,_,_) -> Nothing+                      Just (_,_,False,_) -> Nothing+                      Just (False,True,True,_) -> Just (i, h)+                      Just (True,True,True,_) -> Just (i, markColl)+                      Nothing -> impossible++        a' = catMaybes $ map get [(i, ah!i) | i <- range (bounds ah)]+        b' = catMaybes $ map get [(i, bh!i) | i <- range (bounds bh)]++        (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds)++-- | mark hash value where collision occured+markColl :: Int32+markColl = 2345677++-- | return arrays with changes in a and b (1 indexed), offsets start with 0+diffArr :: [(Int,Int32)] -> [(Int,Int32)]+        -> (PArray, (Int, Int)) -> (PArray, (Int, Int))+        -> (BArray, BArray)+diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST (+  do let h_a = initH (map snd a)+         h_b = initH (map snd b)+         m_a = initM (map fst a)+         m_b = initM (map fst b)+         end_a = (aLen p_a)+         end_b = (aLen p_b)+     c_a <- initVChanged end_a+     c_b <- initVChanged end_b+     mapM_ (\ (l,_) -> writeArray c_a l False) $ a+     mapM_ (\ (l,_) -> writeArray c_b l False) $ b+     _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)+     let unchanged ar = do {xs <- getElems ar; return $ (length $ filter not $ xs) -1}+     err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+     when (err) impossible+     -- Mark common lines at beginning and end+     mapM_ (\ i -> writeArray c_a i False ) $ [1..(off_a - 1)]+     mapM_ (\ i -> writeArray c_b i False ) $ [1..(off_b - 1)]+     mapM_ (\ i -> writeArray c_a i False ) $ [(l_a + 1) .. (end_a)]+     mapM_ (\ i -> writeArray c_b i False ) $ [(l_b + 1) .. (end_b)]+     shiftBoundaries c_a c_b p_a 1 1+     shiftBoundaries c_b c_a p_b 1 1+     err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+     when (err1) impossible+     c_a' <- unsafeFreeze c_a+     c_b' <- unsafeFreeze c_b+     return (c_a', c_b'))++-- | set changes array for a and b and return number of changed lines+cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+       -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int+cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = do return 0+cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do+  let lim_a = off_a+l_a+      lim_b = off_b+l_b+      off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b+      off_b' = off_b+off_a'-off_a+      lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b'+      lim_b' = lim_b+lim_a'-lim_a+      l_a' = lim_a'-off_a'+      l_b' = lim_b'-off_b'+  if l_a' == 0 || l_b' == 0+     then if l_a' == 0+             then do when (l_b' > 0) $+                          mapM_ (\i -> writeArray c_b (m_b!i) True)+                                [(off_b' + 1) .. lim_b']+                     return l_b'+             else do when (l_a' > 0) $+                          mapM_ (\i -> writeArray c_a (m_a!i) True)+                                [(off_a' + 1) .. lim_a']+                     return l_a'+     else do let m = l_a' + l_b'+                 del = l_a' - l_b'+                 dodd = odd $ del+             v <- initV m+             vrev <- initVRev m l_a'+             writeArray vrev 0 l_a'+             writeArray v 0 0+             (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev+                                off_a' off_b' l_a' l_b' del dodd+             when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')+                   || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b')) +                     impossible+             c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+                          off_a' off_b' xmid ymid+             c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+                          (off_a' + xmid) (off_b' + ymid)+                          (l_a' - xmid) (l_b' - ymid)+             return $ c1 + c2++-- | return (xmid, ymid, cost) for the two substrings+--   a[off_a+1..off_a+1+l_a] and b+findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+         -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool+         -> ST s (Int, Int, Int)+findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do+  if c > l_a + l_b then error "findDiag failed" else return ()+  r <- findF+  case r of+    Just (xmid, ymid) -> return (xmid, ymid, (c*2 - 1))+    Nothing ->+      do r' <- findR+         case r' of+           Just (xmid, ymid) -> return (xmid, ymid, c*2)+           Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev+                      off_a off_b l_a l_b del dodd+ where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2)+       rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2)+       lastrdmax = if (c-1) <= l_b then c-1 else l_b-((l_b + (c-1) `mod` 2))+       lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2))+       fdmin = -rdmax+       rdmin = -fdmax+       findF = findF' fdmax+       findR = findR' rdmax+       findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b+                     if dodd && d - del >= lastrdmin && d - del <= lastrdmax+                        then do xr <- readArray vrev (d - del)+                                if xr <= x then return $ Just (x, x - d)+                                           else if d <= fdmin then return Nothing+                                                              else findF' (d-2)+                        else if d <= fdmin then return Nothing else findF' (d-2)+       findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b+                     if not dodd && (d + del >= fdmin) && (d + del <= fdmax)+                        then do xf <- readArray v (d + del)+                                if x <= xf then return $ Just (x,x-del-d)+                                           else if d <= rdmin then return Nothing+                                                              else findR' (d-2)+                        else if d <= rdmin then return Nothing else findR' (d-2)++-- | find position on diag d with one more insert/delete going forward+findOne  :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+         -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int +findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do+  x0 <- do xbelow <- readArray v (d - 1)+           xover <- readArray v (d + 1)+           return $ if xover > xbelow then xover else xbelow + 1+  let y0 = x0 - d+      x = findSnake h_a h_b p_a p_b  m_a m_b (x0+off_a) (y0+off_b)+            l_a l_b off_a off_b+  writeArray v d (x - off_a)+  return (x-off_a)++-- | follow snake from northwest to southeast, x and y are absolute positions+findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+          -> Int -> Int -> Int -> Int -> Int -> Int -> Int+findSnake h_a h_b p_a p_b  m_a m_b x y l_a l_b off_a off_b =+  if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1)+       && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1)))+     then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b+     else x++-- | find position on diag d with one more insert/delete going backward+findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+           -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int +findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do+  x0 <- do xbelow <- readArray v (d - 1)+           xover <- readArray v (d + 1)+           return $ if xbelow < xover then xbelow else xover-1+  let y0 = x0 - del - d+      x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)+            off_a off_b+  writeArray v d (x-off_a)+  return (x-off_a)++-- | follow snake from southeast to northwest, x and y are absolute positions+findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+             -> Int -> Int -> Int -> Int -> Int+findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b =+  if x > off_a && y > off_b && h_a!x == h_b!y+       && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y))+     then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b+     else x++-- | try to create nicer diffs by shifting around regions of changed lines+shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()+shiftBoundaries c_a c_b p_a i_ j_ =+  do x <- nextChanged c_a i_+     case x of+       Just start ->+             do let skipped = start - i_+                j1 <- nextUnchangedN c_b skipped j_+                end <- nextUnchanged c_a start+                j2 <- nextUnchanged c_b j1+                (i3,j3) <- expand start end j2+                shiftBoundaries c_a c_b p_a i3 j3+       Nothing -> return () -- no change up to end of file+ where noline = (aLen p_a) + 1+       expand start i j =+         do let len = i - start+            (start0,i0,j0) <- shiftBackward start i j+            b <- if j0 > 1 then readArray c_b (j0-1) else return False+            let corr = if b then i0 else noline+            let blank = if p_a!(i0-1) == B.empty then i0+                                               else noline+            (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank+            -- prefer corresponding to ending with blank line+            let newi = if corr1 == noline then blank1+                                          else corr1+            (start2,i2,j2) <- moveCorr start1 i1 j1 newi+            if len /= i2 - start2+                then expand start2 i2 j2+                else return (i2, j2)+       shiftBackward start i j =+         if start > 1 && p_a!(i-1) == p_a!(start-1)+            then do when (i == start) impossible+                    b1 <- readArray c_a (i-1)+                    b2 <- readArray c_a (start-1)+                    when ((not b1) || b2) impossible+                    writeArray c_a (i-1) False+                    writeArray c_a (start-1) True+                    b <- if start > 2 then readArray c_a (start-2)+                                      else return False+                    start' <- if b then liftM (1+) (prevUnchanged c_a (start-2))+                                   else return (start-1)+                    j' <- prevUnchanged c_b (j-1)+                    shiftBackward start' (i-1) j'+            else do return (start,i,j)+       shiftForward start i j corr blank =+         if i <= aLen p_a && p_a!i == p_a!start &&+             -- B.empty at the end of file marks empty line after final newline+             not ((i == aLen p_a) && (p_a!i == B.empty))+            then do when (i == start) impossible+                    b1 <- readArray c_a i+                    b2 <- readArray c_a start+                    when ((not b2) ||  b1) impossible+                    writeArray c_a i True+                    writeArray c_a start False+                    i0 <- nextUnchanged c_a (i+1)+                    j0 <- nextUnchanged c_b (j+1)+                    let corr0 = if i0 > (i+1) then noline+                                              else if j0-j > 2 then i0 else corr+                    let blank0 = if i0 > i+1 then noline+                                 else if p_a!(i0-1) == B.empty then i0+                                                             else blank+                    shiftForward (start+1) i0 j0 corr0 blank0+            else do return (start,i,j,corr,blank)+       moveCorr start i j corr =+         if corr >= i+            then return (start,i,j)+            else do b1 <- readArray c_a (i-1)+                    b2 <- readArray c_a (start-1)+                    when ((not b1) || b2) impossible+                    when (p_a!(i-1) /= p_a!(start-1)) impossible+                    writeArray c_a (i-1) False+                    writeArray c_a (start-1) True       +                    j' <- prevUnchanged c_b (j-1)+                    moveCorr (start-1) (i-1) j' corr++-- | goto next unchanged line, return the given line if unchanged+nextUnchanged :: BSTArray s -> Int -> ST s Int+nextUnchanged c i = do+  len <- aLenM c+  if i == len + 1 then return i+     else do b <- readArray c i+             if b then nextUnchanged c (i+1)+                  else return i++-- | skip at least one unchanged line, if there is none advance+--   behind the last line+skipOneUnChanged :: BSTArray s -> Int -> ST s Int+skipOneUnChanged c i = do+  len <- aLenM c+  if i == len + 1+     then return i+     else do b <- readArray c i+             if not b then return (i+1)+                      else skipOneUnChanged c (i+1)++-- | goto n-th next unchanged line+nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int+nextUnchangedN c n i = do+  if n == 0 then return i+            else do i' <- skipOneUnChanged c i+                    nextUnchangedN c (n-1) i'++-- | goto next changed line, return the given line if changed+nextChanged :: BSTArray s -> Int -> ST s (Maybe Int)+nextChanged c i = do+  len <- aLenM c+  if i <= len+    then do b <- readArray c i+            if not b then nextChanged c (i+1)+                     else return $ Just i+    else return Nothing++-- | goto previous unchanged line, return the given line if unchanged+prevUnchanged :: BSTArray s -> Int -> ST s Int+prevUnchanged c i = do+  b <- readArray c i+  if b then prevUnchanged c (i-1)+       else return i++type HArray = UArray Int Int32+type BArray = UArray Int Bool+type PArray = Array Int B.ByteString+type MapArray = UArray Int Int+type VSTArray s = STUArray s Int Int+type BSTArray s = STUArray s Int Bool++initV :: Int -> ST s (VSTArray s)+initV dmax = do+  newArray (-(dmax + 1), dmax + 1) (-1)++initVRev :: Int -> Int -> ST s (VSTArray s)+initVRev dmax xmax = do+  newArray (-(dmax + 1), dmax + 1) (xmax + 1)++-- 1 indexed, v[0] is used as a guard element+initVChanged :: Int -> ST s (BSTArray s)+initVChanged l = do+  a <- newArray (0, l) True+  writeArray a 0 False+  return a+  -- set to false for all lines which have a mapping later+  -- other lines are only present in one of the files++initH :: [Int32] -> HArray+initH a = listArray (0, length a) (0:a)++initM :: [Int] -> MapArray+initM a = listArray (0, length a) (0:a)++initP :: [B.ByteString] -> PArray+initP a = listArray (0, length a) (B.empty:a)++aLen :: (IArray a e) => a Int e -> Int+aLen a = snd $ bounds a+aLenM :: (MArray a e m) => a Int e -> m Int+aLenM a = getBounds a >>= return . snd++convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int)+             -> (Int,[B.ByteString],[B.ByteString])+convertPatch off a b (a0,a1,b0,b1)+ | b0 == b1 = (b0+off,getDelete a a0 a1,[])+ | a0 == a1 = (b0+off,[],getInsert b b0 b1)+ | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1)++getInsert :: PArray -> Int -> Int -> [B.ByteString]+getInsert b from to+  | from >= to = []+  | otherwise = (b!(from+1)):(getInsert b (from+1) to)+getDelete :: PArray -> Int -> Int -> [B.ByteString]+getDelete a from to+  | from >= to = []+  | otherwise = (a!(from+1)):(getDelete a (from+1) to)++createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)]+createPatch c_a c_b =+  reverse $ createP c_a c_b (aLen c_a) (aLen c_b)++createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)]+createP _ _ 0 0 = []+createP c_a c_b ia ib =+  if c_a!ia || c_b!ib+     then let ia' = skipChangedRev c_a ia+              ib' = skipChangedRev c_b ib+          in (ia',ia,ib',ib):(createP c_a c_b ia' ib')+     else createP c_a c_b (ia-1) (ib-1)++skipChangedRev :: BArray -> Int -> Int+skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i
+ src/OldDate.hs view
@@ -0,0 +1,350 @@+-- Copyright (C) 2003 Peter Simons+-- Copyright (C) 2003,2008 David Roundy+--+-- 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.++-- This module is intended to provide backwards-compatibility in the parsing+-- of darcs patches.  In other words: don't change it, new features don't get+-- added here.  The only user should be Darcs.Patch.Info.++module OldDate ( readUTCDate, showIsoDateTime ) where++import Text.ParserCombinators.Parsec+import System.Time+import Data.Char ( toUpper, isDigit )+import Control.Monad ( liftM, liftM2 )+import qualified Data.ByteString.Char8 as B+import Data.Maybe ( fromMaybe )++-- | Read/interpret a date string, assuming UTC if timezone+--   is not specified in the string+readUTCDate :: String -> CalendarTime+readUTCDate = readDate 0++readDate :: Int -> String -> CalendarTime+readDate tz d =+             case parseDate tz d of+             Left e -> error e+             Right ct -> ct++parseDate :: Int -> String -> Either String CalendarTime+parseDate tz d =+              if length d >= 14 && B.all isDigit bd+              then Right $+                   CalendarTime (readI $ B.take 4 bd)+                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)+                                (readI $ B.take 2 $ B.drop 6 bd) -- Day+                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour+                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute+                                (readI $ B.take 2 $ B.drop 12 bd) -- Second+                                0 Sunday 0 -- Picosecond, weekday and day of year unknown+                                "GMT" 0 False+              else let dt = do { x <- date_time tz; eof; return x }+                   in case parse dt "" d of+                      Left e -> Left $ "bad date: "++d++" - "++show e+                      Right ct -> Right ct+  where bd = B.pack (take 14 d)+        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)++showIsoDateTime :: CalendarTime -> String+showIsoDateTime ct = concat [ show $ ctYear ct+                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct+                            , twoDigit . show $ ctDay ct+                            , twoDigit . show $ ctHour ct+                            , twoDigit . show $ ctMin ct+                            , twoDigit . show $ ctSec ct+                            ]+    where twoDigit []          = undefined+          twoDigit x@(_:[])    = '0' : x+          twoDigit x@(_:_:[])  = x+          twoDigit _           = undefined++----- Parser Combinators ---------------------------------------------++-- |Case-insensitive variant of Parsec's 'char' function.++caseChar        :: Char -> GenParser Char a Char+caseChar c       = satisfy (\x -> toUpper x == toUpper c)++-- |Case-insensitive variant of Parsec's 'string' function.++caseString      :: String -> GenParser Char a ()+caseString cs    = mapM_ caseChar cs <?> cs++-- |Match a parser at least @n@ times.++manyN           :: Int -> GenParser a b c -> GenParser a b [c]+manyN n p+    | n <= 0     = return []+    | otherwise  = liftM2 (++) (count n p) (many p)++-- |Match a parser at least @n@ times, but no more than @m@ times.++manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]+manyNtoM n m p+    | n < 0      = return []+    | n > m      = return []+    | n == m     = count n p+    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))+    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)+++----- Date/Time Parser -----------------------------------------------++date_time :: Int -> CharParser a CalendarTime+date_time tz =+            choice [try $ cvs_date_time tz,+                    try $ iso8601_date_time tz,+                    old_date_time]++cvs_date_time :: Int -> CharParser a CalendarTime+cvs_date_time tz =+                do y <- year+                   char '/'+                   mon <- month_num +                   char '/'+                   d <- day+                   my_spaces+                   h <- hour+                   char ':'+                   m <- minute+                   char ':'+                   s <- second+                   z <- option tz $ my_spaces >> zone+                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)++old_date_time   :: CharParser a CalendarTime+old_date_time    = do wd <- day_name+                      my_spaces+                      mon <- month_name+                      my_spaces+                      d <- day+                      my_spaces+                      h <- hour+                      char ':'+                      m <- minute+                      char ':'+                      s <- second+                      my_spaces+                      z <- zone+                      my_spaces+                      y <- year+                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)++{- FIXME: In case you ever want to use this outside of darcs, you should note +   that this implementation of ISO 8601 is not complete.  ++   reluctant to implement (ambiguous!): +     * years > 9999  +     * truncated representations with implied century (89 for 1989) +   unimplemented: +     * repeated durations (not relevant)+     * lowest order component fractions in intervals+     * negative dates (BC)                    +   unverified or too relaxed:+     * the difference between 24h and 0h+     * allows stuff like 2005-1212; either you use the hyphen all the way +       (2005-12-12) or you don't use it at all (20051212), but you don't use+       it halfway, likewise with time +     * No bounds checking whatsoever on intervals! +       (next action: read iso doc to see if bounds-checking required?) -}+iso8601_date_time   :: Int -> CharParser a CalendarTime+iso8601_date_time localTz = try $ +  do d <- iso8601_date+     t <- option id $ try $ do optional $ oneOf " T" +                               iso8601_time  +     return $ t $ d { ctTZ = localTz }++iso8601_date :: CharParser a CalendarTime+iso8601_date = +  do d <- calendar_date <|> week_date <|> ordinal_date+     return $ foldr ($) nullCalendar d+  where +    calendar_date = -- yyyy-mm-dd+      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]+               -- allow other variants to be parsed correctly +               notFollowedBy (digit <|> char 'W')+               return d+    week_date = --yyyy-Www-dd +      try $ do yfn <- year_+               optional dash+               char 'W'+               -- offset human 'week 1' -> computer 'week 0'+               w'  <- (\x -> x-1) `liftM` two_digits+               wd  <- option 1 $ do { optional dash; n_digits 1 }+               let y = yfn nullCalendar+                   firstDay = ctWDay y+               -- things that make this complicated+               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday+               -- 2. the first week is the one that contains at least Thursday+               --    if the year starts after Thursday, then some days of the year+               --    will have already passed before the first week+               let afterThursday = firstDay == Sunday || firstDay > Thursday+                   w  = if afterThursday then w'+1 else w'+                   diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }+               return [(toUTCTime.toClockTime.diff.yfn)]+    ordinal_date = -- yyyy-ddd+      try $ optchain year_ [ (dash, yearDay_) ]+    --+    year_  = try $ do y <- four_digits <?> "year (0000-9999)"+                      return $ \c -> c { ctYear = y }+    month_ = try $ do m <- two_digits <?> "month (1 to 12)"+                      -- we (artificially) use ctPicosec to indicate+                      -- whether the month has been specified.+                      return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }+    day_   = try $ do d <- two_digits <?> "day in month (1 to 31)"+                      return $ \c -> c { ctDay = d }+    yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"+                        return $ \c -> c { ctYDay = d }+    dash = char '-'++-- we return a function which sets the time on another calendar+iso8601_time :: CharParser a (CalendarTime -> CalendarTime)+iso8601_time = try $+  do ts <- optchain hour_ [ (colon     , min_)+                          , (colon     , sec_)+                          , (oneOf ",.", pico_) ] +     z  <- option id $ choice [ zulu , offset ]+     return $ foldr (.) id (z:ts)+  where +    hour_ = do h <- two_digits+               return $ \c -> c { ctHour = h }+    min_  = do m <- two_digits+               return $ \c -> c { ctMin = m }+    sec_  = do s <- two_digits+               return $ \c -> c { ctSec = s }+    pico_ = do digs <- many digit+               let picoExp = 12+                   digsExp = length digs+               let frac | null digs = 0+                        | digsExp > picoExp = read $ take picoExp digs+                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)+               return $ \c -> c { ctPicosec = frac }+    zulu   = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }+    offset = do sign <- choice [ do { char '+' >> return   1  }+                               , do { char '-' >> return (-1) } ]+                h <- two_digits+                m <- option 0 $ do { optional colon; two_digits }+                return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }+    colon = char ':'++optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]+optchain p next = try $ +  do r1 <- p+     r2 <- case next of +           [] -> return []+           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }+     return (r1:r2)++n_digits :: Int -> CharParser a Int +n_digits n = read `liftM` count n digit++two_digits, four_digits :: CharParser a Int+two_digits = n_digits 2+four_digits = n_digits 4++my_spaces :: CharParser a String+my_spaces = manyN 1 $ char ' '++day_name        :: CharParser a Day+day_name         = choice+                       [ caseString "Mon"       >> return Monday+                       , try (caseString "Tue") >> return Tuesday+                       , caseString "Wed"       >> return Wednesday+                       , caseString "Thu"       >> return Thursday+                       , caseString "Fri"       >> return Friday+                       , try (caseString "Sat") >> return Saturday+                       , caseString "Sun"       >> return Sunday+                       ]++year            :: CharParser a Int+year             = four_digits++month_num       :: CharParser a Month+month_num = do mn <- manyNtoM 1 2 digit +               return $ intToMonth $ (read mn :: Int)++intToMonth :: Int -> Month+intToMonth 1 = January+intToMonth 2 = February+intToMonth 3 = March+intToMonth 4 = April+intToMonth 5 = May+intToMonth 6 = June+intToMonth 7 = July+intToMonth 8 = August+intToMonth 9 = September+intToMonth 10 = October+intToMonth 11 = November+intToMonth 12 = December+intToMonth _  = error "invalid month!"++month_name      :: CharParser a Month+month_name       = choice+                       [ try (caseString "Jan") >> return January+                       , caseString "Feb"       >> return February+                       , try (caseString "Mar") >> return March+                       , try (caseString "Apr") >> return April+                       , caseString "May"       >> return May+                       , try (caseString "Jun") >> return June+                       , caseString "Jul"       >> return July+                       , caseString "Aug"       >> return August+                       , caseString "Sep"       >> return September+                       , caseString "Oct"       >> return October+                       , caseString "Nov"       >> return November+                       , caseString "Dec"       >> return December+                       ]++day             :: CharParser a Int+day              = do d <- manyNtoM 1 2 digit+                      return (read d :: Int)++hour            :: CharParser a Int+hour             = two_digits++minute          :: CharParser a Int+minute           = two_digits++second          :: CharParser a Int+second           = two_digits++zone            :: CharParser a Int+zone             = choice+                       [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }+                       , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }+                       , mkZone "UTC"  0+                       , mkZone "UT"  0+                       , mkZone "GMT" 0+                       , mkZone "EST" (-5)+                       , mkZone "EDT" (-4)+                       , mkZone "CST" (-6)+                       , mkZone "CDT" (-5)+                       , mkZone "MST" (-7)+                       , mkZone "MDT" (-6)+                       , mkZone "PST" (-8)+                       , mkZone "PDT" (-7)+                       , mkZone "CEST" 2+                       , mkZone "EEST" 3+                         -- if we don't understand it, just give a GMT answer...+                       , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])+                                       (lookAhead space_digit);+                              return 0 }+                       ]+     where mkZone n o  = try $ do { caseString n; return (o*60*60) }+           space_digit = try $ do { char ' '; oneOf ['0'..'9'] }++nullCalendar :: CalendarTime +nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False
+ src/Printer.lhs view
@@ -0,0 +1,425 @@++A Document is at heart ShowS from the prelude+\htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS}++Essentially, if you give a Doc a string it'll print out whatever it+wants followed by that string. So \verb!(text "foo")! makes the Doc that+prints \verb!"foo"! followed by its argument. The combinator names are taken+from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is+slightly different.++The advantage of Printer over simple string appending/concatenating is+that the appends end up associating to the right, e.g.:++\begin{verbatim}+  (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""+= \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""+= (text "foo" <> text "bar") ((text "baz" <> text "quux") "")+= (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")+= text "foo" (text "bar" ((text "baz" <> text "quux") ""))+= (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))+= "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))+= "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))+= "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))+= "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))+= "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))+= "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))+\end{verbatim}++The Empty alternative comes in because you want+\begin{verbatim}+    text "a" $$ vcat xs $$ text "b"+\end{verbatim}+(\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be+\verb!"a\nb"! when \verb!xs!  is \verb![]!, but without the concept of an+Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with+\verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two+\verb!'\n'!s).++This code was made generic in the element type by Juliusz Chroboczek.+\begin{code}+module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..),+                hPutDoc,     hPutDocLn,     putDoc,     putDocLn,+                hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith,+                renderString, renderStringWith, renderPS, renderPSWith,+                renderPSs, renderPSsWith, lineColor,+                prefix, insert_before_lastline, colorText, invisibleText, +                hiddenText, hiddenPrefix, userchunk, text,+                printable, wrap_text,+                blueText, redText, greenText, magentaText, cyanText,+                unsafeText, unsafeBoth, unsafeBothText, unsafeChar,+                invisiblePS, packedString, unsafePackedString, userchunkPS,+                simplePrinters, invisiblePrinter, simplePrinter,+                doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat,+                minus, newline, plus, space, backslash, lparen, rparen,+                parens,+                errorDoc,+               ) where++import Data.List (intersperse)+import System.IO (Handle, stdout, hPutStr)+import ByteStringUtils ( linesPS )+import qualified Data.ByteString as B (ByteString, hPut, concat)+import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton)++-- | A 'Printable' is either a String, a packed string, or a chunk of+-- text with both representations.+data Printable = S !String+               | PS !B.ByteString+               | Both !String !B.ByteString++-- | 'space_p' is the 'Printable' representation of a space.+space_p :: Printable+space_p   = Both " "  (BC.singleton ' ')++-- | 'newline_p' is the 'Printable' representation of a newline.+newline_p :: Printable+newline_p = S "\n"++-- | Minimal 'Doc's representing the common characters 'space', 'newline'+-- 'minus', 'plus', and 'backslash'.+space, newline, plus, minus, backslash :: Doc+space     = unsafeBoth " "  (BC.singleton ' ')+newline   = unsafeChar '\n'+minus     = unsafeBoth "-"  (BC.singleton '-')+plus      = unsafeBoth "+"  (BC.singleton '+')+backslash = unsafeBoth "\\" (BC.singleton '\\')++-- | 'lparen' is the 'Doc' that represents @\"(\"@+lparen :: Doc+lparen = unsafeBoth  "(" (BC.singleton '(')++-- | 'rparen' is the 'Doc' that represents @\")\"@+rparen :: Doc+rparen = unsafeBoth ")" (BC.singleton ')')++-- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within+-- a pair of parenthesis.+parens :: Doc -> Doc+parens d = lparen <> d <> rparen++errorDoc :: Doc -> a+errorDoc = error . renderStringWith simplePrinters'+++-- | 'putDocWith' puts a doc on stdout using the given printer.+putDocWith :: Printers -> Doc -> IO ()+putDocWith prs = hPutDocWith prs stdout++-- | 'putDocLnWith' puts a doc, followed by a newline on stdout using+-- the given printer.+putDocLnWith :: Printers -> Doc -> IO ()+putDocLnWith prs = hPutDocLnWith prs stdout+++-- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'.+putDoc :: Doc -> IO ()+-- | 'putDocLn' puts a doc, followed by a newline on stdout using+-- 'simplePrinters'+putDocLn :: Doc -> IO ()+putDoc = hPutDoc stdout+putDocLn = hPutDocLn stdout++-- | 'hputDocWith' puts a doc on the given handle using the given printer.+hPutDocWith :: Printers -> Handle -> Doc -> IO ()+-- | 'hputDocLnWith' puts a doc, followed by a newline on the given+-- handle using the given printer.+hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()++hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)+hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)++-- |'hputDoc' puts a doc on the given handle using 'simplePrinters'+hPutDoc :: Handle -> Doc -> IO ()+-- 'hputDocLn' puts a doc, followed by a newline on the given handle using+-- 'simplePrinters'.+hPutDocLn :: Handle -> Doc -> IO ()+hPutDoc = hPutDocWith simplePrinters+hPutDocLn = hPutDocLnWith simplePrinters++-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h+hPrintPrintables :: Handle -> [Printable] -> IO ()+hPrintPrintables h = mapM_ (hPrintPrintable h)++-- | @hPrintPrintable h@ prints a 'Printable' to the handle h.+hPrintPrintable :: Handle -> Printable -> IO ()+hPrintPrintable h (S ps) = hPutStr h ps+hPrintPrintable h (PS ps) = B.hPut h ps+hPrintPrintable h (Both _ ps) = B.hPut h ps++-- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using+-- '<>', which is right-associative.+newtype Doc = Doc { unDoc :: St -> Document }++-- | The State associated with a doc. Contains a set of printers for each+-- hanlde, and the current prefix of the document.+data St = St { printers :: !Printers',+               current_prefix :: !([Printable] -> [Printable]) }+type Printers = Handle -> Printers'++-- | A set of printers to print different types of text to a handle.+data Printers' = Printers {colorP :: !(Color -> Printer),+                           invisibleP :: !Printer,+                           hiddenP :: !Printer,+                           userchunkP :: !Printer,+                           defP :: !Printer,+                           lineColorT :: !(Color -> Doc -> Doc),+                           lineColorS :: !([Printable] -> [Printable])+                          }+type Printer = Printable -> St -> Document++data Color = Blue | Red | Green | Cyan | Magenta++-- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows+-- for empty Documents. The simplest 'Documents' are built from 'String's+-- using 'text'.+data Document = Document ([Printable] -> [Printable])+              | Empty++-- | renders a 'Doc' into a 'String' with control codes for the+-- special features of the doc.+renderString :: Doc -> String+renderString = renderStringWith simplePrinters'++-- | renders a 'Doc' into a 'String' using a given set of printers.+renderStringWith :: Printers' -> Doc -> String+renderStringWith prs d = concatMap toString $ renderWith prs d+    where toString (S s) = s+          toString (PS ps) = BC.unpack ps+          toString (Both s _) = s++-- | renders a 'Doc' into 'B.ByteString' with control codes for the+-- special features of the Doc. See also 'readerString'.+renderPS :: Doc -> B.ByteString+renderPS = renderPSWith simplePrinters'++-- | renders a 'Doc' into a list of 'PackedStrings', one for each line.+renderPSs :: Doc -> [B.ByteString]+renderPSs = renderPSsWith simplePrinters'++-- | renders a doc into a 'B.ByteString' using a given set of printers.+renderPSWith :: Printers' -> Doc -> B.ByteString+renderPSWith prs d = B.concat $ renderPSsWith prs d++-- | renders a 'Doc' into a list of 'PackedStrings', one for each+-- chunk of text that was added to the doc, using the given set of+-- printers.+renderPSsWith :: Printers' -> Doc -> [B.ByteString]+renderPSsWith prs d = map toPS $ renderWith prs d+    where toPS (S s)        = BC.pack s+          toPS (PS ps)      = ps+          toPS (Both _ ps)  = ps++-- | renders a 'Doc' into a list of 'Printables' using a set of+-- printers. Each item of the list corresponds to a string that was+-- added to the doc.+renderWith :: Printers' -> Doc -> [Printable]+renderWith ps (Doc d) = case d (init_state ps) of+                        Empty -> []+                        Document f -> f []++init_state :: Printers' -> St+init_state prs = St { printers = prs, current_prefix = id }++prefix :: String -> Doc -> Doc+prefix s (Doc d) = Doc $ \st ->+                   let p = S s+                       st' = st { current_prefix = current_prefix st . (p:) } in+                   case d st' of+                     Document d'' -> Document $ (p:) . d''+                     Empty -> Empty+                     ++insert_before_lastline :: Doc -> Doc -> Doc+insert_before_lastline a b =+   case reverse $ map packedString $ linesPS $ renderPS a of+   (ll:ls) -> vcat (reverse ls) $$ b $$ ll+   [] -> error "empty Doc given as first argument of Printer.insert_before_last_line"+++lineColor :: Color -> Doc -> Doc+lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of+                             Doc d' -> d' st++hiddenPrefix :: String -> Doc -> Doc+hiddenPrefix s (Doc d) =+    Doc $ \st -> let pr = printers st+                     p = S (renderStringWith pr $ hiddenText s)+                     st' = st { current_prefix = current_prefix st . (p:) }+                 in case d st' of+                      Document d'' -> Document $ (p:) . d''+                      Empty -> Empty++-- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing+-- the same text, but does not check that they do.+unsafeBoth :: String -> B.ByteString -> Doc+unsafeBoth s ps = Doc $ simplePrinter (Both s ps)++-- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the+-- Doc as both a String and a 'B.ByteString'.+unsafeBothText :: String -> Doc+unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s))++-- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'+packedString :: B.ByteString -> Doc+-- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'+unsafePackedString :: B.ByteString -> Doc+-- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'+invisiblePS :: B.ByteString -> Doc+-- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.+userchunkPS :: B.ByteString -> Doc+packedString = printable . PS+unsafePackedString = Doc . simplePrinter . PS+invisiblePS = invisiblePrintable . PS+userchunkPS = userchunkPrintable . PS++-- | 'unsafeChar' creates a Doc containing just one character.+unsafeChar :: Char -> Doc+unsafeChar = unsafeText . (:"")++-- | 'text' creates a 'Doc' from a @String@, using 'printable'.+text :: String -> Doc+-- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly+unsafeText :: String -> Doc+-- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@+invisibleText :: String -> Doc+-- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@+hiddenText :: String -> Doc+-- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@+userchunk :: String -> Doc+-- | 'blueText' creates a 'Doc' containing blue text from a @String@+blueText, redText, greenText, magentaText, cyanText :: String -> Doc+text = printable . S+unsafeText = Doc . simplePrinter . S+invisibleText = invisiblePrintable . S+hiddenText = hiddenPrintable . S+userchunk = userchunkPrintable . S+blueText = colorText Blue+redText = colorText Red+greenText = colorText Green+magentaText = colorText Magenta+cyanText = colorText Cyan++-- | 'colorText' creates a 'Doc' containing colored text from a @String@+colorText :: Color -> String -> Doc+colorText c = mkColorPrintable c . S++-- | @'wrap_text' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters+wrap_text :: Int -> String -> Doc+wrap_text n s =+    vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s)+  where add_to_line [] a = [a]+        add_to_line ("":d) a = (a:d)+        add_to_line (l:ls) new | length l + length new > n = new:l:ls+        add_to_line (l:ls) new = (l ++ " " ++ new):ls++-- | 'printable x' creates a 'Doc' from any 'Printable'.+printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc+printable x = Doc $ \st -> defP (printers st) x st++mkColorPrintable :: Color -> Printable -> Doc+mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st+invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st+hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st+userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st++-- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any+-- handle.+simplePrinters :: Printers+simplePrinters _ = simplePrinters'++-- | A set of default printers suitable for any handle. Does not use color.+simplePrinters' :: Printers'+simplePrinters'  = Printers { colorP = const simplePrinter,+                              invisibleP = simplePrinter,+                              hiddenP = invisiblePrinter,+                              userchunkP = simplePrinter,+                              defP = simplePrinter,+                              lineColorT = const id,+                              lineColorS = id+                            }++-- | 'simplePrinter' is the simplest 'Printer': it just concatenates together+-- the pieces of the 'Doc'+simplePrinter :: Printer+-- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces+-- the document with 'empty'.  It's useful to have a printer that doesn't+-- actually do anything because this allows you to have tunable policies,+-- for example, only printing some text if it's to the terminal, but not+-- if it's to a file or vice-versa.+invisiblePrinter :: Printer+simplePrinter x = unDoc $ doc (\s -> x:s)+invisiblePrinter _ = unDoc empty++infixr 6 <>+infixr 6 <+>+infixr 5 $$++-- | The empty 'Doc'.+empty :: Doc+empty = Doc $ const Empty+doc :: ([Printable] -> [Printable]) -> Doc+doc f = Doc $ const $ Document f++-- | '(<>)' is the concatenation operator for 'Doc's+(<>) :: Doc -> Doc -> Doc+-- | @a '<?>' b@ is @a@ if it is not empty, else @b@.+(<?>) :: Doc -> Doc -> Doc+-- | @a '<+>' b@ is @a@ followed by a space, then @b@.+(<+>) :: Doc -> Doc -> Doc+-- | @a '$$' b@ is @a@ above @b@.+($$) :: Doc -> Doc -> Doc+-- a then b+Doc a <> Doc b =+   Doc $ \st -> case a st of+                Empty -> b st+                Document af ->+                    Document (\s -> af $ case b st of+                                         Empty -> s+                                         Document bf -> bf s)++-- empty if a empty, else a then b+Doc a <?> Doc b =+    Doc $ \st -> case a st of+                 Empty -> Empty+                 Document af -> Document (\s -> af $ case b st of+                                                     Empty -> s+                                                     Document bf -> bf s)++-- a then space then b+Doc a <+> Doc b =+    Doc $ \st -> case a st of+                 Empty -> b st+                 Document af -> Document (\s -> af $ case b st of+                                                     Empty -> s+                                                     Document bf ->+                                                         space_p:bf s)++-- a above b+Doc a $$ Doc b =+   Doc $ \st -> case a st of+                Empty -> b st+                Document af ->+                    Document (\s -> af $ case b st of+                                         Empty -> s+                                         Document bf -> sf (newline_p:pf (bf s)))+                        where pf = current_prefix st+                              sf = lineColorS $ printers st++-- | 'vcat' piles vertically a list of 'Doc's.+vcat :: [Doc] -> Doc+vcat [] = empty+vcat ds = foldr1 ($$) ds++-- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each.+vsep :: [Doc] -> Doc+vsep [] = empty+vsep ds = foldr1 ($$) $ intersperse (text "") ds++-- | 'hcat' concatenates (horizontally) a list of 'Doc's+hcat :: [Doc] -> Doc+hcat [] = empty+hcat ds = foldr1 (<>) ds++\end{code}+
+ src/Progress.hs view
@@ -0,0 +1,202 @@+-- Various utility functions that do not belong anywhere else.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Progress ( beginTedious, endTedious, tediousSize,+                  debugMessage, debugFail, withoutProgress,+                  progress, progressKeepLatest, finishedOne,+                  finishedOneIO, progressList, minlist,+                  setProgressMode) where++import Prelude hiding (lookup, catch)++import Control.Exception ( catch, throw )+import Control.Monad ( when )+import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,+                   hSetBuffering, hIsTerminalDevice,+                   Handle, BufferMode(LineBuffering) )+import System.IO.Unsafe ( unsafePerformIO )+import Data.Char ( toLower )+import Data.Map ( Map, empty, adjust, insert, delete, lookup )+import Data.Maybe ( isJust )+import Control.Concurrent ( forkIO, threadDelay )+import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )++import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail )++handleProgress :: IO ()+handleProgress = do threadDelay 1000000+                    handleMoreProgress "" 0++handleMoreProgress :: String -> Int -> IO ()+handleMoreProgress k n = withProgressMode $ \m ->+    if m then do s <- getProgressLast+                 mp <- getProgressData s+                 case mp of+                   Nothing -> do threadDelay 1000000+                                 handleMoreProgress k n+                   Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p+                                threadDelay 1000000+                                handleMoreProgress s (sofar p)+         else do threadDelay 1000000+                 handleMoreProgress k n++printProgress :: String -> ProgressData -> IO ()+printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =+    myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t)+printProgress k (ProgressData {latest=Just l}) =+    myput (k++" "++l) k+printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =+    myput (k++" "++show s++"/"++show t) (k++" "++show s)+printProgress k (ProgressData {sofar=s}) =+    myput (k++" "++show s) k++myput :: String -> String -> IO ()+myput l s = withDebugMode $ \debugMode ->+            if debugMode+            then putTiming >> hPutStrLn stderr l+            else if '\n' `elem` l+                 then myput (takeWhile (/= '\n') l) s+                 else if length l < 80 then putTiming >> simpleput l+                                       else putTiming >> simpleput (take 80 s)++{-# NOINLINE simpleput #-}+simpleput :: String -> IO ()+simpleput = unsafePerformIO $ mkhPutCr stderr++-- | @beginTedious k@ starts a tedious process and registers it in+-- '_progressData' with the key @k@. A tedious process is one for which we+-- want a progress indicator.+--+--  Wouldn't it be safer if it had type String -> IO+-- ProgressDataKey, so that we can ensure there is no collision?+-- What happens if you call beginTedious twice with the same string, without+-- calling endTedious in the meantime?+beginTedious :: String -> IO ()+beginTedious k = do debugMessage $ "Beginning " ++ (map toLower k)+                    setProgressData k $ ProgressData { sofar = 0,+                                                       latest = Nothing,+                                                       total = Nothing }++-- | @endTedious k@ unregisters the tedious process with key @k@, printing "Done" if such+-- a tedious process exists.+endTedious :: String -> IO ()+endTedious k = whenProgressMode $ do p <- getProgressData k+                                     modifyIORef _progressData (\(a,m) -> (a,delete k m))+                                     when (isJust p) $ debugMessage $ "Done "+++                                          (map toLower k)++tediousSize :: String -> Int -> IO ()+tediousSize k s = updateProgressData k uptot+    where uptot p = case total p of Just t -> seq ts $ p { total = Just ts }+                                        where ts = t + s+                                    Nothing -> p { total = Just s }++minlist :: Int+minlist = 4++progressList :: String -> [a] -> [a]+progressList _ [] = []+progressList k (x:xs) = if l < minlist then x:xs+                                       else startit x : pl xs+    where l = length (x:xs)+          startit y = unsafePerformIO $ do beginTedious k+                                           tediousSize k l+                                           return y+          pl [] = []+          pl [y] = unsafePerformIO $ do endTedious k+                                        return [y]+          pl (y:ys) = progress k y : pl ys+++progress :: String -> a -> a+progress k a = unsafePerformIO $ progressIO k >> return a++progressIO :: String -> IO ()+progressIO "" = return ()+progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1,+                                                  latest = Nothing })+                  putDebug k ""++progressKeepLatest :: String -> a -> a+progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a++progressKeepLatestIO :: String -> IO ()+progressKeepLatestIO "" = return ()+progressKeepLatestIO k = do updateProgressData k (\p -> p {sofar = sofar p + 1})+                            putDebug k ""++finishedOne :: String -> String -> a -> a+finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a++finishedOneIO :: String -> String -> IO ()+finishedOneIO "" _ = return ()+finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1,+                                                       latest = Just l })+                       putDebug k l++putDebug :: String -> String -> IO ()+putDebug _ _ = return ()+--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k+--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l++{-# NOINLINE _progressMode #-}+_progressMode :: IORef Bool+_progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering+                                     newIORef True++{-# NOINLINE _progressData #-}+_progressData :: IORef (String, Map String ProgressData)+_progressData = unsafePerformIO $ do forkIO handleProgress+                                     newIORef ("", empty)++mkhPutCr :: Handle -> IO (String -> IO ())+mkhPutCr fe = do+  isTerm <- hIsTerminalDevice fe+  stdoutIsTerm <- hIsTerminalDevice stdout+  return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r"+                                   hFlush fe+                                   let spaces = '\r':replicate (length s) ' '++"\r"+                                   hPutStr fe spaces+                                   when stdoutIsTerm $ hPutStr stdout spaces+                     else \s -> when (not $ null s) $ do hPutStrLn fe s+                                                         hFlush fe++setProgressMode :: Bool -> IO ()+setProgressMode m = writeIORef _progressMode m++withoutProgress :: IO a -> IO a+withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..."+                                                setProgressMode False+                                                a <- j `catch` \e -> setProgressMode m >> throw e+                                                if m then debugMessage "Reenabling progress reports."+                                                     else debugMessage "Leaving progress reports off."+                                                setProgressMode m+                                                return a++updateProgressData :: String -> (ProgressData -> ProgressData) -> IO ()+updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))++setProgressData :: String -> ProgressData -> IO ()+setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m))++getProgressData :: String -> IO (Maybe ProgressData)+getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData+                                                  else return Nothing++getProgressLast :: IO String+getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData+                                                else return ""++whenProgressMode :: IO a -> IO ()+whenProgressMode j = withProgressMode $ const $ j >> return ()++withProgressMode :: (Bool -> IO a) -> IO a+withProgressMode j = readIORef _progressMode >>= j++data ProgressData = ProgressData { sofar :: !Int,+                                   latest :: !(Maybe String),+                                   total :: !(Maybe Int)}
+ src/RegChars.hs view
@@ -0,0 +1,75 @@+-- Copyright (C) 2003 David Roundy+--+-- 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.+++module RegChars ( regChars,+                ) where++(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(&&&) a b c = a c && b c++(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(|||) a b c = a c || b c++{-# INLINE regChars #-}++-- | 'regChars' returns a filter function that tells if a char is a member+-- of the regChar expression or not. The regChar expression is basically a+-- set of chars, but it can contain ranges with use of the '-' (dash), and+-- it can also be specified as a complement set by prefixing with '^'+-- (caret). The dash and caret, as well as the backslash, can all be+-- escaped with a backslash to suppress their special meaning.+-- +-- NOTE: The '.' (dot) is allowed to be escaped. It has no special meaning+-- if it is not escaped, but the default 'filename_toks' in+-- Darcs.Commands.Replace uses an escaped dot (WHY?).++regChars :: String -> (Char -> Bool)+regChars ('^':cs) = not . normalRegChars (unescapeChars cs)+regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs+regChars cs = normalRegChars $ unescapeChars cs++{-# INLINE unescapeChars #-}++-- | 'unescapeChars' unescapes whitespace, which is escaped in the replace+-- patch file format. It will also unescape escaped carets, which is useful+-- for escaping a leading caret that should not invert the regChars. All+-- other escapes are left for the unescaping in 'normalRegChars'.++unescapeChars :: String -> String+unescapeChars ('\\':'n':cs) = '\n' : unescapeChars cs+unescapeChars ('\\':'t':cs) = '\t' : unescapeChars cs+unescapeChars ('\\':'^':cs) = '^' : unescapeChars cs+unescapeChars (c:cs) = c : unescapeChars cs+unescapeChars [] = []++{-# INLINE normalRegChars #-}++-- | 'normalRegChars' assembles the filter function. It handles special+-- chars, and also unescaping of escaped special chars. If a non-special+-- char is still escaped by now we get a failure.++normalRegChars :: String -> (Char -> Bool)+normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs+normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs+normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs+normalRegChars ('\\':c:_) = error $ "'\\"++[c]++"' not supported."+normalRegChars (c1:'-':c2:cs) = ((>= c1) &&& (<= c2)) ||| normalRegChars cs+normalRegChars (c:cs) = (== c) ||| normalRegChars cs+normalRegChars [] = \_ -> False++
+ src/SHA1.hs view
@@ -0,0 +1,206 @@+-- Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>+--+-- 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.++{-# OPTIONS_GHC -fno-warn-name-shadowing -cpp #-}+{-# LANGUAGE CPP #-}+++-- {-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing #-}+-- -fglasgow-exts needed for nasty hack below+-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4+module SHA1 (sha1PS) where++import ByteStringUtils (unsafeWithInternals)+import qualified Data.ByteString as B (ByteString, pack, length, concat)++import Data.Char (intToDigit)+import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)+import Data.Word (Word8, Word32)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Marshal.Array (advancePtr)+import Foreign.Storable (peek, poke)+import System.IO.Unsafe (unsafePerformIO)++data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32+data XYZ = XYZ !Word32 !Word32 !Word32++sha1PS :: B.ByteString -> String+sha1PS s = s5+ where s1_2 = sha1_step_1_2_pad_length s+       abcde = sha1_step_3_init+       abcde' = unsafePerformIO+              $ unsafeWithInternals s1_2 (\ptr len ->+                    do let ptr' = castPtr ptr+#ifndef BIGENDIAN+                       fiddle_endianness ptr' len+#endif+                       sha1_step_4_main abcde ptr' len)+       s5 = sha1_step_5_display abcde'++fiddle_endianness :: Ptr Word32 -> Int -> IO ()+fiddle_endianness p 0 = p `seq` return ()+fiddle_endianness p n+ = do x <- peek p+      poke p $ shiftL x 24+           .|. shiftL (x .&. 0xff00) 8+           .|. (shiftR x 8 .&. 0xff00)+           .|. shiftR x 24+      fiddle_endianness (p `advancePtr` 1) (n - 4)++-- sha1_step_1_2_pad_length assumes the length is at most 2^61.+-- This seems reasonable as the Int used to represent it is normally 32bit,+-- but obviously could go wrong with large inputs on 64bit machines.+-- The B.ByteString library should probably move to Word64s if this is an+-- issue, though.++sha1_step_1_2_pad_length :: B.ByteString -> B.ByteString+sha1_step_1_2_pad_length s+ = let len = B.length s+       num_nuls = (55 - len) `mod` 64+       padding = 128:replicate num_nuls 0+       len_w8s = reverse $ size_split 8 (fromIntegral len*8)+   in B.concat [s, B.pack padding, B.pack len_w8s]++size_split :: Int -> Integer -> [Word8]+size_split 0 _ = []+size_split p n = fromIntegral d:size_split (p-1) n'+ where (n', d) = divMod n 256++sha1_step_3_init :: ABCDE+sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0++sha1_step_4_main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE+sha1_step_4_main abcde _ 0 = return $! abcde+sha1_step_4_main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len+    = do+         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e+         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d+         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c+         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b+         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a+         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e+         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d+         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c+         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b+         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a+         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e+         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d+         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c+         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b+         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a+         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e+         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d+         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c+         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b+         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a+         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e+         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d+         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c+         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b+         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a+         let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)+         sha1_step_4_main abcde' (s `advancePtr` 16) (len - 64)+ where {-# INLINE f1 #-}+       f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)+       {-# INLINE f2 #-}+       f2 (XYZ x y z) = x `xor` y `xor` z+       {-# INLINE f3 #-}+       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)+       {-# INLINE x #-}+       x n = peek (s `advancePtr` n)+       {-# INLINE m #-}+       m n = do let base = s `advancePtr` (n .&. 15)+                x0 <- peek base+                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))+                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))+                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))+                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1+                poke base res+                return res+       {-# INLINE doit #-}+       doit f k i a b c d e = a `seq` c `seq`+           do i' <- i+              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,+                      rotateL b 30)++sha1_step_5_display :: ABCDE -> String+sha1_step_5_display (ABCDE a b c d e)+ = concatMap showAsHex [a, b, c, d, e]++showAsHex :: Word32 -> String+showAsHex n = showIt 8 n ""+   where+    showIt :: Int -> Word32 -> String -> String+    showIt 0 _ r = r+    showIt i x r = case quotRem x 16 of+                       (y, z) -> let c = intToDigit (fromIntegral z)+                                 in c `seq` showIt (i-1) y (c:r)
+ src/Ssh.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..),+             environmentHelpSsh, environmentHelpScp, environmentHelpSshPort+           ) where++import Prelude hiding ( lookup, catch )++import System.Exit ( ExitCode(..) )+import System.Environment ( getEnv )+#ifndef WIN32+import System.Posix.Process ( getProcessID )+#else+import Darcs.Utils ( showHexLen )+import Data.Bits ( (.&.) )+import System.Random ( randomIO )+#endif+import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hGetContents, hClose, hFlush )+import System.IO.Unsafe ( unsafePerformIO )+import System.Directory ( doesFileExist, createDirectoryIfMissing )+import Control.Monad ( when )+import System.Process ( runInteractiveProcess )++import Data.Map ( Map, empty, insert, lookup )+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )++import Darcs.SignalHandler ( catchNonSignal )+import Darcs.Utils ( withCurrentDirectory, breakCommand, prettyException, catchall )+import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, withDebugMode )+import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist )+import Exec ( exec, Redirects, Redirect(..), )+import Progress ( withoutProgress, debugMessage, debugFail, progressList )++import qualified Data.ByteString as B (ByteString, hGet, writeFile, readFile)+import qualified Data.ByteString.Char8 as BC (unpack)++#include "impossible.h"++{-# NOINLINE sshConnections #-}+sshConnections :: IORef (Map String (Maybe Connection))+sshConnections = unsafePerformIO $ newIORef empty++data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () }++withSSHConnection :: String -> (Connection -> IO a) -> IO a -> IO a+withSSHConnection x withconnection withoutconnection =+    withoutProgress $+    do cs <- readIORef sshConnections+       let uhost = takeWhile (/= ':') x+           url = cleanrepourl x+       case lookup url (cs :: Map String (Maybe Connection)) of+         Just Nothing -> withoutconnection+         Just (Just c) -> withconnection c+         Nothing ->+           do mc <- do (ssh,sshargs_) <- getSSHOnly SSH+                       let sshargs = sshargs_ ++ [uhost,"darcs","transfer-mode","--repodir",cleanrepodir x]+                       debugMessage $ "ssh "++unwords sshargs+                       (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing+                       l <- hGetLine o+                       if l == "Hello user, I am darcs transfer mode"+                           then return ()+                           else debugFail "Couldn't start darcs transfer-mode on server"+                       let c = C { inp = i, out = o, err = e,+                                   deb = \s -> debugMessage ("with ssh (transfer-mode) "++uhost++": "++s) }+                       modifyIORef sshConnections (insert url (Just c))+                       return $ Just c+                    `catchNonSignal`+                            \e -> do debugMessage $ "Failed to start ssh connection:\n    "+++                                                    prettyException e+                                     severSSHConnection x+                                     debugMessage $ unlines $+                                         [ "NOTE: the server may be running a version of darcs prior to 2.0.0."+                                         , ""+                                         , "Installing darcs 2 on the server will speed up ssh-based commands."+                                         ]+                                     return Nothing+              maybe withoutconnection withconnection mc++severSSHConnection :: String -> IO ()+severSSHConnection x = do debugMessage $ "Severing ssh failed connection to "++x+                          modifyIORef sshConnections (insert (cleanrepourl x) Nothing)++cleanrepourl :: String -> String+cleanrepourl zzz | take (length dd) zzz == dd = ""+                 where dd = darcsdir++"/"+cleanrepourl (z:zs) = z : cleanrepourl zs+cleanrepourl "" = ""++cleanrepodir :: String -> String+cleanrepodir = cleanrepourl . drop 1 . dropWhile (/= ':')++grabSSH :: String -> Connection -> IO B.ByteString+grabSSH x c = do+               let dir = drop 1 $ dropWhile (/= ':') x+                   dd = darcsdir++"/"+                   clean zzz | take (length dd) zzz == dd = drop (length dd) zzz+                   clean (_:zs) = clean zs+                   clean "" = bug $ "Buggy path in grabSSH: "++x+                   file = clean dir+                   failwith e = do severSSHConnection x+                                   eee <- hGetContents (err c) -- ratify hGetContents: it's okay+                                                               -- here because we're only grabbing+                                                               -- stderr, and we're also about to+                                                               -- throw the contents.+                                   debugFail $ e ++ " grabbing ssh file "++x++"\n"++eee+               deb c $ "get "++file+               hPutStrLn (inp c) $ "get " ++ file+               hFlush (inp c)+               l2 <- hGetLine (out c)+               if l2 == "got "++file+                  then do showlen <- hGetLine (out c)+                          case reads showlen of+                            [(len,"")] -> B.hGet (out c) len+                            _ -> failwith "Couldn't get length"+                  else if l2 == "error "++file+                       then do e <- hGetLine (out c)+                               case reads e of+                                 (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg+                                 [] -> failwith "An error occurred"+                       else failwith "Error"++sshStdErrMode :: IO Redirect+sshStdErrMode = withDebugMode $ \amdebugging ->+                return $ if amdebugging then AsIs else Null++copySSH :: String -> FilePath -> IO ()+copySSH uRaw f = withSSHConnection uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $+              do let u = escape_dollar uRaw+                 stderr_behavior <- sshStdErrMode+                 r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior)+                 when (r /= ExitSuccess) $+                      debugFail $ "(scp) failed to fetch: " ++ u+    where {- '$' in filenames is troublesome for scp, for some reason.. -}+          escape_dollar :: String -> String+          escape_dollar = concatMap tr+           where tr '$' = "\\$"+                 tr c = [c]++copySSHs :: String -> [String] -> FilePath -> IO ()+copySSHs u ns d =+  withSSHConnection u (\c -> withCurrentDirectory d $+                             mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $+                             progressList "Copying via ssh" ns) $+  do let path = drop 1 $ dropWhile (/= ':') u+         host = takeWhile (/= ':') u+         cd = "cd "++path++"\n"+         input = cd++(unlines $ map ("get "++) ns)+     withCurrentDirectory d $ withOpenTemp $ \(th,tn) ->+         withTemp $ \sftpoutput ->+         do hPutStr th input+            hClose th+            stderr_behavior <- sshStdErrMode+            r <- runSSH SFTP u [] [host] (File tn, File sftpoutput, stderr_behavior)+            let files = if length ns > 5+                          then (take 5 ns) ++ ["and "+                               ++ (show (length ns - 5)) ++ " more"]+                          else ns+                hint = if take 1 path == "~"+                         then ["sftp doesn't expand ~, use path/ instead of ~/path/"]+                         else []+            when (r /= ExitSuccess) $ do+                 outputPS <- B.readFile sftpoutput+                 debugFail $ unlines $+                          ["(sftp) failed to fetch files.",+                           "source directory: " ++ path,+                           "source files:"] ++ files +++                          ["sftp output:",BC.unpack outputPS] +++                          hint++-- ---------------------------------------------------------------------+-- older ssh helper functions+-- ---------------------------------------------------------------------++data SSHCmd = SSH | SCP | SFTP++instance Show SSHCmd where+  show SSH  = "ssh"+  show SCP  = "scp"+  show SFTP = "sftp"++runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO ExitCode+runSSH cmd remoteAddr preArgs postArgs redirs =+ do (ssh, args) <- getSSH cmd remoteAddr+    exec ssh (preArgs ++ args ++ postArgs) redirs++-- | Return the command and arguments needed to run an ssh command+--   along with any extra features like use of the control master.+--   See 'getSSHOnly'+getSSH :: SSHCmd -> String -- ^ remote path+       -> IO (String, [String])+getSSH cmd remoteAddr =+ do (ssh, ssh_args) <- getSSHOnly cmd+    cm_args <- if sshControlMasterDisabled+               then return []+               else do -- control master+                       cmPath <- controlMasterPath remoteAddr+                       hasLaunchedCm <- doesFileExist cmPath+                       when (not hasLaunchedCm) $ launchSSHControlMaster remoteAddr+                       hasCmFeature <- doesFileExist cmPath+                       return $ if hasCmFeature then [ "-o ControlPath=" ++ cmPath ] else []+    let verbosity = case cmd of+                    SCP  -> ["-q"] -- (p)scp is the only one that recognises -q+                                   -- sftp and (p)sftp do not, and plink neither+                    _    -> []+    --+    return (ssh, verbosity ++ ssh_args ++ cm_args)++-- | Return the command and arguments needed to run an ssh command.+--   First try the appropriate darcs environment variable and SSH_PORT+--   defaulting to "ssh" and no specified port.+getSSHOnly :: SSHCmd -> IO (String, [String])+getSSHOnly cmd =+ do ssh_command <- getEnv (evar cmd) `catchall` return (show cmd)+    -- port+    port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []+    let (ssh, ssh_args) = breakCommand ssh_command+    --+    return (ssh, ssh_args ++ port)+    where+     evar SSH  = "DARCS_SSH"+     evar SCP  = "DARCS_SCP"+     evar SFTP = "DARCS_SFTP"+     portFlag SSH  x = ["-p", x]+     portFlag SCP  x = ["-P", x]+     portFlag SFTP x = ["-oPort="++x]++environmentHelpSsh :: ([String], [String])+environmentHelpSsh = (["DARCS_SSH"], [+ "Repositories of the form [user@]host:[dir] are taken to be remote",+ "repositories, which Darcs accesses with the external program ssh(1).",+ "",+ "The environment variable $DARCS_SSH can be used to specify an",+ "alternative SSH client.  Arguments may be included, separated by",+ "whitespace.  The value is not interpreted by a shell, so shell",+ "constructs cannot be used; in particular, it is not possible for the",+ "program name to contain whitespace by using quoting or escaping."])++environmentHelpScp :: ([String], [String])+environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [+ "When reading from a remote repository, Darcs will attempt to run",+ "`darcs transfer-mode' on the remote host.  This will fail if the",+ "remote host only has Darcs 1 installed, doesn't have Darcs installed",+ "at all, or only allows SFTP.",+ "",+ "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",+ "The commands invoked can be customized with the environment variables",+ "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",+ "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])++environmentHelpSshPort :: ([String], [String])+environmentHelpSshPort = (["SSH_PORT"], [+ "If this environment variable is set, it will be used as the port",+ "number for all SSH calls made by Darcs (when accessing remote",+ "repositories over SSH).  This is useful if your SSH server does not",+ "run on the default port, and your SSH client does not support",+ "ssh_config(5).  OpenSSH users will probably prefer to put something",+ "like `Host *.example.net Port 443' into their ~/.ssh/config file."])++-- | Return True if this version of ssh has a ControlMaster feature+-- The ControlMaster functionality allows for ssh multiplexing+hasSSHControlMaster :: Bool+hasSSHControlMaster = unsafePerformIO hasSSHControlMasterIO++-- Because of the unsafePerformIO above, this can be called at any+-- point.  It cannot rely on any state, not even the current directory.+hasSSHControlMasterIO :: IO Bool+hasSSHControlMasterIO = do+  (ssh, _) <- getSSHOnly SSH+  -- If ssh has the ControlMaster feature, it will recognise the+  -- the -O flag, but exit with status 255 because of the nonsense+  -- command.  If it does not have the feature, it will simply dump+  -- a help message on the screen and exit with 1.+  sx <- exec ssh ["-O", "an_invalid_command"] (Null,Null,Null)+  case sx of+    ExitFailure 255 -> return True+    _ -> return False++-- | Launch an SSH control master in the background, if available.+--   We don't have to wait for it or anything.+--   Note also that this will cleanup after itself when darcs exits+launchSSHControlMaster :: String -> IO ()+launchSSHControlMaster rawAddr =+  when hasSSHControlMaster $ do+  let addr = takeWhile (/= ':') rawAddr+  (ssh, ssh_args) <- getSSHOnly SSH+  cmPath <- controlMasterPath addr+  removeFileMayNotExist cmPath+  -- -f : put ssh in the background once it succeeds in logging you in+  -- -M : launch as the control master for addr+  -- -N : don't run any commands+  -- -S : use cmPath as the ControlPath.  Equivalent to -oControlPath=+  exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,AsIs)+  atexit $ exitSSHControlMaster addr+  return ()++-- | Tell the SSH control master for a given path to exit.+exitSSHControlMaster :: String -> IO ()+exitSSHControlMaster addr = do+  (ssh, ssh_args) <- getSSHOnly SSH+  cmPath <- controlMasterPath addr+  exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null)+  return ()++-- | Create the directory ssh control master path for a given address+controlMasterPath :: String -- ^ remote path (foo\@bar.com:file is ok; the file part with be stripped)+                  -> IO FilePath+controlMasterPath rawAddr = do+  let addr = takeWhile (/= ':') rawAddr+  tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdir_loc+#ifdef WIN32+  r <- randomIO+  let suffix = (showHexLen 6 (r .&. 0xFFFFFF :: Int))+#else+  suffix <- show `fmap` getProcessID+#endif+  let tmpDarcsSsh = tmp /// "darcs-ssh"+  createDirectoryIfMissing True tmpDarcsSsh+  return $ tmpDarcsSsh /// addr ++ suffix++(///) :: FilePath -> FilePath -> FilePath+d /// f = d ++ "/" ++ f
+ src/ThisVersion.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -cpp #-}++module ThisVersion ( darcs_version ) where++#ifndef PACKAGE_VERSION+#define PACKAGE_VERSION "0"+#define PACKAGE_VERSION_STATE "no version info"+#endif++{-# NOINLINE darcs_version #-}+darcs_version :: String+darcs_version = PACKAGE_VERSION ++ " (" ++ PACKAGE_VERSION_STATE ++ ")"
+ src/URL.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault,+             setDebugHTTP, setHTTPPipelining, waitUrl,+             Cachable(Cachable, Uncachable, MaxAge),+             environmentHelpProxy, environmentHelpProxyPassword+           ) where++import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+import Data.Map ( Map )+import Data.List ( delete )+import qualified Data.Map as Map+import System.Directory ( copyFile )+import System.IO.Unsafe ( unsafePerformIO )+import Control.Concurrent ( forkIO )+import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan )+import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar )+import Control.Monad ( unless, when )+import Control.Monad.Trans ( liftIO )+import Control.Monad.State ( evalStateT, get, modify, put, StateT )+import Foreign.C.Types ( CInt )++import Workaround ( renameFile )+import Darcs.Global ( atexit )+import Progress ( debugFail, debugMessage )+import Darcs.Lock ( removeFileMayNotExist )++import Numeric ( showHex )+import System.Random ( randomRIO )++#ifdef HAVE_CURL+import Foreign.C.String ( withCString, peekCString, CString )+#else+import qualified HTTP ( request_url, wait_next_url )+#endif+#include "impossible.h"++data UrlRequest = UrlRequest { url :: String+                             , file :: FilePath+                             , cachable :: Cachable+                             , priority :: Priority+                             , notifyVar :: MVar String }++data Cachable = Cachable | Uncachable | MaxAge !CInt+                deriving (Show, Eq)++data UrlState = UrlState { inProgress :: Map String ( FilePath+                                                    , [FilePath]+                                                    , Cachable+                                                    , (MVar String) )+                         , waitToStart :: Q String+                         , pipeLength :: Int+                         , randomJunk :: String }++data Q a = Q [a] [a]++readQ :: Q a -> Maybe (a, Q a)+readQ (Q (x:xs) ys) = Just (x, Q xs ys)+readQ (Q [] ys) = do x:xs <- Just $ reverse ys+                     Just (x, Q xs [])++insertQ :: a -> Q a -> Q a+insertQ y (Q xs ys) = Q xs (y:ys)++pushQ :: a -> Q a -> Q a+pushQ x (Q xs ys) = Q (x:xs) ys++deleteQ :: Eq a => a -> Q a -> Q a+deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)++elemQ :: Eq a => a -> Q a -> Bool+elemQ x (Q xs ys) = x `elem` xs || x `elem` ys++emptyQ :: Q a+emptyQ = Q [] []++nullQ :: Q a -> Bool+nullQ (Q [] []) = True+nullQ _         = False++data Priority = High | Low deriving Eq++#if defined(CURL_PIPELINING) || defined(CURL_PIPELINING_DEFAULT)+pipeliningLimit :: Int+pipeliningLimit = 100+#endif++pipeliningEnabledByDefault :: Bool+#ifdef CURL_PIPELINING_DEFAULT+pipeliningEnabledByDefault = True+#else+pipeliningEnabledByDefault = False+#endif++{-# NOINLINE maxPipeLength #-}+maxPipeLength :: IORef Int+maxPipeLength = unsafePerformIO $ newIORef $+#ifdef CURL_PIPELINING_DEFAULT+                pipeliningLimit+#else+                1+#endif++{-# NOINLINE urlNotifications #-}+urlNotifications :: MVar (Map String (MVar String))+urlNotifications = unsafePerformIO $ newMVar Map.empty++{-# NOINLINE urlChan #-}+urlChan :: Chan UrlRequest+urlChan = unsafePerformIO $ do+  ch <- newChan+  forkIO (urlThread ch)+  return ch++urlThread :: Chan UrlRequest -> IO ()+urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange+                  evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)+    where rrange = (0, 2^(128 :: Integer) :: Integer)+          urlThread' = do+            empty <- liftIO $ isEmptyChan ch+            st <- get+            let l = pipeLength st+                w = waitToStart st+            reqs <- if not empty || (nullQ w && l == 0)+                    then liftIO readAllRequests+                    else return []+            mapM_ addReq reqs+            checkWaitToStart+            waitNextUrl+            urlThread'+          readAllRequests = do+            r <- readChan ch+            debugMessage $ "URL.urlThread ("++url r++"\n"+++                           "            -> "++file r++")"+            empty <- isEmptyChan ch+            reqs <- if not empty+                    then readAllRequests+                    else return []+            return (r:reqs)+          addReq r = do+            let u = url r+                f = file r+                c = cachable r+            d <- liftIO $ alreadyDownloaded u+            if d+               then dbg "Ignoring UrlRequest of URL that is already downloaded."+               else do+                 st <- get+                 let p = inProgress st+                     w = waitToStart st+                     e = (f, [], c, notifyVar r)+                     new_w = case priority r of+                               High -> pushQ u w+                               Low  -> insertQ u w+                     new_st = st { inProgress = Map.insert u e p+                                 , waitToStart = new_w }+                 case Map.lookup u p of+                   Just (f', fs', c', v) -> do+                     let new_c = minCachable c c'+                     when (c /= c') $ let new_p = Map.insert u (f', fs', new_c, v) p+                                      in do modify (\s -> s { inProgress = new_p })+                                            dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c+                     when (u `elemQ` w && priority r == High) $ do+                       modify (\s -> s { waitToStart = pushQ u (deleteQ u w) })+                       dbg $ "Moving "++u++" to head of download queue."+                     if f `notElem` (f':fs')+                        then let new_p = Map.insert u (f', f:fs', new_c, v) p+                             in do modify (\s -> s { inProgress = new_p })+                                   dbg "Adding new file to existing UrlRequest."+                        else dbg "Ignoring UrlRequest of file that's already queued."+                   _ -> put new_st+          alreadyDownloaded u = do+            n <- liftIO $ withMVar urlNotifications (return . (Map.lookup u))+            case n of+              Just v  -> not `fmap` isEmptyMVar v+              Nothing -> return True++checkWaitToStart :: StateT UrlState IO ()+checkWaitToStart = do+  st <- get+  let l = pipeLength st+  mpl <- liftIO $ readIORef maxPipeLength+  when (l < mpl) $ do+    let w = waitToStart st+    case readQ w of+      Just (u,rest) -> do+        case Map.lookup u (inProgress st) of+          Just (f, _, c, v) -> do+            dbg ("URL.request_url ("++u++"\n"+++                 "              -> "++f++")")+            let f_new = f++"-new_"++randomJunk st+            err <- liftIO $ request_url u f_new c+            if null err+               then do dbg "URL.request_url succeeded"+                       liftIO $ atexit (removeFileMayNotExist f_new)+                       put $ st { waitToStart = rest+                                , pipeLength = l + 1 }+               else do dbg $ "Failed to start download URL "++u++": "++err+                       liftIO $ do removeFileMayNotExist f_new+                                   putMVar v err+                       put $ st { waitToStart = rest }+          _              -> bug $ "Possible bug in URL.checkWaitToStart "++u+        checkWaitToStart+      _ -> return ()++copyUrlFirst :: String -> FilePath -> Cachable -> IO ()+copyUrlFirst = copyUrlWithPriority High++copyUrl :: String -> FilePath -> Cachable -> IO ()+copyUrl = copyUrlWithPriority Low++copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()+copyUrlWithPriority p u f c = do+  debugMessage ("URL.copyUrlWithPriority ("++u++"\n"+++                "                      -> "++f++")")+  v <- newEmptyMVar+  let fn _ old_val = old_val+  modifyMVar_ urlNotifications (return . (Map.insertWith fn u v))+  let r = UrlRequest u f c p v+  writeChan urlChan r++waitNextUrl :: StateT UrlState IO ()+waitNextUrl = do+  st <- get+  let l = pipeLength st+  when (l > 0) $ do+                dbg "URL.waitNextUrl start"+                (u, e) <- liftIO $ wait_next_url+                let p = inProgress st+                    new_st = st { inProgress = Map.delete u p+                                , pipeLength = l - 1 }+                liftIO $ if null e+                         then case Map.lookup u p of+                                Just (f, fs, _, v) -> do+                                  renameFile (f++"-new_"++randomJunk st) f+                                  mapM_ (safeCopyFile st f) fs+                                  putMVar v e+                                  debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f+                                Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u+                         else case Map.lookup u p of+                                Just (f, _, _, v) -> do+                                  removeFileMayNotExist (f++"-new_"++randomJunk st)+                                  putMVar v e+                                  debugMessage $ "URL.waitNextUrl failed: "+++                                               u++" "++f++" "++e+                                Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e+                unless (null u) $ put new_st+    where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st+                                in do copyFile f new_t+                                      renameFile new_t t++waitUrl :: String -> IO ()+waitUrl u = do debugMessage $ "URL.waitUrl "++u+               r <- withMVar urlNotifications (return . (Map.lookup u))+               case r of+                 Just var -> do+                        e <- readMVar var+                        modifyMVar_ urlNotifications (return . (Map.delete u))+                        unless (null e) (debugFail $ "Failed to download URL "++u++": "++e)+                 Nothing  -> return () -- file was already downloaded++dbg :: String -> StateT a IO ()+dbg = liftIO . debugMessage++minCachable :: Cachable -> Cachable -> Cachable+minCachable Uncachable _          = Uncachable+minCachable _          Uncachable = Uncachable+minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b+minCachable (MaxAge a) _          = MaxAge a+minCachable _          (MaxAge b) = MaxAge b+minCachable _          _          = Cachable++#ifdef HAVE_CURL+cachableToInt :: Cachable -> CInt+cachableToInt Cachable = -1+cachableToInt Uncachable = 0+cachableToInt (MaxAge n) = n+#endif++setHTTPPipelining :: Bool -> IO ()+setHTTPPipelining False = writeIORef maxPipeLength 1+setHTTPPipelining True = writeIORef maxPipeLength+#ifdef CURL_PIPELINING+    pipeliningLimit+#else+    1 >> (putStrLn $ "Warning: darcs is compiled without HTTP pipelining "+++                     "support, '--http-pipelining' argument is ignored.")+#endif++setDebugHTTP :: IO ()+request_url :: String -> FilePath -> Cachable -> IO String+wait_next_url :: IO (String, String)++#ifdef HAVE_CURL++setDebugHTTP = curl_enable_debug++request_url u f cache =+    withCString u $ \ustr ->+    withCString f $ \fstr -> do+      err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString+      return err++wait_next_url = do+  e <- curl_wait_next_url >>= peekCString+  u <- curl_last_url >>= peekCString+  return (u, e)++foreign import ccall "hscurl.h curl_request_url"+  curl_request_url :: CString -> CString -> CInt -> IO CString++foreign import ccall "hscurl.h curl_wait_next_url"+  curl_wait_next_url :: IO CString++foreign import ccall "hscurl.h curl_last_url"+  curl_last_url :: IO CString++foreign import ccall "hscurl.h curl_enable_debug"+  curl_enable_debug :: IO ()++#elif defined(HAVE_HTTP)++setDebugHTTP = return ()+request_url = HTTP.request_url+wait_next_url = HTTP.wait_next_url++#else++setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"+request_url _ _ _ = debugFail "URL.request_url: there is no libcurl!"+wait_next_url = debugFail "URL.wait_next_url: there is no libcurl!"++#endif++-- Usage of these environment variables happens in C code, so the+-- closest to "literate" user documentation is here, where the+-- offending function 'curl_request_url' is imported.+environmentHelpProxy :: ([String], [String])+environmentHelpProxy = (["HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY",+                         "ALL_PROXY", "NO_PROXY"], [+ "If Darcs was built with libcurl, the environment variables HTTP_PROXY,",+ "HTTPS_PROXY and FTP_PROXY can be set to the URL of a proxy in the form",+ "",+ "  [protocol://]<host>[:port]",+ "",+ "In which case libcurl will use the proxy for the associated protocol",+ "(HTTP, HTTPS and FTP).  The environment variable ALL_PROXY can be used",+ "to set a single proxy for all libcurl requests.",+ "",+ "If the environment variable NO_PROXY is a comma-separated list of host",+ "names, access to those hosts will bypass proxies defined by the above",+ "variables.  For example, it is quite common to avoid proxying requests",+ "to machines on the local network with",+ "",+ "  NO_PROXY=localhost,*.localdomain",+ "",+ "For compatibility with lynx et al, lowercase equivalents of these",+ "environment variables (e.g. $http_proxy) are also understood and are",+ "used in preference to the uppercase versions.",+ "",+ "If Darcs was not built with libcurl, all these environment variables",+ "are silently ignored, and there is no way to use a web proxy."])++environmentHelpProxyPassword :: ([String], [String])+environmentHelpProxyPassword = (["DARCS_PROXYUSERPWD"], [+ "If Darcs was built with libcurl, and you are using a web proxy that",+ "requires authentication, you can set the $DARCS_PROXYUSERPWD",+ "environment variable to the username and password expected by the",+ "proxy, separated by a colon.  This environment variable is silently",+ "ignored if Darcs was not built with libcurl."])
+ src/UTF8.lhs view
@@ -0,0 +1,173 @@+Copyright (c) 2002, members of the Haskell Internationalisation Working+Group All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+* Neither the name of the Haskell Internationalisation Working Group nor+   the names of its contributors may be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++This module provides lazy stream encoding/decoding facilities for UTF-8,+the Unicode Transformation Format with 8-bit words.++2002-09-02  Sven Moritz Hallberg <pesco@gmx.de>+++> {-# OPTIONS_GHC -cpp #-}+> module UTF8+>   ( encode ) where+++SUNSET: we should remove this module after the 2009-07 release+of darcs and just use Codec.Binary.UTF8.String instead++#ifdef HAVE_UTF8STRING+> import qualified Codec.Binary.UTF8.String (encode)+> import Data.Word (Word8)+#else+> import Data.Char (ord)+> import Data.Word (Word8, Word16, Word32)+> import Data.Bits (Bits, shiftR, (.&.), (.|.))+#endif++++///- UTF-8 in General -///++Adapted from the Unicode standard, version 3.2,+Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):++  Scalar                    1st Byte  2nd Byte  3rd Byte  4th Byte+          000000000xxxxxxx  0xxxxxxx+          00000yyyyyxxxxxx  110yyyyy  10xxxxxx+          zzzzyyyyyyxxxxxx  1110zzzz  10yyyyyy  10xxxxxx+  000uuuzzzzzzyyyyyyxxxxxx  11110uuu  10zzzzzz  10yyyyyy  10xxxxxx++Also from the Unicode standard, version 3.2,+Table 3.1B "Legal UTF-8 Byte Sequences":++  Code Points         1st Byte  2nd Byte  3rd Byte  4th Byte+    U+0000..U+007F    00..7F+    U+0080..U+07FF    C2..DF    80..BF+    U+0800..U+0FFF    E0        A0..BF    80..BF+    U+1000..U+CFFF    E1..EC    80..BF    80..BF+    U+D000..U+D7FF    ED        80..9F    80..BF+    U+D800..U+DFFF    ill-formed+    U+E000..U+FFFF    EE..EF    80..BF    80..BF+   U+10000..U+3FFFF   F0        90..BF    80..BF    80..BF+   U+40000..U+FFFFF   F1..F3    80..BF    80..BF    80..BF+  U+100000..U+10FFFF  F4        80..8F    80..BF    80..BF++++///- Encoding Functions -///++Must the encoder ensure that no illegal byte sequences are output or+can we trust the Haskell system to supply only legal values?+For now I include error case for the surrogate values U+D800..U+DFFF and+out-of-range scalars.++The function is pretty much a transscript of table 3.1B with error checks.+It dispatches the actual encoding to functions specific to the number of+required bytes.++#ifndef HAVE_UTF8STRING+> encodeOne :: Char -> [Word8]+> encodeOne c+>-- The report guarantees in (6.1.2) that this won't happen:+>--   | n < 0       = error "encodeUTF8: ord returned a negative value"+>     | n < 0x0080  = encodeOne_onebyte n8+>     | n < 0x0800  = encodeOne_twobyte n16+>     | n < 0xD800  = encodeOne_threebyte n16+>     | n < 0xE000  = error "encodeUTF8: ord returned a surrogate value"+>     | n < 0x10000       = encodeOne_threebyte n16+>-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.+>     | n < 0x10FFFF      = encodeOne_fourbyte n32+>     | otherwise  = error "encodeUTF8: ord returned a value above 0x10FFFF"+>     where+>     n = ord c            :: Int+>     n8 = fromIntegral n  :: Word8+>     n16 = fromIntegral n :: Word16+>     n32 = fromIntegral n :: Word32+#endif+++With the above, a stream decoder is trivial:+++> encode :: [Char] -> [Word8]+#ifdef HAVE_UTF8STRING+> encode = Codec.Binary.UTF8.String.encode+#else+> encode = concatMap encodeOne+#endif+++Now follow the individual encoders for certain numbers of bytes...+          _+         / |  __  ___  __ __+        / ^| //  /__/ // //+       /.==| \\ //_  // //+It's  //  || // \_/_//_//_  and it's here to stay!++#ifndef HAVE_UTF8STRING+> encodeOne_onebyte :: Word8 -> [Word8]+> encodeOne_onebyte cp = [cp]+#endif+++00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx++#ifndef HAVE_UTF8STRING+> encodeOne_twobyte :: Word16 -> [Word8]+> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]+>     where+>     xs, ys :: Word8+>     ys = fromIntegral (shiftR cp 6)+>     xs = (fromIntegral cp) .&. 0x3F+#endif+++zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx++#ifndef HAVE_UTF8STRING+> encodeOne_threebyte :: Word16 -> [Word8]+> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]+>     where+>     xs, ys, zs :: Word8+>     xs = (fromIntegral cp) .&. 0x3F+>     ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+>     zs = fromIntegral (shiftR cp 12)+#endif+++000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++#ifndef HAVE_UTF8STRING+> encodeOne_fourbyte :: Word32 -> [Word8]+> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]+>     where+>     xs, ys, zs, us :: Word8+>     xs = (fromIntegral cp) .&. 0x3F+>     ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+>     zs = (fromIntegral (shiftR cp 12)) .&. 0x3F+>     us = fromIntegral (shiftR cp 18)+#endif
+ src/Workaround.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Workaround ( renameFile, setExecutable, getCurrentDirectory,+                    installHandler, raiseSignal, Handler(..), Signal,+                    sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) where++#ifdef WIN32+import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )+import qualified Control.Exception ( block )+import qualified System.IO.Error ( isDoesNotExistError, ioError, catch )+#else+import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,+                            sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)+import System.Directory ( renameFile, getCurrentDirectory )+import System.Posix.Files (fileMode,getFileStatus, setFileMode,+                           setFileCreationMask,+                           ownerReadMode, ownerWriteMode, ownerExecuteMode,+                           groupReadMode, groupWriteMode, groupExecuteMode,+                           otherReadMode, otherWriteMode, otherExecuteMode)+import Data.Bits ( (.&.), (.|.), complement )+#endif++#ifdef WIN32+-- Dummy implementation of POSIX signals+data Handler = Default | Ignore | Catch (IO ())+type Signal = Int++installHandler :: Signal -> Handler -> Maybe () -> IO ()+installHandler _ _ _ = return ()++raiseSignal :: Signal -> IO ()+raiseSignal _ = return ()++sigINT, {- sigKILL, -} sigHUP, {- sigQUIT, -} sigABRT, sigALRM, sigTERM, sigPIPE :: Signal+sigINT = 0+-- not used: sigKILL = 0+sigHUP = 0+-- not used: sigQUIT = 0+sigABRT = 0+sigTERM = 0+sigPIPE = 0+sigALRM = 0++{-+System.Directory.renameFile incorrectly fails when the new file already+exists.  This code works around that bug at the cost of losing atomic+writes.+-}++renameFile :: FilePath -> FilePath -> IO ()+renameFile old new = Control.Exception.block $+   System.Directory.renameFile old new+   `System.IO.Error.catch` \_ ->+   do System.Directory.removeFile new+        `System.IO.Error.catch`+         (\e -> if System.IO.Error.isDoesNotExistError e+                   then return ()+                   else System.IO.Error.ioError e)+      System.Directory.renameFile old new++setExecutable :: FilePath -> Bool -> IO ()+setExecutable _ _ = return ()++{-+System.Directory.getCurrentDirectory returns a path with backslashes in it+under windows, and some of the code gets confused by that, so we override+getCurrentDirectory and translates '\\' to '/'+-}++getCurrentDirectory :: IO FilePath+getCurrentDirectory = do d <- System.Directory.getCurrentDirectory+                         return $ map rb d+    where rb '\\' = '/'+          rb c = c++#else++setExecutable :: FilePath -> Bool -> IO ()+setExecutable f ex =+  do st <- getFileStatus f+     umask <- setFileCreationMask 0+     setFileCreationMask umask+     let rw = fileMode st .&.+              (ownerReadMode .|. ownerWriteMode .|.+               groupReadMode .|. groupWriteMode .|.+               otherReadMode .|. otherWriteMode)+         total = if ex then rw .|.+                           ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)+                            .&. complement umask)+                       else rw+     setFileMode f total++#endif
+ src/atomic_create.c view
@@ -0,0 +1,181 @@+/*+  Copyright (C) 2005 Juliusz Chroboczek++  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.+*/++#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+#include <string.h>+#include <stdio.h>+#include <stdlib.h>++#include <unistd.h>+#include <errno.h>+#include <sys/time.h>++#ifdef _WIN32+#include <windows.h>+#include <io.h>+#endif++int sloppy_atomic_create(const char *p)+{+    int fd;+    fd = open(p, O_WRONLY | O_EXCL | O_CREAT, 0666);+    if(fd < 0)+        return -1;+    close(fd);+    return 1;+}++#ifdef _WIN32++int atomic_create(const char *p)+{+    return sloppy_atomic_create(p);+}++#else++static int careful_atomic_create(const char *p)+{+    /* O_EXCL is not available over NFSv2, and even under NFSv3, it is+       broken on many systems.  The following protocol is provably+       safe assuming that:+       - creation of hard links is atomic;+       - stat hits the server rather than working from the cache.+    */++    static char hostname[65] = {'\0'};+    int fd, rc, saved_errno;+#define FILENAME_SIZE (11 + 15 + 8 + 1)+    char *filename;+    char *lastslash;+    int dirlen;+    struct timeval now;+    struct stat sb;++    if(hostname[0] == '\0') {+        char *c;+        int i;+        /* POSIX guarantees 65 is enough. */+        rc = gethostname(hostname, 65);+        if(rc < 0 || rc >= 65) {+            fprintf(stderr, "Error reading hostname when locking.\n");+            strcpy(hostname, "kremvax");+        }+        c = strchr(hostname, '.');+        if(c != NULL)+            *c = '\0';+        hostname[15] = '\0';+        /* clean up a few possible nasty characters folks might put in their hostname */+        for (i=0;i<15;i++)+          if (hostname[i] == ':' || hostname[i] == '/' || hostname[i] == '\\')+            hostname[i] = '-';+    }++    lastslash = strrchr(p, '/');+    dirlen = lastslash ? lastslash - p + 1 : 0;++    filename = malloc(dirlen + FILENAME_SIZE);+    if(filename == NULL)+        return -1;++    if(dirlen > 0)+        memcpy(filename, p, dirlen);+    filename[dirlen] = '\0';++    gettimeofday(&now, NULL);++    rc = snprintf(filename + dirlen, FILENAME_SIZE, "darcs_lock_%s%04x%04x",+                  hostname, ((unsigned)getpid()) & 0xFFFF,+                  ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF);+    if(rc < 0 || rc >= FILENAME_SIZE) {+        fprintf(stderr, "Error writing to lock filename (%d)\n", +                rc < 0 ? errno : 0);+        goto fail2;+    }++    fd = open(filename, O_WRONLY | O_EXCL | O_CREAT, 0666);+    if(fd < 0)+        goto fail2;++    /* Paranoia: should cause the client to flush its metadata cache. */+    rc = close(fd);+    if(rc < 0) {+        fprintf(stderr, "Error closing file %s. (%d)\n", filename, errno);+        goto fail;+    }++    rc = link(filename, p);+    if(rc >= 0)+        goto success;+    else if(errno == EPERM || errno == EOPNOTSUPP) {+        /* Linux returns EPERM when making hard links on filesystems+           that don't support them. */+        /* It seems that MacOS returns EOPNOTSUPP on filesystems that+           don't support hard links. */+        unlink(filename);+        free(filename);+        return sloppy_atomic_create(p);+    } else if(errno != EEXIST && errno != EIO)+        goto fail;++    /* The link may still have been successful if we're running over+       UDP and got EEXIST or EIO.  Check the file's link count. */++    rc = stat(filename, &sb);+    if(rc < 0) {+        goto fail;+    }++    if(sb.st_nlink != 2) {+        errno = EEXIST;+        goto fail;+    }++ success:+    unlink(filename);+    free(filename);+    return 1;++ fail:+    saved_errno = errno;+    unlink(filename);+    errno = saved_errno;+ fail2:+    free(filename);+    return -1;+}++int atomic_create(const char *p)+{+    static int sloppy = -1;++    if(sloppy < 0) {+        char *s = getenv("DARCS_SLOPPY_LOCKS");+        sloppy = (s != NULL);+    }++    if(sloppy)+        return sloppy_atomic_create(p);+    else+        return careful_atomic_create(p);+}++#endif
+ src/atomic_create.h view
@@ -0,0 +1,25 @@++#include <sys/stat.h>+#include <string.h>+#include <stdlib.h>++int sloppy_atomic_create(const char *p);+int atomic_create(const char *p);++#ifdef _WIN32+int mkstemp(char *p);+int pipe( int fildes[2] );+int renamefile(const char *from, const char *to);+#endif++int open_read(const char *fname);+int open_write(const char *fname);+int smart_wait(int pid);++int execvp_no_vtalarm(const char *file, char *const argv[]);++int is_symlink(const char *file);++int stdout_is_a_pipe();++int maybe_relink(const char *src, const char *dst, int careful);
+ src/best_practices.tex view
@@ -0,0 +1,611 @@+% This file (unlike the rest of darcs) is in the public domain.+ ++\chapter{Best practices}++This chapter is intended to review various scenarios and describe in each+case effective ways of using darcs.  There is no one ``best practice'', and+darcs is a sufficiently low-level tool that there are many high-level ways+one can use it, which can be confusing to new users.  The plan (and hope)+is that various users will contribute here describing how they use darcs in+different environments.  However, this is not a wiki, and contributions+will be edited and reviewed for consistency and wisdom.+++\section{Creating patches}++This section will lay down the concepts around patch creation.+The aim is to develop a way of thinking+that corresponds well to how darcs is behaving+--- even in complicated situations.++	In a single darcs repository you can think of two ``versions'' of the source tree.+	They are called the \emph{working} and \emph{pristine} trees.+    \emph{Working} is your normal source tree, with or without darcs alongside.+	The only thing that makes it part of a darcs repository+	is the \verb!_darcs! directory in its root.+    \emph{Pristine} is the recorded state of the source tree.+	The pristine tree is constructed from groups of changes,+        called {\em patches\/} (some other version control systems use the+	term {\em changeset\/} instead of {\em patch\/}).\footnote{If+	you look inside \_darcs you will find files or directories named+	{\tt patches} and {\tt inventories}, which store all the patches+          ever recorded.  If the repository holds a cached pristine tree, it+          is stored in a directory called {\tt pristine} or {\tt current\/};+          otherwise, the fact that there is no pristine tree is marked+          by the presence of a file called {\tt pristine.none} or {\tt+            current.none}.}+	Darcs will create and store these patches+	based on the changes you make in \emph{working}.+++\subsection{Changes}+	If \emph{working} and \emph{pristine} are the same,+	there are ``no changes'' in the repository.+	Changes can be introduced (or removed) by editing the files in \emph{working}.+	They can also be caused by darcs commands,+	which can modify \emph{both} \emph{working} and \emph{pristine}.+	It is important to understand for each darcs command+	how it modifies \emph{working}, \emph{pristine} or both of them.++	\verb!whatsnew! (as well as \verb!diff!) can show+	the difference between \emph{working} and \emph{pristine} to you.+	It will be shown as a difference in \emph{working}.+	In advanced cases it need \emph{not} be \emph{working} that has changed;+	it can just as well have been \emph{pristine}, or both.+	The important thing is the difference and what darcs can do with it.++\subsection{Keeping or discarding changes}+    If you have a difference in \emph{working}, you do two things+    with it: \verb!record! it to keep it, or \verb!revert! it to lose the changes.%+		\footnote{%+		Revert can undo precious work in a blink.+		To protect you from great grief,+		the discarded changes are saved temporarily+		so the latest revert can be undone with unrevert.}++	If you have a difference between \emph{working} and \emph{pristine}%+	---for example after editing some files in \emph{working}---%+	\verb!whatsnew! will show some ``unrecorded changes''.+	To save these changes, use \verb!record!.+	It will create a new patch in \emph{pristine} with the same changes,+	so \emph{working} and \emph{pristine} are no longer different.+	To instead undo the changes in \emph{working}, use \verb!revert!.+	It will modify the files in \emph{working} to be the same as in \emph{pristine}+	(where the changes do not exist).+++\subsection{Unrecording changes}+    \verb!unrecord! is a command meant to be run only in private+    repositories. Its intended purpose is to allow developers the flexibility+    to undo patches that haven't been distributed yet.++    However, darcs does not prevent you from unrecording a patch that+    has been copied to another repository. Be aware of this danger!++	If you \verb!unrecord! a patch, that patch will be deleted from \emph{pristine}.+	This will cause \emph{working} to be different from \emph{pristine},+	and \verb!whatsnew! to report unrecorded changes.+	The difference will be the same as just before that patch was \verb!record!ed.+	Think about it.+	\verb!record! examines what's different with \emph{working}+	and constructs a patch with the same changes in \emph{pristine}+	so they are no longer different.+	\verb!unrecord! deletes this patch;+	the changes in \emph{pristine} disappear and the difference is back.++	If the recorded changes included an error,+	the resulting flawed patch can be unrecorded.+	When the changes have been fixed,+	they can be recorded again as a new---hopefully flawless---patch.++	If the whole change was wrong it can be discarded from \emph{working} too,+	with \verb!revert!.+	\verb!revert! will update \emph{working} to the state of \emph{pristine},+	in which the changes do no longer exist after the patch was deleted.++	Keep in mind that the patches are your history,+	so deleting them with \verb!unrecord! makes it impossible to track+	what changes you \emph{really} made.+	Redoing the patches is how you ``cover the tracks''.+	On the other hand,+	it can be a very convenient way to manage and organize changes+	while you try them out in your private repository.+	When all is ready for shipping,+	the changes can be reorganized in what seems as useful and impressive patches.+	Use it with care.++	All patches are global,+	so don't \emph{ever} replace an already ``shipped'' patch in this way!+	If an erroneous patch is deleted and replaced with a better one,+	you have to replace it in \emph{all} repositories that have a copy of it.+	This may not be feasible, unless it's all private repositories.+	If other developers have already made patches or tags in their repositories+	that depend on the old patch, things will get complicated.+++\subsection{Special patches and pending}++The patches described in the previous sections have mostly been hunks.+A \emph{hunk} is one of darcs' primitive patch types,+and it is used to remove old lines and/or insert new lines.+There are other types of primitive patches,+such as \emph{adddir} and \emph{addfile}+which add new directories and files,+and \emph{replace}+which does a search-and-replace on tokens in files.++Hunks are always calculated in place with a diff algorithm+just before \verb!whatsnew! or \verb!record!.+But other types of primitive patches need to be explicitly created+with a darcs command.+They are kept in \emph{pending}%+\footnote{In the file {\tt\_darcs/patches/pending}.}+until they are either recorded or reverted.++\emph{Pending} can be thought of as a special extension of \emph{working}.+When you issue, e.g., a darcs \verb!replace! command,+the replace is performed on the files in \emph{working}+and at the same time a replace patch is put in \emph{pending}.+Patches in \emph{pending} describe special changes made in \emph{working}.+The diff algorithm will fictively apply these changes to \emph{pristine}+before it compares it to \emph{working},+so all lines in \emph{working} that are changed by a \verb!replace! command+will also be changed in \emph{pending}$+$\emph{pristine}+when the hunks are calculated.+That's why no hunks with the replaced lines will be shown by \verb!whatsnew!;+it only shows the replace patch in \emph{pending} responsible for the change.++If a special patch is recorded, it will simply be moved to \emph{pristine}.+If it is instead reverted, it will be deleted from \emph{pending}+and the accompanying change will be removed from \emph{working}.++Note that reverting a patch in pending is \emph{not} the same as+simply removing it from pending.+It actually applies the inverse of the change to \emph{working}.+Most notable is that reverting an addfile patch+will delete the file in \emph{working} (the inverse of adding it).+So if you add the wrong file to darcs by mistake,+\emph{don't} \verb!revert! the addfile.+Instead use \verb!remove!, which cancels out the addfile in pending.+++\section{Using patches} % still basics++This section will lay down the concepts around patch distribution and branches.+The aim is to develop a way of thinking+that corresponds well to how darcs is behaving+--- even in complicated situations.++A repository is a collection of patches.+Patches have no defined order,+but patches can have dependencies on other patches.+Patches can be added to a repository in any order+as long as all patches depended upon are there.+Patches can be removed from a repository in any order,+as long as no remaining patches depend on them.++Repositories can be cloned to create branches.+Patches created in different branches may conflict.+A conflict is a valid state of a repository.+A conflict makes the working tree ambiguous until the conflict is resolved.+++\subsection{Dependencies}++There are two kinds of dependencies:+implicit dependencies and explicit dependencies.++Implicit dependencies is the far most common kind.+These are calculated automatically by darcs.+If a patch removes a file or a line of code,+it will have to depend on the patch that added that file or line of code.\footnote{%+Actually it doesn't have to---in theory---,+but in practice it's hard to create ``negative'' files or lines in the working tree.+See the chapter about Theory of patches for other constraints.}+If a patch adds a line of code,+it will usually have to depend on the patch or patches that added the adjacent lines.++Explicit dependencies can be created if you give the \verb|--ask-deps| option to \verb|darcs record|.+This is good for assuring that logical dependencies hold between patches.+It can also be used to group patches---%+a patch with explicit dependencies doesn't need to change anything---%+and pulling the patch also pulls all patches it was made to depend on.+++\subsection{Branches: just normal repositories}++Darcs does not have branches---it doesn't need to.+Every repository can be used as a branch.+This means that any two repositories are ``branches'' in darcs,+but it is not of much use unless they have a large portion of patches in common.+If they are different projects they will have nothing in common,+but darcs may still very well be able to merge them,+although the result probably is nonsense.+Therefore the word ``branch'' isn't a technical term in darcs;+it's just the way we think of one repository in relation to another.++Branches are \emph{very} useful in darcs.+They are in fact \emph{necessary} if you want to do more than only simple work.+When you \verb|get| someone's repository from the Internet,+you are actually creating a branch of it.+It may first seem inefficient (or if you come from CVS---frightening),+not to say plain awkward.+But darcs is designed this way, and it has means to make it efficient.+The answer to many questions about how to do a thing with darcs is: ``use a branch''.+It is a simple and elegant solution with great power and flexibility,+which contributes to darcs' uncomplicated user interface.++You create new branches (i.e., clone repositories)+with the \verb|get| and \verb|put| commands.+++\subsection{Moving patches around---no versions}++Patches are global, and a copy of a patch either is or is not present in a branch.+This way you can rig a branch almost any way you like,+as long as dependencies are fulfilled---%+darcs \emph{won't} let you break dependencies.+If you suspect a certain feature from some time ago introduced a bug,+you can remove the patch/patches that adds the feature,+and try without it.\footnote{%+darcs even has a special command, {\tt trackdown}+that automatically removes patches+until a specified test no longer fails.}++Patches are added to a repository with \verb|pull|+and removed from the repositories with \verb|obliterate|.+Don't confuse these two commands with \verb|record| and \verb|unrecord|,+which constructs and deconstructs patches.++It is important not to lose patches when (re)moving them around.+\verb|pull| needs a source repository to copy the patch from,+whereas \verb|obliterate| just erases the patch.+Beware that if you obliterate \emph{all} copies of a patch+it is completely lost---forever.+Therefore you should work with branches when you obliterate patches.+The \verb|obliterate| command can wisely be disabled in a dedicated main repository+by adding \verb|obliterate disable| to the repository's defaults file.++For convenience, there is a \verb|push| command.+It works like \verb|pull| but in the other direction.+It also differs from \verb|pull| in an important way:+it starts a second instance of darcs to apply the patch in the target repository,+even if it's on the same computer.+It can cause surprises if you have a ``wrong'' darcs in your PATH.+++\subsection{Tags---versions}++While \verb|pull| and \verb|obliterate| can be used to+construct different ``versions'' in a repository,+it is often desirable to name specific configurations of patches+so they can be identified and retrieved easily later.+This is how darcs implements what is usually known as versions.+The command for this is \verb|tag|,+and it records a tag in the current repository.++A tag is just a patch, but it only contains explicit dependencies.+It will depend on all the patches in the current repository.\footnote{%+It will omit patches already depended upon by other patches,+since they will be indirectly depended upon anyway.}+Darcs can recognize if a patch is as a tag;+tags are sometimes treated specially by darcs commands.++While traditional revision control systems tag versions in the time line history,+darcs lets you tag any configuration of patches at any time,+and pass the tags around between branches.++With the option \verb|--tag| to \verb|get| you can easily get+a named version in the repository+as a new branch.+++\subsection{Conflicts}++This part of darcs becomes a bit complicated,+and the description given here is slightly simplified.++Conflicting patches are created when+you record changes to the same line in two different repositories.+Same line does \emph{not} mean the same line number and file name,+but the same line added by a common depended-upon patch.++If you are using a darcs-2 repository (Section \ref{initialize}),+darcs does \emph{not} consider two patches making the \emph{same} change to be a+conflict, much in the same fashion as other version control systems.+(The caveat here is two non-identical patches with some identical+changes may conflict.  For the most part, darcs should just do what you+expect).++A conflict \emph{happens} when two conflicting patches meet in the same repository.+This is no problem for darcs; it can happily pull together just any patches.+But it is a problem for the files in \emph{working} (and \emph{pristine}).+The conflict can be thought of as+two patches telling darcs different things about what a file should look like.++Darcs escapes this problem+by ignoring those parts\footnote{%+The primitive patches making up the total patch.}+of the patches that conflict.+They are ignored in \emph{both} patches.+If patch~A changes the line ``FIXME'' to ``FIXED'',+and patch~B changes the same line to ``DONE'',+the two patches together will produce the line ``FIXME''.+Darcs doesn't care which one you pulled into the repository first,+you still get the same result when the conflicting patches meet.+All other changes made by A and B are performed as normal.++Darcs can mark a conflict for you in \emph{working}.+This is done with \verb|mark-conflicts|.+Conflicts are marked such that both conflicting changes+are inserted with special delimiter lines around them.+Then you can merge the two changes by hand,+and remove the delimiters.++When you pull patches,+darcs automatically performs a \verb|mark-conflicts| for you if a conflict happens.+You can remove the markup with \verb|revert|,+Remember that the result will be the lines from+the previous version common to both conflicting patches.+The conflict marking can be redone again with \verb|mark-conflicts|.++A special case is when a pulled patch conflicts with unrecorded changes in the repository.+The conflict will be automatically marked as usual,+but since the markup is \emph{also} an unrecorded change,+it will get mixed in with your unrecorded changes.+There is no guarantee you can revert \emph{only} the markup after this,+and \verb|resolve| will not be able to redo this markup later if you remove it.+It is good practice to record important changes before pulling.++\verb|mark-conflicts| can't mark complicated conflicts.+In that case you'll have to use \verb|darcs diff| and other commands+to understand what the conflict is all about.+If for example two conflicting patches create the same file,+\verb|mark-conflicts| will pick just one of them,+and no delimiters are inserted.+So watch out if darcs tells you about a conflict.++\verb|mark-conflicts| can also be used to check for unresolved conflicts.+If there are none, darcs replies ``No conflicts to resolve''.+While \verb|pull| reports when a conflict happens,+\verb|obliterate| and \verb|get| don't.+++\subsection{Resolving conflicts}++A conflict is resolved+(not marked, as with the command \verb|mark-conflicts|)+as soon as some new patch depends on the conflicting patches.+This will usually be the resolve patch you record after manually putting together the pieces+from the conflict markup produced by \verb|mark-conflicts| (or \verb|pull|).+But it can just as well be a tag.+So don't forget to fix conflicts before you accidently ``resolve'' them by recording other patches.++If the conflict is with one of your not-yet-published patches,+you may choose to amend that patch rather than creating a resolve patch.++If you want to back out and wait with the conflict,+you can \verb|obliterate| the conflicting patch you just pulled.+Before you can do that you have to \verb|revert| the conflict markups+that \verb|pull| inserted when the conflict happened.++\section{Use a Global Cache}++When working with darcs 2 it is recommended to use a global cache, as this+is one of the biggest performance enhancing tools of darcs 2.  The global+cache acts as a giant patch pool where darcs first looks for a patch when+grabbing new patches. This saves time by not downloading the same patch+twice from a remote server. It also saves space by storing the patch only+once, if you ensure your cache and your repositories are on the same+hardlink-supporting filesystem. ++Darcs now enables a global patch cache under your home directory by default.+Older darcs 2.x versions required this manual step:++\begin{verbatim}+$ mkdir -p $HOME/.darcs/cache+$ echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources+\end{verbatim}++On MS Windows~\ref{ms_win}, using \verb|cmd.exe| (Command Prompt under Accessories):++\begin{verbatim}+> md "%UserProfile%\Application Data\darcs\cache" (notice double quotes!)+> echo cache:%UserProfile%\Application Data\darcs\cache > "%UserProfile%\Application Data\darcs\sources"+\end{verbatim}++There are some other advanced things you can do in \verb!_darcs/prefs/sources!,+such as create per-repository caches, read-only caches and even set a+primary source repository above any used in a \verb|darcs get| or +\verb|darcs pull| command.++\section{Distributed development with one primary developer}+\label{darcs-development-practices}++This is how darcs itself is developed.  There are many contributors to+darcs, but every contribution is reviewed and manually applied by myself.+For this sort of a situation, \verb|darcs send| is ideal, since the barrier for+contributions is very low, which helps encourage contributors.++One could simply set the \verb!_darcs/prefs/email! value to the project+mailing list, but I also use darcs send to send my changes to the main+server, so instead the email address is set to+``\verb!Davids Darcs Repo <droundy@abridgegame.org>!''.  My+\verb-.procmailrc-+file on the server has the following rule:+\begin{verbatim}+:0+* ^TODavids Darcs Repo+|(umask 022; darcs apply --reply darcs-devel@abridgegame.org \+             --repodir /path/to/repo --verify /path/to/allowed_keys)+\end{verbatim}+This causes darcs apply to be run on any email sent to ``Davids Darcs+Repo''.+\verb'apply' actually applies them only if they are signed by an+authorized key.  Currently, the only authorized key is mine, but of course+this could be extended easily enough.++The central darcs repository contains the following values in its+\verb!_darcs/prefs/defaults!:+\begin{verbatim}+apply test+apply verbose+apply happy-forwarding+\end{verbatim}+The first line tells apply to always run the test suite.  The test suite is+in fact the main reason I use send rather than push, since it allows me to+easily continue working (or put my computer to sleep) while the tests are+being run on the main server.  The second line is just there to improve the+email response that I get when a patch has either been applied or failed+the tests.  The third line makes darcs not complain about unsigned patches,+but just to forward them to \verb!darcs-devel!.++On my development computer, I have in my \verb!.muttrc! the following+alias, which allows me to easily apply patches that I get via email+directly to my darcs working directory:+\begin{verbatim}+macro pager A "<pipe-entry>(umask 022; darcs apply --no-test -v \+        --repodir ~/darcs)"+\end{verbatim}+++\section{Development by a small group of developers in one office}+\label{dft-development-practices}++This section describes the development method used for the density+functional theory code DFT++, which is available at+\verb!http://dft.physics.cornell.edu/dft!.++We have a number of workstations which all mount the same \verb!/home! via NFS.+We created a special ``dft'' user, with the central repository living in that+user's home directory.  The ssh public keys of authorized persons are added to+the ``dft'' user's \verb!.ssh/allowed_keys!, and we commit patches to this+repository using+\verb'darcs push'.  As in Section~\ref{darcs-development-practices},+we have the central repository set to run the test suite before the push goes+through.++Note that no one ever runs as the dft user.++A subtlety that we ran into showed up in the running of the test suite.+Since our test suite includes the running of MPI programs, it must be run+in a directory that is mounted across our cluster.  To achieve this, we set+the \verb!$DARCS_TMPDIR! % following is added to make emacs color right:$+environment variable to \verb!~/tmp!.++Note that even though there are only four active developers at the moment,+the distributed nature of darcs still plays a large role.  Each developer+works on a feature until it is stable, a process that often takes quite a+few patches, and only once it is stable does he+\verb'push' to the central repository.++\section{Personal development}++It's easy to have several personal development trees using darcs, even+when working on a team or with shared code.  The number and method of+using each personal tree is limited only by such grand limitations as:+your disk space, your imagination, available time, etc.++For example, if the central darcs repository for your development team+is $R_{c}$, you can create a local working directory for feature+$f_1$.  This local working directory contains a full copy of $R_c$+(as of the time of the ``darcs get'' operation) and can be denoted+$R_1$.  In the midst of working on feature $f_1$, you realize it+requires the development of a separate feature $f_2$.  Rather than+intermingling $f_1$ and $f_2$ in the same working tree, you can create+a new working tree for working on $f_2$, where that working tree+contains the repository $R_2$.++While working on $f_2$, other developers may have made other changes;+these changes can be retrieved on a per-patch selection basis by+periodic ``darcs pull'' operations.++When your work on $f_2$ is completed, you can publish it for the use+of other developers by a ``darcs push'' (or ``darcs send'') from $R_2$+to $R_c$.  Independently of the publishing of $f_2$, you can merge+your $f_2$ work into your $f_1$ working tree by a ``darcs pull $R_2$''+in the $R_1$ development tree (or ``darcs push'' from $R_2$ to $R_1$).++When your work on $f_1$ is completed, you publish it as well by a+``darcs push'' from $R_1$ to $R_c$.  ++Your local feature development efforts for $f_1$ or $f_2$ can each+consist of multiple patches.  When pushing or pulling to other trees,+these patches can either all be selected or specific patches can be+selected.  Thus, if you introduce a set of debugging calls into the+code, you can commit the debugging code in a distictly separate patch+(or patches) that you will not push to $R_c$.++\subsection{Private patches}++As discussed in the section above, a developer may have various+changes to their local development repositories that they do not ever+wish to publish to a group repository (e.g. personal debugging code),+but which they would like to keep in their local repository, and+perhaps even share amongst their local repositories.++This is easily done via darcs, since those private changes can be+committed in patches that are separate from other patches; during the+process of pushing patches to the common repository ($R_c$), the+developer is queried for which patches should be moved to ($R_c$) on a+patch-by-patch basis.++The \verb!--complement! flag for the ``darcs pull'' operation can+further simplify this effort.  If the developer copies (via ``darcs+push'' or ``darcs pull'') all private patches into a special+repository/working tree ($R_p$), then those patches are easily+disregarded for pulling by adding \verb!--complement! to the ``darcs+pull'' line and listing $R_p$ after the primary source repository.++The \verb!--complement! flag is only available for ``darcs pull'', and+not ``darcs push'' or ``darcs send'', requiring the user to have pull+access to the target repository.  While the actual public repository+is often not shared in this manner, it's simple to create a local+version of the public repository to act as the staging area for that+public repository.++The following example extends the two feature addition example in the+previous section using a local staging repository ($R_l$) and a+private patch repository:++\begin{verbatim}+$ cd working-dir+$ darcs get http://server/repos/Rc Rl++$ darcs get Rl R1+$ cd R1+...development of f1+$ darcs record -m'p1: f1 initial work'+...+$ darcs record -m'p2: my debugging tracepoints'+...++$ cd ..+$ darcs get http://server/repos/Rc R2+$ cd R2+$ darcs pull -p p2 ../R1+... development of f2+$ darcs record -m'p3: f2 finished'++$ cd ..+$ darcs get Rl Rp+$ cd Rp+$ darcs pull -p p2 ../R2++$ cd ../Rl+$ darcs pull --complement ../R2 ../Rp+$ darcs send+... for publishing f2 patches to Rc++$ cd ../R1+$ darcs pull ../R2+... updates R1 with f2 changes from R2+... more development of f1+$ darcs record -m'p4: f1 feature finished.'++$ cd ../Rl+$ darcs pull --complement ../R1 ../Rp+$ darcs send+\end{verbatim}+
+ src/building_darcs.tex view
@@ -0,0 +1,93 @@+\chapter{Building darcs}+\section{The Easy Way}+If your distribution provides a pre-built binary package of a recent+Darcs release, you are strongly encouraged to use that rather than+building Darcs yourself.++If you have (or can install) the \texttt{cabal-install} package, this+is the next best option, as this will resolve build dependencies+automatically.  To download, compile and install Darcs and its+dependencies via cabal-install, simply run+\begin{verbatim}+cabal update+cabal install darcs+\end{verbatim}++\section{The Hard Way}+If you cannot install \texttt{cabal-install}, you need to run+\begin{verbatim}+ghc --make Setup+./Setup configure+./Setup build+./Setup install+\end{verbatim}++This will require the following build dependencies:+\begin{itemize}+\item GHC 6.8 or higher; and+\item Cabal 1.6 or higher.+\end{itemize}++%% Note: darcs.cabal tends to have build dependencies [x,y), but I+%% couldn't work out a way to describe this concisely (and+%% intelligibly to non-mathematicians).  So I have lied and simply+%% said `or higher', since the upper bounds usually only declare+%% incompatibility with versions that don't exist yet. --twb, 2009++Additional build dependencies are declared in the \texttt{darcs.cabal}+file, and \texttt{./Setup configure} will tell you if any required+build dependencies aren't found.  The build dependencies at time of+writing (Darcs 2.3) are as follows:+\begin{itemize}+\item the C library zlib;+\item the Haskell packages+  \begin{itemize}+  \item array 1.1 or 1.2;+  \item containers 1.1 or 1.2;+  \item directory 1.0;+  \item filepath 1.1;+  \item hashed-storage 0.3;+  \item haskeline 0.6.1 or higher;+  \item html 1.0;+  \item mtl 1.0 or 1.1;+  \item old-time 1.0;+  \item parsec 2.1 or higher;+  \item process 1.0;+  \item random 1.0; and+  \item regex-compat 0.71 or higher.+  \end{itemize}+\end{itemize}++Missing \emph{optional} build dependencies are only listed if+\texttt{./Setup configure} is passed the \texttt{--verbose} argument.+At time of writing they are:+\begin{itemize}+\item the C library libcurl (7.19.1 or higher recommended);+\item the Haskell packages+  \begin{itemize}+  \item bytestring 0.9;+  \item bytestring-mmap 0.2 or higher;+  \item http 3000 or 3001.1;+  \item network 2.2;+  \item terminfo 0.3.+  \item utf8-string 0.3; and+  \item zlib 0.5.+  \end{itemize}+\end{itemize}++\section{The Old Way}+Darcs can still be built with GNU autotools; this approach is+deprecated and will be removed after the 2.3 release.  Run+\begin{verbatim}+autoconf+./configure+make+make install+\end{verbatim}++The build dependencies are identical to the previous approach, except+that instead of the \texttt{Cabal} package, you will need+\begin{itemize}+\item GNU Make; and+\item GNU autoconf 2.50 or higher.+\end{itemize}
+ src/c_compat.c view
@@ -0,0 +1,88 @@++#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+#include <string.h>+#include <stdio.h>+#include <stdlib.h>++#include <unistd.h>+#include <errno.h>+#include <sys/time.h>+#include <time.h>++#ifdef _WIN32+#include <windows.h>+#include <io.h>+#endif++#ifndef _WIN32++int open_read(const char *fname) {+  return open(fname, O_RDONLY);+}++int open_write(const char *fname) {+  return open(fname, O_WRONLY | O_TRUNC | O_CREAT,+              S_IWUSR | S_IRUSR | S_IROTH | S_IRGRP);+}++int get_errno() {+  return errno;+}++#include <sys/wait.h>+#include <signal.h>+#if  HAVE_SIGINFO_H+#include <siginfo.h>+#endif++/* This waits and then returns the exit status of the process that was+   waited for. */+int smart_wait(int pid) {+  int stat;+  pid_t rc;++  do {+      rc = waitpid(pid, &stat, 0);+  } while(rc < 0 && errno == EINTR);++  if(rc < 0) {+    perror("waitpid");+    return -138;+  } else if (WIFEXITED(stat)) {+    return WEXITSTATUS(stat);+  } else if (WIFSIGNALED(stat)) {+    /* Fixme: psignal isn't portable (not in POSIX).  */+    psignal(WTERMSIG(stat), "Error in subprocess");+    return - WTERMSIG(stat);+  } else {+    return -137;+  }+}++#include <unistd.h>+#include <sys/time.h>+#include <errno.h>+#include <stdio.h>++int execvp_no_vtalarm(const char *file, char *const argv[]) {+  /* Reset the itimers in the child, so it doesn't get plagued+   * by SIGVTALRM interrupts.+   */+  struct timeval tv_null = { 0, 0 };+  struct itimerval itv;+  itv.it_interval = tv_null;+  itv.it_value = tv_null;+  setitimer(ITIMER_REAL, &itv, NULL);+  setitimer(ITIMER_VIRTUAL, &itv, NULL);+  setitimer(ITIMER_PROF, &itv, NULL);+  execvp(file, argv);+  perror("Error in execvp");+  return errno;+}++#include <sys/types.h>+#include <sys/stat.h>+#endif+
+ src/compat.h view
@@ -0,0 +1,12 @@++#include <sys/stat.h>+#include <string.h>+#include <stdlib.h>++int open_read(const char *fname);+int open_write(const char *fname);+int smart_wait(int pid);+int get_errno();++int execvp_no_vtalarm(const char *file, char *const argv[]);+
+ src/configuring_darcs.tex view
@@ -0,0 +1,264 @@+%  Copyright (C) 2004 David Roundy+%+%  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; if not, write to the Free Software Foundation,+%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++\chapter{Configuring darcs}\label{configuring}++There are several ways you can adjust darcs' behavior to suit your needs.+The first is to edit files in the \verb!_darcs/prefs/! directory of a+repository.  Such configuration only applies when working with that+repository.  To configure darcs on a per-user rather than per-repository+basis (but with essentially the same methods), you can edit (or create)+files in the \verb!~/.darcs/! directory.+Finally, the behavior of some darcs commands can be modified by setting+appropriate environment variables.++\paragraph{Microsoft Windows}\label{ms_win}++The global darcs directory is \verb!%APPDATA%\darcs\!.  This typically expands to+\texttt{C:\textbackslash{}Documents And Settings\textbackslash{}\emph{user}\textbackslash{}Application Data\textbackslash{}darcs\textbackslash{}}.+This folder contains the cache, as well as all the per-user+settings files: preferences, boring etc... These will became the new defaults+that can be overridden on per-repository basis.++\input{Darcs/Repository/Prefs.lhs}++\input{Darcs/Repository/Motd.lhs}++\section{Environment variables}++There are a few environment variables whose contents affect darcs'+behavior.  Here is a quick list of all the variables and their+documentation in the rest of the manual:++\begin{tabular}{|l|r|}+\hline+\textbf{Variable} & \textbf{Section} \\+\hline+DARCS\_EDITOR, EDITOR, VISUAL & \ref{env:DARCS_EDITOR} \\+DARCS\_PAGER, PAGER &  \ref{env:DARCS_PAGER} \\+HOME & \ref{env:HOME} \\+TERM & \ref{env:TERM} \\+\hline+DARCS\_EMAIL, EMAIL  & \ref{env:DARCS_EMAIL} \\+\hline+DARCS\_APPLY\_FOO & \ref{env:DARCS_X_FOO} \\+DARCS\_GET\_FOO & \ref{env:DARCS_X_FOO} \\+DARCS\_MGET\_FOO & \ref{env:DARCS_X_FOO} \\+DARCS\_MGETMAX & \ref{env:DARCS_MGETMAX} \\+DARCS\_PROXYUSERPWD & \ref{env:DARCS_PROXYUSERPWD} \\+DARCS\_SSH & \ref{env:DARCS_SSH} \\+DARCS\_SCP & \ref{env:DARCS_SCP} \\+DARCS\_SFTP & \ref{env:DARCS_SFTP} \\+SSH\_PORT & \ref{env:SSH_PORT} \\+\hline+DARCS\_ALTERNATIVE\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\+DARCS\_ALWAYS\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\+DARCS\_DO\_COLOR\_LINES & \ref{env:DARCS_DO_COLOR_LINES}\\+DARCS\_DONT\_COLOR   & \ref{env:DARCS_ALWAYS_COLOR} \\+DARCS\_DONT\_ESCAPE\_TRAILING\_CR     & \ref{env:DARCS_DONT_ESCAPE_white}\\+DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES & \ref{env:DARCS_DONT_ESCAPE_white} \\+DARCS\_DONT\_ESCAPE\_8BIT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\+DARCS\_DONT\_ESCAPE\_ANYTHING & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\+DARCS\_DONT\_ESCAPE\_ISPRINT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\+DARCS\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\+DARCS\_DONT\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\+\hline+\end{tabular}++\section{General-purpose variables}++\darcsEnv{DARCS_EDITOR}+\darcsEnv{DARCS_PAGER}+\darcsEnv{DARCS_TMPDIR}+\darcsEnv{DARCS_KEEP_TMPDIR}+\darcsEnv{HOME}++\section{Remote repositories}+\darcsEnv{DARCS_SSH}+\darcsEnv{DARCS_SCP}+\darcsEnv{SSH_PORT}+\darcsEnv{HTTP_PROXY}+\darcsEnv{DARCS_PROXYUSERPWD}++\paragraph{DARCS\_GET\_FOO, DARCS\_MGET\_FOO and DARCS\_APPLY\_FOO}+\label{env:DARCS_X_FOO}+When trying to access a repository with a URL beginning foo://,+darcs will invoke the program specified by the DARCS\_GET\_FOO+environment variable (if defined) to download each file, and the+command specified by the DARCS\_APPLY\_FOO environment variable (if+defined) when pushing to a foo:// URL.  ++This method overrides all other ways of getting \verb!foo://xxx! URLs.++Note that each command should be constructed so that it sends the downloaded+content to STDOUT, and the next argument to it should be the URL\@.  Here are some+examples that should work for DARCS\_GET\_HTTP:++\begin{verbatim}+fetch -q -o -  +curl -s -f+lynx -source +wget -q -O -+\end{verbatim}++Apart from such toy examples, it is likely that you will need to+manipulate the argument before passing it to the actual fetcher+program.  For example, consider the problem of getting read access to+a repository on a CIFS (SMB) share without mount privileges:++\begin{verbatim}+export DARCS_GET_SMB="smbclient -c get"+darcs get smb://fs/twb/Desktop/hello-world+\end{verbatim}++The above command will not work for several reasons.  Firstly, Darcs+will pass it an argument beginning with `smb:', which smbclient does+not understand.  Secondly, the host and share `//fs/twb' must be+presented as a separate argument to the path `Desktop/hello-world'.+Thirdly, smbclient requires that `get' and the path be a single+argument (including a space), rather than two separate arguments.+Finally, smbclient's `get' command writes the file to disk, while+Darcs expects it to be printed to standard output.++In principle, we could get around such problems by making the variable+contain a shell script, e.g.++\begin{verbatim}+export DARCS_GET_SMB='sh -c "...; smbclient $x -c \"get $y\""'+\end{verbatim}++Unfortunately, Darcs splits the command on whitespace and does not+understand that quotation or escaping, so there is no way to make+Darcs pass the text after `-c' to sh as a single argument.  Therefore,+we instead need to put such one-liners in separate, executable scripts.++Continuing our smbclient example, we create an executable script+\verb|~/.darcs/libexec/get_smb| with the following contents:++\begin{verbatim}+#!/bin/bash -e+IFS=/ read host share file <<<"${1#smb://}"+smbclient //$host/$share -c "get $file -"+\end{verbatim}++And at last we can say++\begin{verbatim}+export DARCS_GET_SMB=~/.darcs/libexec/get_smb+darcs get smb://fs/twb/Desktop/hello-world+\end{verbatim}+++If set, DARCS\_MGET\_FOO+will be used to fetch many files from a single repository simultaneously.+Replace FOO and foo as appropriate to handle other URL schemes.+These commands are \emph{not} interpreted by a shell, so you cannot+use shell metacharacters, and the first word in the command must+be the name of an executable located in your path. The GET command+will be called with a URL for each file.  The MGET command will be+invoked with a number of URLs and is expected to download the files+to the current directory, preserving the file name but not the path.+The APPLY command will be called with a darcs patchfile piped into+its standard input. Example:++\begin{verbatim}+wget -q +\end{verbatim}++\paragraph{DARCS\_MGETMAX}+\label{env:DARCS_MGETMAX}+When invoking a DARCS\_MGET\_FOO command, darcs will limit the+number of URLs presented to the command to the value of this variable,+if set, or 200.++These commands are \emph{not} interpreted by a shell, so you cannot use shell+meta-characters.++\section{Highlighted output}+\label{env:DARCS_ALWAYS_COLOR}+\label{env:DARCS_DO_COLOR_LINES}+\label{env:DARCS_DONT_ESCAPE_white}++If the terminal understands ANSI color escape sequences,+darcs will highlight certain keywords and delimiters when printing patches.+This can be turned off by setting the environment variable DARCS\_DONT\_COLOR to 1.+If you use a pager that happens to understand ANSI colors, like \verb!less -R!,+darcs can be forced always to highlight the output+by setting DARCS\_ALWAYS\_COLOR to 1.+If you can't see colors you can set DARCS\_ALTERNATIVE\_COLOR to 1,+and darcs will use ANSI codes for bold and reverse video instead of colors.+In addition, there is an extra-colorful mode, which is not enabled by+default, which can be activated with DARCS\_DO\_COLOR\_LINES.++By default darcs will escape (by highlighting if possible) any kind of spaces at the end of lines+when showing patch contents.+If you don't want this you can turn it off by setting+DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES to 1.+A special case exists for only carriage returns:+DARCS\_DONT\_ESCAPE\_TRAILING\_CR.+++\section{Character escaping and non-ASCII character encodings}+\label{env:DARCS_DONT_ESCAPE_nonascii}++Darcs needs to escape certain characters when printing patch contents to a terminal.+Characters like \emph{backspace} can otherwise hide patch content from the user,+and other character sequences can even in some cases redirect commands to the shell+if the terminal allows it.++By default darcs will only allow printable 7-bit ASCII characters (including space),+and the two control characters \emph{tab} and \emph{newline}.+(See the last paragraph in this section for a way to tailor this behavior.)+All other octets are printed in quoted form (as \verb!^<control letter>! or+\verb!\!\verb!<hex code>!).++Darcs has some limited support for locales.+If the system's locale is a single-byte character encoding,+like the Latin encodings,+you can set the environment variable DARCS\_DONT\_ESCAPE\_ISPRINT to 1+and darcs will display all the printables in the current system locale+instead of just the ASCII ones.+NOTE: This curently does not work on some architectures if darcs is+compiled with GHC~6.4 or later. Some non-ASCII control characters might be printed+and can possibly spoof the terminal.++For multi-byte character encodings things are less smooth.+UTF-8 will work if you set DARCS\_DONT\_ESCAPE\_8BIT to 1,+but non-printables outside the 7-bit ASCII range are no longer escaped.+E.g., the extra control characters from Latin-1+might leave your terminal at the mercy of the patch contents.+Space characters outside the 7-bit ASCII range are no longer recognized+and will not be properly escaped at line endings.++As a last resort you can set DARCS\_DONT\_ESCAPE\_ANYTHING to 1.+Then everything that doesn't flip code sets should work,+and so will all the bells and whistles in your terminal.+This environment variable can also be handy+if you pipe the output to a pager or external filter+that knows better than darcs how to handle your encoding.+Note that \emph{all} escaping,+including the special escaping of any line ending spaces,+will be turned off by this setting.++There are two environment variables you can set+to explicitly tell darcs to not escape or escape octets.+They are+DARCS\_DONT\_ESCAPE\_EXTRA and DARCS\_ESCAPE\_EXTRA.+Their values should be strings consisting of the verbatim octets in question.+The do-escapes take precedence over the dont-escapes.+Space characters are still escaped at line endings though.+The special environment variable DARCS\_DONT\_ESCAPE\_TRAILING\_CR+turns off escaping of carriage return last on the line (DOS style).
+ src/darcs.hs view
@@ -0,0 +1,72 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- 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.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Main (main) where++import System.IO ( hSetBinaryMode)+import System.IO ( stdin, stdout )+import System.Exit ( exitWith, ExitCode(..) )+import System.Environment ( getArgs )+import Control.Exception ( Exception( AssertionFailed ), handleJust, catchDyn )++import Darcs.RunCommand ( run_the_command )+import Darcs.Flags ( DarcsFlag(Verbose) )+import Darcs.Commands.Help ( help_cmd, list_available_commands, print_version )+import ThisVersion ( darcs_version )+import Darcs.SignalHandler ( withSignalsHandled )+import Context ( context )+import Darcs.Global ( with_atexit )+import Exec ( ExecException(..) )+#include "impossible.h"++assertions :: Control.Exception.Exception -> Maybe String+assertions (AssertionFailed s) = Just s+assertions _ = Nothing++execExceptionHandler :: ExecException -> IO a+execExceptionHandler (ExecException cmd args redirects reason) =+    do putStrLn $ "Failed to execute external command: " ++ unwords (cmd:args) ++ "\n"+                    ++ "Lowlevel error: " ++ reason ++ "\n"+                    ++ "Redirects: " ++ show redirects ++"\n"+       exitWith $ ExitFailure 3++main :: IO ()+main = with_atexit $ withSignalsHandled $+  flip catchDyn execExceptionHandler $+  handleJust assertions bug $ do+  argv <- getArgs+  case argv of+    -- User called "darcs" without arguments.+    []                  -> print_version >> help_cmd [] []+    -- User called "darcs --foo" for some special foo.+    ["-h"]              -> help_cmd [] []+    ["--help"]          -> help_cmd [] []+    ["--overview"]      -> help_cmd [Verbose] []+    ["--commands"]      -> list_available_commands+    ["-v"]              -> putStrLn darcs_version+    ["--version"]       -> putStrLn darcs_version+    ["--exact-version"] -> do+              putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__+              putStrLn context+    -- User called a normal darcs command, "darcs foo [args]".+    _ -> do+      hSetBinaryMode stdin True+      hSetBinaryMode stdout True+      run_the_command (head argv) (tail argv)
+ src/features.tex view
@@ -0,0 +1,88 @@+\section{Features}++\paragraph{Record changes locally}+In darcs, the equivalent of a cvs ``commit'' is called record, because it+doesn't put the change into any remote or centralized repository.  Changes+are always recorded locally, meaning no net access is required in order to+work on your project and record changes as you make them.  Moreover, this+means that there is no need for a separate ``disconnected operation'' mode.++\paragraph{Interactive records}+You can choose to perform an interactive record, in which case darcs will+prompt you for each change you have made and ask if you wish to record it.+Of course, you can tell darcs to record all the changes in a given file, or+to skip all the changes in a given file, or go back to a previous change,+or whatever.  There is also an experimental graphical interface, which+allows you to view and choose changes even more easily, and in whichever+order you like.++\paragraph{Unrecord local changes}+As a corollary to the ``local'' nature of the record operation, if a change+hasn't yet been published to the world---that is, if the local repository+isn't accessible by others---you can safely unrecord a change (even if it+wasn't the most recently recorded change) and then re-record it+differently, for example if you forgot to add a file, introduced a bug or+realized that what you recorded as a single change was really two separate+changes.++\paragraph{Interactive everything else}+Most darcs commands support an interactive interface.  The ``revert''+command, for example, which undoes unrecorded changes has the same+interface as record, so you can easily revert just a single change.  Pull,+push, send and apply all allow you to view and interactively select which+changes you wish to pull, push, send or apply.++\paragraph{Test suites}+Darcs has support for integrating a test suite with a repository.  If you+choose to use this, you can define a test command (e.g.\ ``make check'') and+have darcs run that command on a clean copy of the project either prior to+recording a change or prior to applying changes---and to reject changes+that cause the test to fail.++\paragraph{Any old server}+Darcs does not require a specialized server in order to make a repository+available for read access.  You can use http, ftp, or even just a plain old+ssh server to access your darcs repository.++\paragraph{You decide write permissions}+Darcs doesn't try to manage write access.  That's your business.  Supported+push methods include direct ssh access (if you're willing to \emph{give}+direct ssh access away), using sudo to allow users who already have shell+access to only apply changes to the repository, or verification of+gpg-signed changes sent by email against a list of allowed keys.  In+addition, there is good support for submission of patches by email that+are not automatically applied, but can easily be applied with a shell escape+from a mail reader (this is how I deal with contributions to darcs).++\paragraph{Symmetric repositories}+Every darcs repository is created equal (well, with the exception of a+``partial'' repository, which doesn't contain a full history\ldots), and every+working directory has an associated repository.  As a result, there is a+symmetry between ``uploading'' and ``downloading'' changes---you can use+the same commands (push or pull) for either purpose.++\paragraph{CGI script}+Darcs has a CGI script that allows browsing of the repositories.++\paragraph{Portable}+Darcs runs on UNIX (or UNIX-like) systems (which includes Mac~OS~X) as well+as on Microsoft Windows.++\paragraph{File and directory moves}+Renames or moves of files and directories, of course are handled properly,+so when you rename a file or move it to a different directory, its history+is unbroken, and merges with repositories that don't have the file renamed+will work as expected.++\paragraph{Token replace}+You can use the ``darcs replace'' command to modify all occurrences of a+particular token (defined by a configurable set of characters that are+allowed in ``tokens'') in a file.  This has the advantage that merges with+changes that introduce new copies of the old token will have the effect of+changing it to the new token---which comes in handy when changing a+variable or function name that is used throughout a project.++\paragraph{Configurable defaults}+You can easily configure the default flags passed to any command on either+a per-repository or a per-user basis or a combination thereof.+
+ src/fpstring.c view
@@ -0,0 +1,187 @@+/*+ * Copyright (C) 2003 David Roundy+ * Most of the UTF code is Copyright (C) 1999-2001 Free Software Foundation, Inc.+ * This file is part of darcs.+ *+ * Darcs is free software; you can redistribute it and/or modify it under+ * the terms of the GNU Library General Public License as published by the+ * Free Software Foundation; either version 2 of the License, or (at your+ * option) any later version.+ *+ * You should have received a copy of the GNU Library General Public+ * License along with the GNU LIBICONV Library; see the file COPYING.LIB.+ * If not, write to the Free Software Foundation, Inc., 51 Franklin Street,+ * Fifth Floor, Boston, MA 02110-1301, USA.+ *+ */+#include "fpstring.h"++#include <stdlib.h>+#include <string.h>+#include <stdio.h>++#ifdef _WIN32+#include <windows.h>+#else+#include <sys/mman.h>+#endif++/* A locale-independent isspace(3) so patches are interpreted the same+ * everywhere. */+// #define ISSPACE(c) \+//     ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')++// int first_white(const char *s, int len)+// {+//     const char *start;+//     const char *end;+// +//     for (start = s, end = s + len; s < end && !ISSPACE(*s); s++);+// +//     return s - start;+// }++// int first_nonwhite(const char *s, int len)+// {+//     const char *start;+//     const char *end;+// +//     for (start = s, end = s + len; s < end && ISSPACE(*s); s++);+// +//     return s - start;+// }++int has_funky_char(const char *s, int len)+{+  // We check first for the more likely \0 so we can break out of+  // memchr that much sooner.+  return !!(memchr(s, 0, len) || memchr(s, 26, len));++}++// ForeignPtr debugging stuff...++static int num_alloced = 0;++void debug_free(void *p) {+  num_alloced--;+  fprintf(stderr, "Freeing %p (%d left)\n", p, num_alloced);+}++void debug_alloc(void *p, const char *name) {+  num_alloced++;+  fprintf(stderr, "Allocating %p named %s (%d left)\n",+          p, name, num_alloced);+}++/* Specification: RFC 2279 */++int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n) {+  /* returns number of unicode chars in the output.  The output array is+     assumed to have the same number of elements as the input array, which+     is n. */++  HsInt *pwc_original = pwc;+  while (n > 0) {+    unsigned char c = s[0];++    if (c < 0x80) {+      *pwc++ = c;+      n--;+      s++;+    } else if (c < 0xc2) {+      return -1;+    } else if (c < 0xe0) {+      if (n < 2) return -1;+      if (!((s[1] ^ 0x80) < 0x40)) return -1;+      *pwc++ = ((unsigned) (c & 0x1f) << 6)+        | (unsigned) (s[1] ^ 0x80);+      n -= 2;+      s += 2;+    } else if (c < 0xf0) {+      if (n < 3) return -1;+      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40+            && (c >= 0xe1 || s[1] >= 0xa0)))+        return -1;+      *pwc++ = ((unsigned) (c & 0x0f) << 12)+        | ((unsigned) (s[1] ^ 0x80) << 6)+        | (unsigned) (s[2] ^ 0x80);+      n -= 3;+      s += 3;+    } else if (c < 0xf8 && sizeof(unsigned)*8 >= 32) {+      if (n < 4) return -1;+      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40+            && (s[3] ^ 0x80) < 0x40+            && (c >= 0xf1 || s[1] >= 0x90)))+        return -1;+      *pwc++ = ((unsigned) (c & 0x07) << 18)+        | ((unsigned) (s[1] ^ 0x80) << 12)+        | ((unsigned) (s[2] ^ 0x80) << 6)+        | (unsigned) (s[3] ^ 0x80);+      n -= 4;+      s += 4;+    } else if (c < 0xfc && sizeof(unsigned)*8 >= 32) {+      if (n < 5) return -1;+      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40+            && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40+            && (c >= 0xf9 || s[1] >= 0x88)))+        return -1;+      *pwc++ = ((unsigned) (c & 0x03) << 24)+        | ((unsigned) (s[1] ^ 0x80) << 18)+        | ((unsigned) (s[2] ^ 0x80) << 12)+        | ((unsigned) (s[3] ^ 0x80) << 6)+        | (unsigned) (s[4] ^ 0x80);+      n -= 5;+      s += 5;+    } else if (c < 0xfe && sizeof(unsigned)*8 >= 32) {+      if (n < 6) return -1;+      if (!((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40+            && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40+            && (s[5] ^ 0x80) < 0x40+            && (c >= 0xfd || s[1] >= 0x84)))+        return -1;+      *pwc++ = ((unsigned) (c & 0x01) << 30)+        | ((unsigned) (s[1] ^ 0x80) << 24)+        | ((unsigned) (s[2] ^ 0x80) << 18)+        | ((unsigned) (s[3] ^ 0x80) << 12)+        | ((unsigned) (s[4] ^ 0x80) << 6)+        | (unsigned) (s[5] ^ 0x80);+      n -= 6;+      s += 6;+    } else+      return -1;+  }+  return pwc - pwc_original;+}++/* Conversion to and from hex */++void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars)+{+    static char hex[] = "0123456789abcdef";+    unsigned char *end;++    for (end = from + num_chars; from < end; from++) {+        *dest++ = hex[*from >> 4];+        *dest++ = hex[*from & 0xf];+    }++    return;+}++#define NYBBLE_TO_INT(c) \+    ((c) - ((c) >= 'a' ? 'a' - 10 : '0'))++void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars)+{+    unsigned char *end;+    unsigned char c;++    end = dest + num_chars;+    while (dest < end) {+        c = NYBBLE_TO_INT(*from) << 4, from++;+        *dest++ = c | NYBBLE_TO_INT(*from), from++;+    }++    return;+}
+ src/fpstring.h view
@@ -0,0 +1,16 @@+#include <HsFFI.h>+#include <sys/types.h>++int wfindps_helper(char c, const char *s, int len);+void debug_free(void *p);+void debug_alloc(void *p, const char *name);++// int first_white(const char *s, int len);+// int first_nonwhite(const char *s, int len);+int has_funky_char(const char *s, int len);++int utf8_to_ints(HsInt *pwc, const unsigned char *s, int n);++void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars);+void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars);+
+ src/gadts.h view
@@ -0,0 +1,11 @@+#ifdef GADT_WITNESSES++#define C(contexts) contexts+#define FORALL(types) forall types.++#else++#define C(contexts)+#define FORALL(types)++#endif
+ src/gpl.tex view
@@ -0,0 +1,414 @@+% This is the FSF GPL, reformatted as an appendix by David Roundy++% This file is intended to be included in another file.++\chapter{The GNU General Public License}+\label{gpl}+\section*{Version 2, June 1991}++\begin{center}+Version 2, June 1991++Copyright \copyright\ 1989, 1991 Free Software Foundation, Inc.++\bigskip++51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA++\bigskip++Everyone is permitted to copy and distribute verbatim copies+of this license document, but changing it is not allowed.++\end{center}++\section*{Preamble}+\begin{quote}+The licenses for most software are designed to take away your freedom to+share and change it.  By contrast, the GNU General Public License is+intended to guarantee your freedom to share and change free software---to+make sure the software is free for all its users.  This General Public+License applies to most of the Free Software Foundation's software and to+any other program whose authors commit to using it.  (Some other Free+Software Foundation software is covered by the GNU Library General Public+License instead.)  You can apply it to your programs, too.++When we speak of free software, we are referring to freedom, not price.+Our General Public Licenses are designed to make sure that you have the+freedom to distribute copies of free software (and charge for this service+if you wish), that you receive source code or can get it if you want it,+that you can change the software or use pieces of it in new free programs;+and that you know you can do these things.++To protect your rights, we need to make restrictions that forbid anyone to+deny you these rights or to ask you to surrender the rights.  These+restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++For example, if you distribute copies of such a program, whether gratis or+for a fee, you must give the recipients all the rights that you have.  You+must make sure that they, too, receive or can get the source code.  And+you must show them these terms so they know their rights.++We protect your rights with two steps: (1) copyright the software, and (2)+offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++Also, for each author's protection and ours, we want to make certain that+everyone understands that there is no warranty for this free software.  If+the software is modified by someone else and passed on, we want its+recipients to know that what they have is not the original, so that any+problems introduced by others will not reflect on the original authors'+reputations.++Finally, any free program is threatened constantly by software patents.+We wish to avoid the danger that redistributors of a free program will+individually obtain patent licenses, in effect making the program+proprietary.  To prevent this, we have made it clear that any patent must+be licensed for everyone's free use or not licensed at all.++The precise terms and conditions for copying, distribution and+modification follow.+\end{quote}++\begin{center}+{\Large \sc GNU General Public License+\\\vspace{3mm}Terms and Conditions For Copying, Distribution and Modification}+\end{center}+++\begin{enumerate}++\addtocounter{enumi}{-1}++\item ++This License applies to any program or other work which contains a notice+placed by the copyright holder saying it may be distributed under the+terms of this General Public License.  The ``Program'', below, refers to+any such program or work, and a ``work based on the Program'' means either+the Program or any derivative work under copyright law: that is to say, a+work containing the Program or a portion of it, either verbatim or with+modifications and/or translated into another language.  (Hereinafter,+translation is included without limitation in the term ``modification''.)+Each licensee is addressed as ``you''.++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++\item You may copy and distribute verbatim copies of the Program's source+  code as you receive it, in any medium, provided that you conspicuously+  and appropriately publish on each copy an appropriate copyright notice+  and disclaimer of warranty; keep intact all the notices that refer to+  this License and to the absence of any warranty; and give any other+  recipients of the Program a copy of this License along with the Program.++You may charge a fee for the physical act of transferring a copy, and you+may at your option offer warranty protection in exchange for a fee.++\item++You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++\begin{enumerate}++\item ++You must cause the modified files to carry prominent notices stating that+you changed the files and the date of any change.++\item++You must cause any work that you distribute or publish, that in+whole or in part contains or is derived from the Program or any+part thereof, to be licensed as a whole at no charge to all third+parties under the terms of this License.++\item+If the modified program normally reads commands interactively+when run, you must cause it, when started running for such+interactive use in the most ordinary way, to print or display an+announcement including an appropriate copyright notice and a+notice that there is no warranty (or else, saying that you provide+a warranty) and that users may redistribute the program under+these conditions, and telling the user how to view a copy of this+License.  (Exception: if the Program itself is interactive but+does not normally print such an announcement, your work based on+the Program is not required to print an announcement.)++\end{enumerate}+++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++\item+You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++\begin{enumerate}++\item++Accompany it with the complete corresponding machine-readable+source code, which must be distributed under the terms of Sections+1 and 2 above on a medium customarily used for software interchange; or,++\item++Accompany it with a written offer, valid for at least three+years, to give any third party, for a charge no more than your+cost of physically performing source distribution, a complete+machine-readable copy of the corresponding source code, to be+distributed under the terms of Sections 1 and 2 above on a medium+customarily used for software interchange; or,++\item++Accompany it with the information you received as to the offer+to distribute corresponding source code.  (This alternative is+allowed only for noncommercial distribution and only if you+received the program in object code or executable form with such+an offer, in accord with Subsection b above.)++\end{enumerate}+++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++\item+You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++\item+You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++\item+Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++\item+If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++\item+If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++\item+The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and ``any+later version'', you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++\item+If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++\begin{center}+{\Large\sc+No Warranty+}+\end{center}++\item+{\sc Because the program is licensed free of charge, there is no warranty+for the program, to the extent permitted by applicable law.  Except when+otherwise stated in writing the copyright holders and/or other parties+provide the program ``as is'' without warranty of any kind, either expressed+or implied, including, but not limited to, the implied warranties of+merchantability and fitness for a particular purpose.  The entire risk as+to the quality and performance of the program is with you.  Should the+program prove defective, you assume the cost of all necessary servicing,+repair or correction.}++\item+{\sc In no event unless required by applicable law or agreed to in writing+will any copyright holder, or any other party who may modify and/or+redistribute the program as permitted above, be liable to you for damages,+including any general, special, incidental or consequential damages arising+out of the use or inability to use the program (including but not limited+to loss of data or data being rendered inaccurate or losses sustained by+you or third parties or a failure of the program to operate with any other+programs), even if such holder or other party has been advised of the+possibility of such damages.}++\end{enumerate}+++\begin{center}+{\Large\sc End of Terms and Conditions}+\end{center}++\section{Appendix: How to Apply These Terms to Your New Programs}++If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these+terms.++  To do so, attach the following notices to the program.  It is safest to+  attach them to the start of each source file to most effectively convey+  the exclusion of warranty; and each file should have at least the+  ``copyright'' line and a pointer to where the full notice is found.++\begin{quote}+$<$one line to give the program's name and a brief idea of what it does.$>$ \\+Copyright (C) $<$year$>$  $<$name of author$>$ \\++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 of the License, 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; if not, write to the Free Software+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.+\end{quote}++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++\begin{quote}+Gnomovision version 69, Copyright (C) $<$year$>$  $<$name of author$>$ \\+Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. \\+This is free software, and you are welcome to redistribute it+under certain conditions; type `show c' for details.+\end{quote}+++The hypothetical commands {\tt show w} and {\tt show c} should show the+appropriate parts of the General Public License.  Of course, the commands+you use may be called something other than {\tt show w} and {\tt show c};+they could even be mouse-clicks or menu items---whatever suits your+program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a ``copyright disclaimer'' for the program, if+necessary.  Here is a sample; alter the names:++\begin{quote}+Yoyodyne, Inc., hereby disclaims all copyright interest in the program \\+`Gnomovision' (which makes passes at compilers) written by James Hacker. \\++$<$signature of Ty Coon$>$, 1 April 1989 \\+Ty Coon, President of Vice+\end{quote}+++This General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications+with the library.  If this is what you want to do, use the GNU Library+General Public License instead of this License.
+ src/hscurl.c view
@@ -0,0 +1,305 @@+#ifdef HAVE_CURL++#include "hscurl.h"++#include <curl/curl.h>+#include <errno.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>++enum RESULT_CODES+  {+    RESULT_OK = 0,+    RESULT_MALLOC_FAIL,+    RESULT_SELECT_FAIL,+    RESULT_MULTI_INIT_FAIL,+    RESULT_EASY_INIT_FAIL,+    RESULT_SLIST_APPEND_FAIL,+    RESULT_NO_RUNNING_HANDLES,+    RESULT_MULTI_INFO_READ_FAIL,+    RESULT_UNKNOWN_MESSAGE,+    RESULT_FILE_OPEN_FAIL+  };++static const char *error_strings[] =+  {+    "",+    "malloc() failed",+    "select() failed",+    "curl_multi_init() failed",+    "curl_easy_init() failed",+    "curl_slist_append() failed",+    "curl_multi_perform() - no running handles",+    "curl_multi_info_read() failed",+    "curl_multi_info_read() returned unknown message",+    "fopen() failed"+  };++struct UrlData+{+  char *url;+  FILE *file;+  struct curl_slist *headers;+};++static int debug = 0;+static const char user_agent[] =+  "darcs/" PACKAGE_VERSION " libcurl/" LIBCURL_VERSION;+static const char *proxypass;+static int init_done = 0;+static CURLM *multi = NULL;+static int msgs_in_queue = 0;+static char *last_url = NULL;++static const char *perform()+{+  int error;+  int running_handles, running_handles_last;+  fd_set fd_read, fd_write, fd_except;+  int max_fd;+  long timeout;+  struct timeval tval;++  error = curl_multi_perform(multi, &running_handles);+  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+    return curl_multi_strerror(error);+  if (running_handles == 0)+    return error_strings[RESULT_NO_RUNNING_HANDLES];++  running_handles_last = running_handles;+  while (1)+    {+      while (error == CURLM_CALL_MULTI_PERFORM)+        error = curl_multi_perform(multi, &running_handles);++      if (error != CURLM_OK)+        return curl_multi_strerror(error);++      if (running_handles < running_handles_last)+        break;++      FD_ZERO(&fd_read);+      FD_ZERO(&fd_write);+      FD_ZERO(&fd_except);++      error = curl_multi_fdset(multi, &fd_read, &fd_write, &fd_except, &max_fd);+      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+        return curl_multi_strerror(error);++#ifdef CURL_MULTI_TIMEOUT+      error = curl_multi_timeout(multi, &timeout);+      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+        return curl_multi_strerror(error);++      if (timeout == -1)+#endif+        timeout = 100;++      tval.tv_sec = timeout / 1000;+      tval.tv_usec = timeout % 1000 * 1000;++      while (select(max_fd + 1, &fd_read, &fd_write, &fd_except, &tval) < 0)+        if (errno != EINTR)+          {+            if (debug)+              perror(error_strings[RESULT_SELECT_FAIL]);+            return error_strings[RESULT_SELECT_FAIL];+          }++      error = CURLM_CALL_MULTI_PERFORM;+    }++  return NULL;+}++const char *curl_request_url(const char *url,+                             const char *filename,+                             int cache_time)+{+  int error;++  if (init_done == 0)+    {+      error = curl_global_init(CURL_GLOBAL_ALL);+      if (error != CURLE_OK)+        return curl_easy_strerror(error);+      proxypass = getenv("DARCS_PROXYUSERPWD");+      init_done = 1;+    }++  if (multi == NULL)+    {+      multi = curl_multi_init();+      if (multi == NULL)+        return error_strings[RESULT_MULTI_INIT_FAIL];+#ifdef CURL_PIPELINING+      error = curl_multi_setopt(multi, CURLMOPT_PIPELINING, 1);+      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+        return curl_multi_strerror(error);+#endif+    }++  CURL *easy = curl_easy_init();+  if (easy == NULL)+    return error_strings[RESULT_EASY_INIT_FAIL];++  if (debug)+    {+      error = curl_easy_setopt(easy, CURLOPT_VERBOSE, 1);+      if (error != CURLE_OK)+        return curl_easy_strerror(error);+    }++  struct UrlData *url_data = malloc(sizeof(struct UrlData));+  if (url_data == NULL)+    return error_strings[RESULT_MALLOC_FAIL];++  url_data->url = strdup(url);+  if (url_data->url == NULL)+    return error_strings[RESULT_MALLOC_FAIL];++  url_data->file = fopen(filename,"wb");+  if (url_data->file == NULL)+    {+      if (debug)+        perror(error_strings[RESULT_FILE_OPEN_FAIL]);+      return error_strings[RESULT_FILE_OPEN_FAIL];+    }++  error = curl_easy_setopt(easy, CURLOPT_PRIVATE, url_data);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  error = curl_easy_setopt(easy, CURLOPT_URL, url_data->url);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++#ifdef CURLOPT_WRITEDATA+  error = curl_easy_setopt(easy, CURLOPT_WRITEDATA, url_data->file);+#else+  error = curl_easy_setopt(easy, CURLOPT_FILE, url_data->file);+#endif+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  error = curl_easy_setopt(easy, CURLOPT_USERAGENT, user_agent);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  error = curl_easy_setopt(easy, CURLOPT_FOLLOWLOCATION, 1);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  error = curl_easy_setopt(easy, CURLOPT_FAILONERROR, 1);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  error = curl_easy_setopt(easy, CURLOPT_HTTPAUTH, CURLAUTH_ANY);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  /* libcurl currently always sends Pragma: no-cache, but never+     Cache-Control, which is contradictory.  We override both, just to+     be sure. */+  url_data->headers = curl_slist_append(NULL, "Accept: */*");+  if(cache_time == 0)+    {+      url_data->headers =+        curl_slist_append(url_data->headers, "Pragma: no-cache");+      url_data->headers =+        curl_slist_append(url_data->headers, "Cache-Control: no-cache");+    }+  else if(cache_time > 0)+    {+      /* This won't work well with HTTP/1.0 proxies. */+      char buf[40];+      snprintf(buf, sizeof(buf), "Cache-Control: max-age=%d", cache_time);+      buf[sizeof(buf) - 1] = '\n';+      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");+      url_data->headers = curl_slist_append(url_data->headers, buf);+    }+  else+    {+      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");+      url_data->headers = curl_slist_append(url_data->headers, "Cache-Control:");+    }+  if (url_data->headers == NULL)+    return error_strings[RESULT_SLIST_APPEND_FAIL];++  error = curl_easy_setopt(easy, CURLOPT_HTTPHEADER, url_data->headers);+  if (error != CURLE_OK)+    return curl_easy_strerror(error);++  if (proxypass && *proxypass)+    {+      error = curl_easy_setopt(easy, CURLOPT_PROXYUSERPWD, proxypass);+      if (error != CURLE_OK)+        return curl_easy_strerror(error);+    }++  error = curl_multi_add_handle(multi, easy);+  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+    return curl_multi_strerror(error);++  return error_strings[RESULT_OK];+}++const char *curl_wait_next_url()+{+  if (last_url != NULL)+    {+      free(last_url);+      last_url = NULL;+    }++  if (msgs_in_queue == 0)+    {+      const char *error = perform();+      if (error != NULL)+        return error;+    }++  CURLMsg *msg = curl_multi_info_read(multi, &msgs_in_queue);+  if (msg == NULL)+    return error_strings[RESULT_MULTI_INFO_READ_FAIL];++  if (msg->msg == CURLMSG_DONE)+    {+      CURL *easy = msg->easy_handle;+      CURLcode result = msg->data.result;+      struct UrlData *url_data;+      int error = curl_easy_getinfo(easy, CURLINFO_PRIVATE, (char **)&url_data);+      if (error != CURLE_OK)+        return curl_easy_strerror(error);++      last_url = url_data->url;+      fclose(url_data->file);+      curl_slist_free_all(url_data->headers);+      free(url_data);++      error = curl_multi_remove_handle(multi, easy);+      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)+        return curl_multi_strerror(error);+      curl_easy_cleanup(easy);++      if (result != CURLE_OK)+        return curl_easy_strerror(result);+    }+  else+    return error_strings[RESULT_UNKNOWN_MESSAGE];++  return error_strings[RESULT_OK];+}++const char *curl_last_url()+{+  return last_url != NULL ? last_url : "";+}++void curl_enable_debug()+{+  debug = 1;+}++#endif
+ src/hscurl.h view
@@ -0,0 +1,9 @@+const char *curl_request_url(const char *url,+                             const char *filename,+                             int cache_time);++const char *curl_wait_next_url();++const char *curl_last_url();++void curl_enable_debug();
+ src/impossible.h view
@@ -0,0 +1,8 @@+import qualified Darcs.Bug as Bug_++#define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__))++#define bug        (darcsBug Bug_._bug)+#define impossible (darcsBug Bug_._impossible)+#define fromJust   (darcsBug Bug_._fromJust)+#define bugDoc     (darcsBug Bug_._bugDoc)
+ src/maybe_relink.c view
@@ -0,0 +1,173 @@+/*+  Copyright (C) 2005 Juliusz Chroboczek++  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.+*/++#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+#include <string.h>+#include <stdio.h>+#include <stdlib.h>++#include <unistd.h>+#include <errno.h>+#include <sys/time.h>++#ifdef _WIN32+int+maybe_relink(const char *src, const char *dst, int careful)+{+    return 0;+}++#else++/* Tries to link src to dst if both files exist and have the same+   contents.  If careful is false only the file sizes are compared; if+   it is true, the full contents are compared.++   This code assumes that dst cannot change behind our back -- the+   caller is supposed to protect it by a lock.  On the other hand, it+   does handle simultaneous access to src, but only if src is never+   modified in place.  It should also be safe over NFS.++   Assumes that rename cannot fail mid-way on a single filesystem.++   Returns 1 on success, 0 if the files are already linked, -1 for an+   error in errno, -2 if the files cannot be linked because they are not+   the same, on different devices, or on a filesystem with no support for+   hard links, -3 if there was a race condition, -4 if something unexpected+   happened. */++int+maybe_relink(char *src, char *dst, int careful)+{+#define RELINK_BUFFER_SIZE 8192++    int len, rc, saved_errno;+    char *tempname;+    struct stat srcstat, dststat, tempstat;+    struct timeval now;++    rc = stat(src, &srcstat);+    if(rc < 0) {+        if(errno == ENOENT)+            return -2;+        else+            return -1;+    }++    rc = stat(dst, &dststat);+    if(rc < 0) return -1;++    if(!S_ISREG(srcstat.st_mode) || !S_ISREG(dststat.st_mode)) {+        return -4;+    }++    if(srcstat.st_dev != dststat.st_dev) {+        return -2;+    }++    if(srcstat.st_ino == dststat.st_ino)+        /* Files are already linked */+        return 0;++    if(srcstat.st_size != dststat.st_size)+        return -2;++    /* link is atomic even on NFS, we will fail gracefully if the name+       is not unique. */+    gettimeofday(&now, NULL);+    rc = strlen(dst) + 6;+    tempname = malloc(rc);+    if(tempname == NULL) return -1;+    len = snprintf(tempname, rc, "%s-%04x", dst,+                   ((unsigned)(now.tv_usec ^ (now.tv_usec >> 16))) & 0xFFFF);+    if(len < 0 || len >= rc) {+        free(tempname);+        return -4;+    }++    rc = link(src, tempname);+    if(rc < 0) {+        /* We need to try to remove the link in case this was a+           problem with NFS over an unreliable transport. */+        goto fail;+    }++    rc = stat(tempname, &tempstat);+    if(rc < 0) goto fail;++    /* Check for a race condition.  The size and mtime checks are+       gratuitious, but they don't cost much, and might save your data+       if you're on a filesystem without i-nodes. */+    if(tempstat.st_ino != srcstat.st_ino ||+       tempstat.st_size != srcstat.st_size ||+       tempstat.st_mtime != srcstat.st_mtime) {+        unlink(tempname);+        free(tempname);+        return -3;+    }+    if(careful) {+        int fd1, fd2, i, rc1, rc2;+        char buf1[RELINK_BUFFER_SIZE], buf2[RELINK_BUFFER_SIZE];++        fd1 = open(tempname, O_RDONLY);+        if(fd1 < 0) goto fail;+        fd2 = open(dst, O_RDONLY);+        if(fd2 < 0) { close(fd1); goto fail; }++        i = 0;+        /* This comparison is approximate: it doesn't deal with short+           reads and EINTR.  It's okay, as these cases are rare and if+           they happen, we're still safe. */+        while(i < tempstat.st_size) {+            rc1 = read(fd1, buf1, RELINK_BUFFER_SIZE);+            if(rc1 < 0) { close(fd1); close(fd2); goto fail; }+            rc2 = read(fd2, buf2, RELINK_BUFFER_SIZE);+            if(rc2 < 0) { close(fd1); close(fd2); goto fail; }+            if(rc1 == 0 || rc1 != rc2 || memcmp(buf1, buf2, rc1) != 0) {+                close(fd1); close(fd2);+                unlink(tempname);+                free(tempname);+                return -2;+            }+            i += rc1;+        }+        close(fd1); close(fd2);+    }++    rc = rename(tempname, dst);+    if(rc < 0) goto fail;++    free(tempname);+    return 1;++ fail:+    saved_errno = errno;+    unlink(tempname);+    free(tempname);+    errno = saved_errno;+    if(errno == EPERM || errno == EOPNOTSUPP)+        return -2;+    return -1;++#undef RELINK_BUFFER_SIZE+}++#endif
+ src/maybe_relink.h view
@@ -0,0 +1,1 @@+int maybe_relink(const char *src, const char *dst, int careful);
+ src/preproc.hs view
@@ -0,0 +1,184 @@+-- | This program mangles a pseudo-LaTeX document into actual LaTeX.+-- There are three key changes to the input:+--+--   * \\input{foo} is replaced by the contents of the file foo (after+--     it, too, is mangled).  Note that this is relative to the+--     working directory, *not* relative to the file being parsed.+--+--   * Anything between \\begin{code} and \\end{code} is deleted.+--     Note that this is quite unlike normal literate documentation+--     (for which we use Haddock, not LaTeX).+--+--   * Some nonstandard pseudo-LaTeX commands are expanded into actual+--     LaTeX text.  In particular, \\darcsCommand{foo} is replaced by+--     LaTeX markup describing the command @foo@.+module Main (main) where+import System.FilePath ( (</>) )+import System.Environment ( getArgs )+import System.Exit ( exitWith, ExitCode(..) )+import Text.Regex ( matchRegex, mkRegex )+import Darcs.Commands ( DarcsCommand(SuperCommand,+                        command_sub_commands, command_name,+                        command_extra_arg_help, command_basic_options,+                        command_advanced_options, command_help,+                        command_description),+                        extract_commands )+import Darcs.Arguments ( options_latex )+import Darcs.Commands.Help ( command_control_list, environmentHelp )+import English ( andClauses )+import ThisVersion ( darcs_version )++the_commands :: [DarcsCommand]+the_commands = extract_commands command_control_list++-- | The entry point for this program.  The path to the TeX master+-- file is supplied as the first argument.  Bootstrapping into+-- 'preproc' then happens by passing it a pseudo-document that+-- contains a single input (include) line.+main :: IO ()+main = do+  args <- getArgs+  if length args < 1+     then exitWith $ ExitFailure 1+     else return ()+  putStrLn "%% This file was automatically generated by preproc."+  c <- preproc ["\\input{"++head args++"}"]+  mapM_ putStrLn c++-- | Depending on whether pdflatex or htlatex is to be used, the LaTeX+-- output of this program must vary subtly.  This procedure returns+-- true iff the command-line arguments contain @--html@.+am_html :: IO Bool+am_html = do args <- getArgs+             return $ elem "--html" args++-- | Given a list of input lines in pseudo-LaTeX, return the same+-- document in LaTeX.  The pseudo-LaTeX lines are replaced, other+-- lines are used unmodified.+preproc :: [String] -> IO [String]+preproc [] = return []              -- Empty input, empty output.+preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "\\usepackage{html}" : rest+             else return $ "\\usepackage{hyperref}" : rest+preproc ("\\begin{code}":ss) = ignore ss+    where ignore :: [String] -> IO [String]+          ignore ("\\end{code}":ss') = preproc ss'+          ignore (_:ss') = ignore ss'+          ignore [] = return []+preproc ("\\begin{options}":ss) =+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "\\begin{rawhtml}" : "<div class=\"cmd-opt-hdr\">" : rest+             else return $ ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," +++                            "xrightmargin=1cm]") : rest+preproc ("\\end{options}":ss) =+    do rest <- preproc ss+       ah <- am_html+       if ah then return $ "</div>" : "\\end{rawhtml}" : rest+             else return $ "\\end{Verbatim}" : rest+preproc ("\\darcsVersion":ss) = do+  rest <- preproc ss+  return $ darcs_version:rest+preproc (s:ss) = do+  rest <- preproc ss+  let rx = mkRegex "^\\\\(input|darcs(Command|Env))\\{(.+)\\}$"+  case matchRegex rx s of+    Just ["input", _, path] ->+        do cs <- readFile $ "src" </> path -- ratify readFile: not part of darcs executable+           this <- preproc $ lines cs+           return $ this ++ rest+    Just ["darcsCommand", _, command] ->+        return $ commandHelp command : rest+    Just ["darcsEnv", _, variable] ->+        return $ envHelp variable : rest+    -- The base case for the whole preproc function.  Nothing to+    -- mangle, so this is an ordinary line of TeX, and we append it to+    -- the result unmodified.+    _ -> return $ s : rest++commandHelp :: String -> String+commandHelp command = section ++ "{darcs " ++ command ++ "}\n" +++                      "\\label{" ++ command ++ "}\n" +++                      gh ++ get_options command ++ gd+    where+      section = if ' ' `elem` command then "\\subsubsection" else "\\subsection"+      -- | Given a Darcs command name as a string, return that command's (multi-line) help string.+      gh :: String+      gh =  escape_latex_specials $ command_property command_help the_commands command+      -- | Given a Darcs command name as a string, return that command's (one-line) description string.+      gd :: String+      gd = command_property command_description the_commands command++get_options :: String -> String+get_options comm = get_com_options $ get_c names the_commands+    where names = words comm++get_c :: [String] -> [DarcsCommand] -> [DarcsCommand]+get_c (name:ns) commands =+    case ns of+    [] -> [get name commands]+    _ -> case get name commands of+         c@SuperCommand { } ->+             c:(get_c ns $ extract_commands $ command_sub_commands c)+         _ ->+             error $ "Not a supercommand: " ++ name+    where get n (c:cs) | command_name c == n = c+                       | otherwise = get n cs+          get n [] = error $ "No such command:  "++n+get_c [] _ = error "no command specified"++get_com_options :: [DarcsCommand] -> String+get_com_options c =+    "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " +++    args ++ "!\n\n" ++ "Options:\n\n" ++ options_latex opts1 +++    (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ options_latex opts2)+    where cmd = unwords $ map command_name c+          args = unwords $ command_extra_arg_help $ last c+          opts1 = command_basic_options $ last c+          opts2 = command_advanced_options $ last c++command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String+                 -> String+command_property property commands name =+    property $ last c+    where names = words name+          c = get_c names commands++++envHelp :: String -> String+envHelp var = unlines $ render $ entry environmentHelp+    where render (ks, ds) =+              ("\\paragraph{" ++ escape_latex_specials (andClauses ks) ++ "}") :+              ("\\label{env:" ++ var ++ "}") :+              map escape_latex_specials ds+          entry [] = undefined+          entry (x:xs) | elem var $ fst x = x+                       | otherwise = entry xs++-- | LaTeX treats a number of characters or sequences specially.+-- Therefore when including ordinary help text in a LaTeX document, it+-- is necessary to escape these characters in the way LaTeX expects.+escape_latex_specials :: String -> String+-- Order is important+escape_latex_specials =+  (bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1)+  where+    amp        = replace "&"  "\\&"+    bs1        = replace "\\" "\001"+    bs2        = replace "\001" "$\\backslash$"+    carrot     = replace "^"  "\\^{}"+    dollar     = replace "$"  "\\$"+    lbrace     = replace "{"  "\\{"+    percent    = replace "%"  "\\%"+    rbrace     = replace "}"  "\\}"+    underscore = 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)
+ src/switching.tex view
@@ -0,0 +1,147 @@+\section{Switching from CVS}++Darcs is refreshingly different from CVS.++CVS keeps version controlled data in a central repository, and+requires that users check out a working directory whenever they wish+to access the version-controlled sources.  In order to modify the+central repository, a user needs to have write access to the central+repository; if he doesn't, CVS merely becomes a tool to get the latest+sources.++In darcs there is no distinction between working directories and+repositories.  In order to work on a project, a user makes a local+copy of the repository he wants to work in; he may then harness the+full power of version control locally.  In order to distribute his+changes, a user who has write access can \emph{push} them to the+remote repository; one who doesn't can simply send them by e-mail in a+format that makes them easy to apply on the remote system.++\paragraph{Darcs commands for CVS users}+Because of the different models used by cvs and darcs, it is+difficult to provide a complete equivalence between cvs and darcs.+A rough correspondence for the everyday commands follows:\\+% The \hspace commands force a line break in the postscript output,+% but they are effectively ignored in the html output.+\begin{description}\addtolength{\itemsep}{-0.5\baselineskip}+\item[{\tt cvs checkout}\hspace*{100em}]+   {\tt darcs get}+\item[{\tt cvs update}\hspace*{100em}]+   {\tt darcs pull}+\item[{\tt cvs -n update}\hspace*{100em}]+   {\tt darcs pull \verb!--dry-run!}+      (summarize remote changes)+\item[{\tt cvs -n update}\hspace*{100em}]+   {\tt darcs whatsnew \verb!--summary!}+      (summarize local changes)+\item[{\tt cvs -n update | grep '?'}\hspace*{100em}]+   {\tt darcs whatsnew -ls | grep \verb!^a! }+      (list potential files to add)+\item[{\tt rm foo.txt; cvs update foo.txt}\hspace*{100em}]+   {\tt darcs revert foo.txt}+      (revert to foo.txt from repo)+\item[{\tt cvs diff}\hspace*{100em}]+   {\tt darcs whatsnew}+      (if checking local changes)+\item[{\tt cvs diff}\hspace*{100em}]+   {\tt darcs diff}+      (if checking recorded changes)+\item[{\tt cvs commit}\hspace*{100em}]+   {\tt darcs record}+      (if committing locally)+\item[{\tt cvs commit}\hspace*{100em}]+   {\tt darcs tag}+      (if marking a version for later use)+\item[{\tt cvs commit}\hspace*{100em}]+   {\tt darcs push} or {\tt darcs send}+      (if committing remotely)+\item[{\tt cvs diff | mail}\hspace*{100em}]+   {\tt darcs send}+\item[{\tt cvs add}\hspace*{100em}]+   {\tt darcs add}+\item[{\tt cvs tag -b}\hspace*{100em}]+   {\tt darcs get}+\item[{\tt cvs tag}\hspace*{100em}]+   {\tt darcs tag}+\end{description}++\paragraph{Migrating CVS repositories to darcs}++Tools and instructions for migrating CVS repositories to darcs are provided+on the darcs community website: +\htmladdnormallinkfoot{http://wiki.darcs.net/DarcsWiki/ConvertingFromCvs}{http://wiki.darcs.net/DarcsWiki/ConvertingFromCvs}+++\section{Switching from arch}++Although arch, like darcs, is a distributed system, and the two systems+have many similarities (both require no special server, for example), their+essential organization is very different.++Like CVS, arch keeps data in two types of data structures:+repositories (called ``archives'') and working directories.  In order+to modify a repository, one must first check out a corresponding+working directory. This requires that users remember a number of+different ways of pushing data around --- \verb|tla| \verb|get|,+\verb|update|, \verb|commit|, \verb|archive-mirror| and so on.++In darcs, on the other hand, there is no distinction between working+directories and repositories, and just checking out your sources+creates a local copy of a repository.  This allows you to harness the+full power of version control in any scratch copy of your sources, and+also means that there are just two ways to push data around:+\verb|darcs| \verb|record|, which stores edits into your local+repository, and \verb|pull|, which moves data between repositories.+(\verb|darcs| \verb|push| is merely the opposite of \verb|pull|;+\verb|send| and \verb|apply| are just the two halves of \verb|push|).++\paragraph{Darcs commands for arch users}++Because of the different models used by arch and darcs, it is+difficult to provide a complete equivalence between arch and darcs.+A rough correspondence for the everyday commands follows:\\+\begin{description}\addtolength{\itemsep}{-0.5\baselineskip}+\item[{\tt tla init-tree}\hspace*{100em}]+   {\tt darcs initialize}+\item[{\tt tla get}\hspace*{100em}]+   {\tt darcs get}+\item[{\tt tla update}\hspace*{100em}]+   {\tt darcs pull}+\item[{\tt tla file-diffs f | patch -R }\hspace*{100em}]+   {\tt darcs revert}+\item[{\tt tla changes --diffs}\hspace*{100em}]+   {\tt darcs whatsnew}+\item[{\tt tla logs}\hspace*{100em}]+   {\tt darcs changes}+\item[{\tt tla file-diffs}\hspace*{100em}]+   {\tt darcs diff -u}+\item[{\tt tla add}\hspace*{100em}]+   {\tt darcs add}+\item[{\tt tla mv}\hspace*{100em}]+   {\tt darcs move}+      (not {\tt tla move})+\item[{\tt tla commit}\hspace*{100em}]+   {\tt darcs record}+      (if committing locally)+\item[{\tt tla commit}\hspace*{100em}]+   {\tt darcs tag}+      (if marking a version for later use)+\item[{\tt tla commit}\hspace*{100em}]+   {\tt darcs push} or {\tt darcs send}+      (if committing remotely)+\item[{\tt tla archive-mirror}\hspace*{100em}]+   {\tt darcs pull} or {\tt darcs push}+\item[{\tt tla tag}\hspace*{100em}]+   {\tt darcs get}+      (if creating a branch)+\item[{\tt tla tag}\hspace*{100em}]+   {\tt darcs tag}+      (if creating a tag).+\end{description}++\paragraph{Migrating arch repositories to darcs}++Tools and instructions for migrating arch repositories to darcs are provided+on the darcs community website: +\htmladdnormallinkfoot{http://wiki.darcs.net/DarcsWiki/ConvertingFromArch}{http://wiki.darcs.net/DarcsWiki/ConvertingFromArch}+
+ src/umask.c view
@@ -0,0 +1,38 @@+#include <sys/types.h>+#include <sys/stat.h>+#include <stdlib.h>+#include <errno.h>+#include "umask.h"++int+set_umask(char *mask_string)+{+#ifndef WIN32+    int rc;+    unsigned mask;+    char *end;++    mask = strtoul(mask_string, &end, 8);+    if(!end || *end != '\0') {+        errno = EINVAL;+        return -1;+    }++    rc = umask(mask);+    return rc;+#else+    /* umask() has no useful meaning on win32. */+    return 0;+#endif /* #ifndef WIN32 ... else ... */+}++int+reset_umask(int old_mask)+{+#ifndef WIN32+    umask(old_mask);+    return 1;+#else+    return 0;+#endif /* #ifndef WIN32 ... else ... */+}
+ src/umask.h view
@@ -0,0 +1,2 @@+int set_umask(char *mask_string);+int reset_umask(int old_mask);
+ src/unit.lhs view
@@ -0,0 +1,822 @@+%  Copyright (C) 2002-2005,2007 David Roundy+%+%  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.++\documentclass{report}+\usepackage{color}++\usepackage{verbatim}+\newenvironment{code}{\color{blue}\verbatim}{\endverbatim}++\begin{document}++% Definition of title page:+\title{+    Unit Testing for darcs in Haskell+}+\author{+    David Roundy    % insert author(s) here+}++\maketitle++\tableofcontents  % Table of Contents++\chapter{Introduction}++This is a unit testing program, which is intended to make sure that all the+functions of my darcs code work properly.++\begin{code}+{-# OPTIONS_GHC -cpp -fno-warn-orphans -fno-warn-deprecations -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++module Main (main) where++import System.IO.Unsafe ( unsafePerformIO )+import ByteStringUtils hiding ( intercalate )+import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.ByteString as B ( empty, concat, length, unpack, foldr,+                                        cons, ByteString, null, filter, head )+import Data.Char ( isPrint )+import Darcs.Patch+import Darcs.Patch.Test+import Darcs.Patch.Unit ( patch_unit_tests )+import Lcs ( shiftBoundaries )+import Test.QuickCheck+import Printer ( renderPS, text )+import Darcs.Patch.Commute+import Data.Array.Base+import Data.Array.Unboxed+import Control.Monad.ST+import Darcs.Ordered+import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal )+import Darcs.Email ( make_email, read_email, formatHeader )+import Test.HUnit ( assertBool, assertFailure )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Runners.Console ( defaultMain )+import Test.Framework ( Test )++#include "impossible.h"+\end{code}++\chapter{Main body of code}++\begin{code}+main :: IO ()+main = do+    putStr ("There are a total of "++(show (length primitive_test_patches))+            ++" primitive patches.\n")+    putStr ("There are a total of "+++            (show (length test_patches))++" patches.\n")+    defaultMain tests++-- | Utility function to run bools with test-framework+testBool :: String -> Bool -> Test+testBool name test = testCase name (assertBool assertName test)+  where assertName = "boolean test \"" ++ name ++ "\" should return True"++-- | Utility function to run old tests that return a list of error messages,+--   with the empty list meaning success.+testStringList :: String -> [String] -> Test+testStringList name test = testCase name $ mapM_ assertFailure test++-- | This is the big list of tests that will be run using testrunner.+tests :: [Test]+tests = patch_unit_tests +++        [testBool "Checking that UTF-8 packing and unpacking preserves 'hello world'"+                  (unpackPSfromUTF8 (BC.pack "hello world") == "hello world"),+         testBool "Checking that hex packing and unpacking preserves 'hello world'"+                  (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")+                       == "hello world"),+         testProperty "Checking that email can be parsed"+          (\s ->+            unlines ("":s++["", ""]) ==+              BC.unpack (read_email (renderPS+                    $ make_email "reponame" [] (Just (text "contents\n"))+                                 (text $ unlines s) (Just "filename")))),+         testProperty "Checking email header line length" email_header_no_long_lines,+         testProperty "Checking email for illegal characters" email_header_ascii_chars,+         testProperty "Checking for spaces at start of folded email header lines" email_header_lines_start,+         testProperty "Checking that there are no empty lines in email headers" email_header_no_empty_lines,+         testProperty "Checking that B.concat works" prop_concatPS,+         testProperty "Checking that hex conversion works" prop_hex_conversion,+         testProperty "Checking that show and read work right" prop_read_show,+         testStringList "Checking known commutes" commute_tests,+         testStringList "Checking known merges" merge_tests,+         testStringList "Checking known canons" canonization_tests]+        ++ check_subcommutes subcommutes_inverse "patch and inverse both commutex"+        ++ check_subcommutes subcommutes_nontrivial_inverse "nontrivial commutes are correct"+        ++ check_subcommutes subcommutes_failure "inverses fail"+        +++        [testProperty "Checking that commuting by patch and its inverse is ok" prop_commute_inverse,+         --putStr "Checking that conflict resolution is valid... "+         --runQuickCheckTest returnval prop_resolve_conflicts_valid+         testProperty "Checking that a patch followed by its inverse is identity" prop_patch_and_inverse_is_identity,+         -- The following tests are "wrong" with the Conflictor code.+         --putStr "Checking that a simple smart_merge is sufficient... "+         --runQuickCheckTest returnval prop_simple_smart_merge_good_enough+         --putStr "Checking that an elegant merge is sufficient... "+         --runQuickCheckTest returnval prop_elegant_merge_good_enough+         testProperty "Checking that commutes are equivalent" prop_commute_equivalency,+         testProperty "Checking that merges are valid" prop_merge_valid,+         testProperty "Checking inverses being valid" prop_inverse_valid,+         testProperty "Checking other inverse being valid" prop_other_inverse_valid,+         testStringList "Checking merge swaps" merge_swap_tests,+         -- The patch generator isn't smart enough to generate correct test+         -- cases for the following: (which will be obsoleted soon, anyhow)+         --putStr "Checking the order dependence of unravel... "+         --runQuickCheckTest returnval prop_unravel_order_independent+         --putStr "Checking the unravelling of three merges... "+         --runQuickCheckTest returnval prop_unravel_three_merge+         --putStr "Checking the unravelling of a merge of a sequence... "+         --runQuickCheckTest returnval prop_unravel_seq_merge+         testProperty "Checking inverse of inverse" prop_inverse_composition,+         testProperty "Checking the order of commutes" prop_commute_either_order,+         testProperty "Checking commutex either way" prop_commute_either_way,+         testProperty "Checking the double commutex" prop_commute_twice,+         testProperty "Checking that merges commutex and are well behaved" prop_merge_is_commutable_and_correct,+         testProperty "Checking that merges can be swapped" prop_merge_is_swapable,+         testProperty "Checking again that merges can be swapped (I'm paranoid) " prop_merge_is_swapable,+         testStringList "Checking that the patch validation works" test_check,+         testStringList "Checking commutex/recommute" commute_recommute_tests,+         testStringList "Checking merge properties" generic_merge_tests,+         testStringList "Testing the lcs code" show_lcs_tests,+         testStringList "Checking primitive patch IO functions" primitive_show_read_tests,+         testStringList "Checking IO functions" show_read_tests,+         testStringList "Checking primitive commutex/recommute" primitive_commute_recommute_tests+        ]+\end{code}++\chapter{Unit Tester}++The unit tester function is really just a glorified map for functions that+return lists, in which the lists get concatenated (where map would end up+with a list of lists).++\begin{code}+type PatchUnitTest p = p -> [String]+type TwoPatchUnitTest = Patch -> Patch -> [String]++parallel_pair_unit_tester :: TwoPatchUnitTest -> [(Patch:\/:Patch)] -> [String]+parallel_pair_unit_tester _ []        = []+parallel_pair_unit_tester thetest ((p1:\/:p2):ps)+    = (thetest p1 p2)++(parallel_pair_unit_tester thetest ps)++pair_unit_tester :: TwoPatchUnitTest -> [(Patch:<Patch)] -> [String]+pair_unit_tester _ []        = []+pair_unit_tester thetest ((p1:<p2):ps)+    = (thetest p1 p2)++(pair_unit_tester thetest ps)+\end{code}++\chapter{Email format tests}++These tests check whether the emails generated by darcs meet a few criteria.+We check for line length and non-ASCII characters. We apparently do not have to+check for CR-LF newlines because that's handled by sendmail.++\begin{code}++-- Check that formatHeader never creates lines longer  than 78 characters+-- (excluding the carriage return and line feed)+email_header_no_long_lines :: String -> String -> Bool+email_header_no_long_lines field value =+    not $ any (>78) $ map B.length $ bs_lines $ formatHeader cleanField value+  where cleanField = clean_field_string field++bs_lines :: B.ByteString -> [B.ByteString]+bs_lines = finalizeFold . B.foldr splitAtLines (B.empty, [])+  where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)+        splitAtLines c  (thisLine, prevLines) = (B.cons c thisLine, prevLines)+        finalizeFold (lastLine, otherLines) = lastLine : otherLines++-- Check that an email header does not contain non-ASCII characters+-- formatHeader doesn't escape field names, there is no such thing as non-ascii+-- field names afaik+email_header_ascii_chars :: String -> String -> Bool+email_header_ascii_chars field value+    = not (any (>127) (B.unpack (formatHeader cleanField value)))+  where cleanField = clean_field_string field++-- Check that header the second and later lines of a header start with a space+email_header_lines_start :: String -> String -> Bool+email_header_lines_start field value =+    all (\l -> B.null l || B.head l == 32) (tail headerLines)+  where headerLines = bs_lines (formatHeader cleanField value)+        cleanField  = clean_field_string field++-- Checks that there are no lines in email headers with only whitespace+email_header_no_empty_lines :: String -> String -> Bool+email_header_no_empty_lines field value =+    all (not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines+  where headerLines = bs_lines (formatHeader cleanField value)+        cleanField  = clean_field_string field++clean_field_string :: String -> String+clean_field_string = filter (\c -> isPrint c && c < '\x80' && c /= ':')++\end{code}++\chapter{LCS}++Here are a few quick tests of the shiftBoundaries function.++\begin{code}+show_lcs_tests :: [String]+show_lcs_tests = concatMap check_known_shifts known_shifts+check_known_shifts :: ([Int],[Int],String,String,[Int],[Int])+                   -> [String]+check_known_shifts (ca, cb, sa, sb, ca', cb') = runST (+    do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)+       cb_arr <- newListArray (0, length cb) $ toBool (0:cb)+       let p_a = listArray (0, length sa) $ B.empty:(toPS sa)+           p_b = listArray (0, length sb) $ B.empty:(toPS sb)+       shiftBoundaries ca_arr cb_arr p_a 1 1+       shiftBoundaries cb_arr ca_arr p_b 1 1+       ca_res <- fmap (fromBool . tail) $ getElems ca_arr+       cb_res <- fmap (fromBool . tail) $ getElems cb_arr+       return $ if ca_res  == ca' && cb_res == cb' then []+                else ["shiftBoundaries failed on "++sa++" and "++sb++" with "+                      ++(show (ca,cb))++" expected "++(show (ca', cb'))+                      ++" got "++(show (ca_res, cb_res))++"\n"])+ where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])+       toBool = map (>0)+       fromBool = map (\b -> if b then 1 else 0)++known_shifts :: [([Int],[Int],String,String,[Int],[Int])]+known_shifts =+  [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",+    [0,0,0],[0,0,0,1,1]),+   ([0,1,0],[0,1,1,0],"cd ","c a ",+    [0,1,0],[0,1,1,0]),+   ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",+    [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+   ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",+    [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+   ([],[1,1],"","aa",[],[1,1]),+   ([1,1],[],"aa","",[1,1],[])]+++\end{code}++\chapter{Show/Read tests}++This test involves calling ``show'' to print a string describing a patch,+and then using readPatch to read it back in, and making sure the patch we+read in is the same as the original.  Useful for making sure that I don't+have any stupid IO bugs.++\begin{code}+show_read_tests :: [String]+show_read_tests = concatMap t_show_read test_patches +++                  concatMap t_show_read test_patches_named+primitive_show_read_tests :: [String]+primitive_show_read_tests = concatMap t_show_read primitive_test_patches+t_show_read :: (Eq p, Show p, Patchy p) => PatchUnitTest p+t_show_read p =+    case readPatch $ renderPS $ showPatch p of+    Just (Sealed p',_) -> if p' == p then []+                          else ["Failed to read shown:  "++(show p)++"\n"]+    Nothing -> ["Failed to read at all:  "++(show p)++"\n"]++instance MyEq p => Eq (Named p) where+    (==) = unsafeCompare+\end{code}++\chapter{Canonization tests}++This is a set of known correct canonizations, to make sure that I'm+canonizing as I ought.++\begin{code}+canonization_tests :: [String]+canonization_tests = concatMap check_known_canon known_canons+check_known_canon :: (Patch, Patch) -> [String]+check_known_canon (p1,p2) =+    if (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1) == p2+    then []+    else ["Canonization failed:\n"++show p1++"canonized is\n"+          ++show (fromPrims $ concatFL $ mapFL_FL canonize $ sort_coalesceFL $ effect p1 :: Patch)+          ++"which is not\n"++show p2]+known_canons :: [(Patch,Patch)]+known_canons =+    [(quickhunk 1 "abcde" "ab",  quickhunk 3 "cde"   ""),+     (quickhunk 1 "abcde" "bd", join_patches [quickhunk 1 "a" "",+                                              quickhunk 2 "c" "",+                                              quickhunk 3 "e" ""]),+     (join_patches [quickhunk 4 "a" "b",+                    quickhunk 1 "c" "d"],+      join_patches [quickhunk 1 "c" "d",+                    quickhunk 4 "a" "b"]),+     (join_patches [quickhunk 1 "a" "",+                    quickhunk 1 "" "b"],+      quickhunk 1 "a" "b"),+     (join_patches [quickhunk 1 "ab" "c",+                    quickhunk 1 "cd" "e"],+      quickhunk 1 "abd" "e"),+     (quickhunk 1 "abcde" "cde", quickhunk 1 "ab" ""),+     (quickhunk 1 "abcde" "acde", quickhunk 2 "b" "")]+quickhunk :: Int -> String -> String -> Patch+quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)+                                             (map (\c -> BC.pack [c]) n)+\end{code}++\chapter{Merge/unmgerge tests}++It should always be true that if two patches can be unmerged, then merging+the resulting patches should give them back again.+\begin{code}+generic_merge_tests :: [String]+generic_merge_tests =+  case take 400 [(p1:\/:p2)|+                 i <- [0..(length test_patches)-1],+                 p1<-[test_patches!!i],+                 p2<-drop i test_patches,+                 check_a_patch $ join_patches [invert p2,p1]] of+  merge_pairs -> (parallel_pair_unit_tester t_merge_either_way_valid merge_pairs) +++                 (parallel_pair_unit_tester t_merge_swap_merge merge_pairs)+t_merge_either_way_valid   :: TwoPatchUnitTest+t_merge_either_way_valid p1 p2 =+  case join_patches [p2, quickmerge (p1:\/: p2)] of+  combo2 ->+    case join_patches [p1, quickmerge (p2:\/: p1)] of+    combo1 ->+      if not $ check_a_patch $ join_patches [combo1]+      then ["oh my combo1 invalid:\n"++show p1++"and...\n"++show p2++show combo1]+      else+        if check_a_patch $ join_patches [invert combo1, combo2]+        then []+        else ["merge both ways invalid:\n"++show p1++"and...\n"++show p2+++              show combo1+++              show combo2]+t_merge_swap_merge   :: TwoPatchUnitTest+t_merge_swap_merge p1 p2 =+  if (swapp $ merge (p2:\/: p1)) == merge (p1:\/:p2)+  then []+  else ["Failed to swap merges:\n"++show p1++"and...\n"++show p2+        ++"merged:\n"++show (merge (p1:\/:p2))++"\n"+        ++"merged and swapped:\n"++show (swapp $ merge (p2:\/: p1))++"\n"]+    where swapp (x :/\: y) = y :/\: x++instance Show p => Show (p :/\: p) where+   show (x :/\: y) = show x ++ " :/\\: " ++ show y+instance Eq p => Eq (p :/\: p) where+   (x :/\: y) == (x' :/\: y') = x == x' && y == y'+\end{code}++\chapter{Commute/recommute tests}++Here we test to see if commuting patch A and patch B and then commuting the+result gives us patch A and patch B again.  The set of patches (A,B) is+chosen from the set of all pairs of test patches by selecting those which+commutex with one another.++\begin{code}+commute_recommute_tests :: [String]+commute_recommute_tests =+  case take 200 [(p2:<p1)|+                 p1<-test_patches,+                 p2<-filter (\p->checkseq [p1,p]) test_patches,+                 commutex (p2:<p1) /= Nothing] of+  commute_pairs -> pair_unit_tester t_commute_recommute commute_pairs+  where checkseq ps = check_a_patch $ join_patches ps+primitive_commute_recommute_tests :: [String]+primitive_commute_recommute_tests =+  pair_unit_tester t_commute_recommute+    [(p1:<p2)|+     p1<-primitive_test_patches,+     p2<-primitive_test_patches,+     commutex (p1:<p2) /= Nothing,+     check_a_patch $ join_patches [p2,p1]]+t_commute_recommute   :: TwoPatchUnitTest+t_commute_recommute p1 p2 =+    if (commutex (p1:<p2) >>= commutex) == Just (p1:<p2)+       then []+       else ["Failed to recommute:\n"++(show p1)++(show p2)+++            "we saw it as:\n"++show (commutex (p1:<p2))+++             "\nAnd recommute was:\n"++show (commutex (p1:<p2) >>= commutex)+             ++ "\n"]+\end{code}++\chapter{Commute tests}++Here we provide a set of known interesting commutes.+\begin{code}+commute_tests :: [String]+commute_tests =+    concatMap check_known_commute known_commutes+++    concatMap check_cant_commute known_cant_commute+check_known_commute :: (Patch:< Patch, Patch:< Patch) -> [String]+check_known_commute (p1:<p2,p2':<p1') =+   case commutex (p1:<p2) of+   Just (p2a:<p1a) ->+       if (p2a:< p1a) == (p2':< p1')+       then []+       else ["Commute gave wrong value!\n"++show p1++"\n"++show p2+             ++"should be\n"++show p2'++"\n"++show p1'+             ++"but is\n"++show p2a++"\n"++show p1a]+   Nothing -> ["Commute failed!\n"++show p1++"\n"++show p2]+   +++   case commutex (p2':<p1') of+   Just (p1a:<p2a) ->+       if (p1a:< p2a) == (p1:< p2)+       then []+       else ["Commute gave wrong value!\n"++show p2a++"\n"++show p1a+             ++"should have been\n"++show p2'++"\n"++show p1']+   Nothing -> ["Commute failed!\n"++show p2'++"\n"++show p1']+known_commutes :: [(Patch:<Patch,Patch:<Patch)]+known_commutes = [+                  (testhunk 1 [] ["A"]:<+                   testhunk 2 [] ["B"],+                   testhunk 3 [] ["B"]:<+                   testhunk 1 [] ["A"]),+                  (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<+                   testhunk 2+                   ["hello world all that is old is good old_"]+                   ["I don't like old things"],+                   testhunk 2+                   ["hello world all that is new is good old_"]+                   ["I don't like new things"]:<+                   fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),+                  (testhunk 1 ["A"] ["B"]:<+                   testhunk 2 ["C"] ["D"],+                   testhunk 2 ["C"] ["D"]:<+                   testhunk 1 ["A"] ["B"]),+                  (fromPrim (rmfile "NwNSO"):<+                   (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),+                   (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<+                   fromPrim (rmfile "NwNSO")),++                  (quickmerge (testhunk 3 ["o"] ["n"]:\/:+                               testhunk 3 ["o"] ["v"]):<+                   testhunk 1 [] ["a"],+                   testhunk 1 [] ["a"]:<+                   quickmerge (testhunk 2 ["o"] ["n"]:\/:+                               testhunk 2 ["o"] ["v"])),++                  (testhunk 1 ["A"] []:<+                   testhunk 3 ["B"] [],+                   testhunk 2 ["B"] []:<+                   testhunk 1 ["A"] []),++                  (testhunk 1 ["A"] ["B"]:<+                   testhunk 2 ["B"] ["C"],+                   testhunk 2 ["B"] ["C"]:<+                   testhunk 1 ["A"] ["B"]),++                  (testhunk 1 ["A"] ["B"]:<+                   testhunk 3 ["B"] ["C"],+                   testhunk 3 ["B"] ["C"]:<+                   testhunk 1 ["A"] ["B"]),++                  (testhunk 1 ["A"] ["B","C"]:<+                   testhunk 2 ["B"] ["C","D"],+                   testhunk 3 ["B"] ["C","D"]:<+                   testhunk 1 ["A"] ["B","C"])]+  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++check_cant_commute :: (Patch:< Patch) -> [String]+check_cant_commute (p1:<p2) =+    case commutex (p1:<p2) of+    Nothing -> []+    _ -> [show p1 ++ "\n\n" ++ show p2 +++          "\nArgh, these guys shouldn't commutex!\n"]+known_cant_commute :: [(Patch:< Patch)]+known_cant_commute = [+                      (testhunk 2 ["o"] ["n"]:<+                       testhunk 1 [] ["A"]),+                      (testhunk 1 [] ["A"]:<+                       testhunk 1 ["o"] ["n"]),+                      (quickmerge (testhunk 2 ["o"] ["n"]:\/:+                                   testhunk 2 ["o"] ["v"]):<+                       testhunk 1 [] ["a"]),+                      (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):<+                       fromPrim (addfile "test"))]+  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)+\end{code}++\chapter{Merge tests}++Here we provide a set of known interesting merges.+\begin{code}+merge_tests :: [String]+merge_tests =+    concatMap check_known_merge_equiv known_merge_equivs+++    concatMap check_known_merge known_merges+check_known_merge :: (Patch:\/: Patch, Patch:< Patch) -> [String]+check_known_merge (p1:\/:p2,p1':<p2') =+   case merge (p1:\/:p2) of+   _ :/\: p1a ->+       if (p1a:< p2) == (p1':< p2')+       then []+       else ["Merge gave wrong value!\n"++show p1++show p2+             ++"I expected\n"++show p1'++show p2'+             ++"but found instead\n"++show p1a]+known_merges :: [(Patch:\/:Patch,Patch:<Patch)]+known_merges = [+                (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:+                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],+                 testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:<+                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),+                (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:+                 testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],+                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:<+                 testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),+                (testhunk 3 [BC.pack "A"] []:\/:+                 testhunk 1 [BC.pack "B"] [],+                 testhunk 2 [BC.pack "A"] []:<+                 testhunk 1 [BC.pack "B"] []),+                (fromPrim (rmdir "./test/world"):\/:+                 fromPrim (hunk "./world" 3 [BC.pack "A"] []),+                 fromPrim (rmdir "./test/world"):<+                 fromPrim (hunk "./world" 3 [BC.pack "A"] [])),++                (join_patches [quickhunk 1 "a" "bc",+                               quickhunk 6 "d" "ef"]:\/:+                 join_patches [quickhunk 3 "a" "bc",+                               quickhunk 8 "d" "ef"],+                 join_patches [quickhunk 1 "a" "bc",+                               quickhunk 7 "d" "ef"]:<+                 join_patches [quickhunk 3 "a" "bc",+                               quickhunk 8 "d" "ef"]),++                (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:+                 testhunk 2 [BC.pack "B"] [BC.pack "C"],+                 testhunk 1 [BC.pack "A"] [BC.pack "B"]:<+                 testhunk 2 [BC.pack "B"] [BC.pack "C"]),++                (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:+                 testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],+                 testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:<+                 testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"])]+  where testhunk l o n = fromPrim $ hunk "test" l o n+check_known_merge_equiv :: (Patch:\/:Patch,Patch) -> [String]+check_known_merge_equiv (p1:\/: p2, pe) =+    case quickmerge (p1:\/:p2) of+    p1' -> if check_a_patch $ join_patches [invert p1, p2, p1', invert pe]+           then []+           else ["Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2+                 ++"in other words\n" ++ show (p1 :\/: p2)+                 ++"merges as\n" ++ show (merge $ p1 :\/: p2)+                 ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)+                 ++"which is equivalent to\n" ++ show (effect p1')+                 ++ "should all work out to\n"+                 ++ show pe]+known_merge_equivs :: [(Patch:\/: Patch, Patch)]+known_merge_equivs = [++                     -- The following tests are going to be failed by the+                     -- Conflictor code as a cleanup.++                     --(addfile "test":\/:+                     -- adddir "test",+                     -- join_patches [adddir "test",+                     --               addfile "test-conflict"]),+                     --(move "silly" "test":\/:+                     -- adddir "test",+                     -- join_patches [adddir "test",+                     --               move "silly" "test-conflict"]),+                     --(addfile "test":\/:+                     -- move "old" "test",+                     -- join_patches [addfile "test",+                     --               move "old" "test-conflict"]),+                     --(move "a" "test":\/:+                     -- move "old" "test",+                     -- join_patches [move "a" "test",+                     --               move "old" "test-conflict"]),+                     (fromPrim (hunk "test" 1 [] [BC.pack "A"]):\/:+                      fromPrim (hunk "test" 1 [] [BC.pack "B"]),+                      fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),+                     (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:+                      fromPrim (hunk "test" 1 [BC.pack "b"] []),+                      identity),+                      --hunk "test" 1 [] [BC.pack "v v v v v v v",+                      --                  BC.pack "*************",+                      --                  BC.pack "a",+                      --                  BC.pack "b",+                      --                  BC.pack "^ ^ ^ ^ ^ ^ ^"]),+                     (quickhunk 4 "a"  "":\/:+                      quickhunk 3 "a"  "",+                      quickhunk 3 "aa" ""),+                     (join_patches [quickhunk 1 "a" "bc",+                                    quickhunk 6 "d" "ef"]:\/:+                      join_patches [quickhunk 3 "a" "bc",+                                    quickhunk 8 "d" "ef"],+                      join_patches [quickhunk 3 "a" "bc",+                                    quickhunk 8 "d" "ef",+                                    quickhunk 1 "a" "bc",+                                    quickhunk 7 "d" "ef"]),+                     (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a"):\/:+                              quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),+                              quickhunk 2 "" "abdc")+                     ]+\end{code}++It also is useful to verify that it doesn't matter which order we specify+the patches when we merge.++\begin{code}+merge_swap_tests :: [String]+merge_swap_tests =+    concat+              [check_merge_swap p1 p2 |+               p1<-primitive_test_patches,+               p2<-primitive_test_patches,+               check_a_patch $ join_patches [invert p1,p2]+              ]+check_merge_swap :: Patch -> Patch -> [String]+check_merge_swap p1 p2 =+    case merge (p2:\/:p1) of+    _ :/\: p2' ->+        case merge (p1:\/:p2) of+        _ :/\: p1' ->+            case commutex (p2':<p1) of+            Just (p1'b:<_) ->+                if p1'b /= p1'+                then ["Merge swapping problem with...\np1 "+++                      show p1++"merged with\np2 "+++                      show p2++"p1' is\np1' "+++                      show p1'++"p1'b is\np1'b  "+++                      show p1'b+                     ]+                else []+            Nothing -> ["Merge commuting problem with...\np1 "+++                        show p1++"merged with\np2 "+++                        show p2++"gives\np2' "+++                        show p2'++"which doesn't commutex with p1.\n"+                       ]+\end{code}++\chapter{Patch test data}++This is where we define the set of patches which we run our tests on.  This+should be kept up to date with as many interesting permutations of patch+types as possible.++\begin{code}+test_patches :: [Patch]+test_patches_named :: [Named Patch]+test_patches_addfile :: [Patch]+test_patches_rmfile :: [Patch]+test_patches_hunk :: [Patch]+primitive_test_patches :: [Patch]+test_patches_binary :: [Patch]+test_patches_composite_nocom :: [Patch]+test_patches_composite :: [Patch]+test_patches_two_composite_hunks :: [Patch]+test_patches_composite_hunks :: [Patch]+test_patches_composite_four_hunks :: [Patch]+test_patches_merged :: [Patch]+valid_patches :: [Patch]++test_patches_named = [unsafePerformIO $+                      namepatch "date is" "patch name" "David Roundy" []+                                (fromPrim $ addfile "test"),+                      unsafePerformIO $+                      namepatch "Sat Oct 19 08:31:13 EDT 2002"+                                "This is another patch" "David Roundy"+                                ["This log file has","two lines in it"]+                                (fromPrim $ rmfile "test")]+test_patches_addfile = map fromPrim+                       [addfile "test",adddir "test",addfile "test/test"]+test_patches_rmfile = map invert test_patches_addfile+test_patches_hunk  =+    [fromPrim $ hunk file line old new |+     file <- ["test"],+     line <- [1,2],+     old <- map (map BC.pack) partials,+     new <- map (map BC.pack) partials,+     old /= new+    ]+    where partials  = [["A"],["B"],[],["B","B2"]]++primitive_test_patches = test_patches_addfile +++                         test_patches_rmfile +++                         test_patches_hunk +++                         [unsafeUnseal.fst.fromJust.readPatch $+                          BC.pack "move ./test/test ./hello",+                          unsafeUnseal.fst.fromJust.readPatch $+                          BC.pack "move ./test ./hello"] +++                         test_patches_binary++test_patches_binary =+    [fromPrim $ binary "./hello"+     (BC.pack $ "agadshhdhdsa75745457574asdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg")+     (BC.pack $ "adafjttkykrehhtrththrthrthre" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaagg"),+     fromPrim $ binary "./hello"+     B.empty+     (BC.pack "adafjttkykrere")]++test_patches_composite_nocom =+    take 50 [join_patches [p1,p2]|+             p1<-primitive_test_patches,+             p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,+             commutex (p2:<p1) == Nothing]+    where checkseq ps = check_a_patch $ join_patches ps++test_patches_composite =+    take 100 [join_patches [p1,p2]|+              p1<-primitive_test_patches,+              p2<-filter (\p->checkseq [p1,p]) primitive_test_patches,+              commutex (p2:<p1) /= Nothing,+              commutex (p2:<p1) /= Just (p1:<p2)]+    where checkseq ps = check_a_patch $ join_patches ps++test_patches_two_composite_hunks =+    take 100 [join_patches [p1,p2]|+              p1<-test_patches_hunk,+              p2<-filter (\p->checkseq [p1,p]) test_patches_hunk]+    where checkseq ps = check_a_patch $ join_patches ps++test_patches_composite_hunks =+    take 100 [join_patches [p1,p2,p3]|+              p1<-test_patches_hunk,+              p2<-filter (\p->checkseq [p1,p]) test_patches_hunk,+              p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk]+    where checkseq ps = check_a_patch $ join_patches ps++test_patches_composite_four_hunks =+    take 100 [join_patches [p1,p2,p3,p4]|+              p1<-test_patches_hunk,+              p2<-filter (\p->checkseq [p1,p]) test_patches_hunk,+              p3<-filter (\p->checkseq [p1,p2,p]) test_patches_hunk,+              p4<-filter (\p->checkseq [p1,p2,p3,p]) test_patches_hunk]+    where checkseq ps = check_a_patch $ join_patches ps++test_patches_merged =+  take 200+    [joinPatches $ flattenFL p2+>+flattenFL (quickmerge (p1:\/:p2)) |+     p1<-take 10 (drop 15 test_patches_composite_hunks)++primitive_test_patches+         ++take 10 (drop 15 test_patches_two_composite_hunks)+         ++ take 2 (drop 4 test_patches_composite_four_hunks),+     p2<-take 10 test_patches_composite_hunks++primitive_test_patches+         ++take 10 test_patches_two_composite_hunks+         ++take 2 test_patches_composite_four_hunks,+     check_a_patch $ join_patches [invert p1, p2],+     commutex (p1:<p2) /= Just (p2:<p1)+    ]++test_patches =  primitive_test_patches +++                test_patches_composite +++                test_patches_composite_nocom +++                test_patches_merged+\end{code}++\chapter{Check patch test}+Check patch is supposed to verify that a patch is valid.++\begin{code}+valid_patches = [(join_patches [quickhunk 4 "a" "b",+                                quickhunk 1 "c" "d"]),+                 (join_patches [quickhunk 1 "a" "bc",+                                quickhunk 1 "b" "d"]),+                 (join_patches [quickhunk 1 "a" "b",+                                quickhunk 1 "b" "d"])]++test_patches++test_check :: [String]+test_check = concatMap t_test_check valid_patches+t_test_check :: PatchUnitTest Patch+t_test_check p = if check_a_patch p+                 then []+                 else ["Failed the check:  "++show p++"\n"]++prop_hex_conversion :: String -> Bool+prop_hex_conversion s =+    fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s+prop_concatPS :: [String] -> Bool+prop_concatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)++-- | Groups a set of tests by giving them the same prefix in their description.+--   When this is called as @check_subcommutes subcoms expl@, the prefix for a+--   test becomes @"Checking " ++ expl ++ " for subcommute "@.+check_subcommutes :: Testable a => [(String, a)] -> String+                                                 -> [Test]+check_subcommutes subcoms expl = map check_subcommute subcoms+  where check_subcommute (name, test) =+            let testName = "Checking" ++ expl ++ " for subcommute " ++ name+            in testProperty testName test+\end{code}++\end{document}++
+ src/win32/CtrlC.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module CtrlC (withCtrlCHandler) where++import Data.Word ( Word32 )+import Foreign.Ptr ( FunPtr )+import Control.Exception ( bracket )++type Handler = Word32 -> IO Int++foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler)+foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()+++withCtrlCHandler :: IO () -> IO a -> IO a+withCtrlCHandler handler m = do+    fp <- wrap (\_ctrlType -> handler >> return 1)+    bracket (setConsoleCtrlHandler fp 1) (const $ setConsoleCtrlHandler fp 0) (const m)+++
+ src/win32/System/Posix.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module System.Posix where++import Foreign.Ptr ( Ptr, castPtr, plusPtr )+import Foreign.Storable ( peek, poke, sizeOf )+import Foreign.C.Types ( CInt, CUInt, CULong, CTime )+import Foreign.C.String ( CString, withCString )+import Foreign.Marshal.Alloc ( allocaBytes )++import System.Posix.Types ( EpochTime )+import System.IO ( Handle )+++foreign import ccall "sys/utime.h _utime" c_utime :: CString -> Ptr a -> IO CInt++setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()+setFileTimes path atime mtime = path `withCString` \s -> do+  allocaBytes 8 $ \p -> do+    poke (castPtr p :: Ptr CTime) (atime)+    poke (castPtr (plusPtr p 4) :: Ptr CTime) (mtime)+    c_utime s p+    return ()+++foreign import ccall "time" c_ctime :: Ptr CTime -> IO CInt++epochTime :: IO EpochTime+epochTime = do+    allocaBytes (sizeOf (undefined :: CTime)) $ \p -> do+      c_ctime p+      t <- peek p :: IO CTime+      return t++foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt++sleep :: Integer -> IO CInt+sleep n = c_SleepEx (1000 * fromIntegral n) 1++handleToFd :: Handle -> IO Int+handleToFd _ = fail "handleToFd not supported!"+
+ src/win32/System/Posix/Files.hsc view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -cpp #-}+module System.Posix.Files where++import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.C.Error ( throwErrnoIfMinus1Retry, throwErrnoPathIf_ )+import Foreign.C.String ( withCString, withCWString, CWString )+import Foreign.C.Types ( CTime, CInt )+import Foreign.Ptr ( Ptr, nullPtr )++import System.Posix.Internals+          ( FDType, CStat, c_fstat, lstat, +            sizeof_stat, statGetType, +            st_mode, st_size, st_mtime,+            s_isreg, s_isdir, s_isfifo, )+import System.Posix.Types ( Fd(..), CMode, EpochTime, FileMode )++import Data.Bits ( (.|.) )++#if mingw32_HOST_OS+import Data.Int ( Int64 )+#else+import System.Posix.Types ( FileOffset )+#endif++##if mingw32_HOST_OS+type FileOffset = Int64+##endif++data FileStatus = FileStatus {+    fst_type :: FDType,+    fst_mode :: CMode,+    fst_mtime :: CTime,+    fst_size :: FileOffset+ }++getFdStatus :: Fd -> IO FileStatus+getFdStatus (Fd fd) = do+  do_stat (c_fstat fd)++do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus+do_stat stat_func = do+  allocaBytes sizeof_stat $ \p -> do+    throwErrnoIfMinus1Retry "do_stat" $+      stat_func p+    tp <- statGetType p+    mode <- st_mode p+    mtime <- st_mtime p+    size <- st_size p+    return (FileStatus tp mode mtime (fromIntegral size))++isNamedPipe :: FileStatus -> Bool+isNamedPipe = s_isfifo . fst_mode++isDirectory :: FileStatus -> Bool+isDirectory = s_isdir . fst_mode++isRegularFile :: FileStatus -> Bool+isRegularFile = s_isreg . fst_mode++isSymbolicLink :: FileStatus -> Bool+isSymbolicLink = const False++linkCount :: FileStatus -> Int+linkCount _ = 1++modificationTime :: FileStatus -> EpochTime+modificationTime = fst_mtime++fileSize :: FileStatus -> FileOffset+fileSize = fst_size++fileMode :: () -> ()+fileMode _ = ()++getFileStatus :: FilePath -> IO ()+getFileStatus _ = return ()++setFileMode :: FilePath -> () -> IO ()+setFileMode _ _ = return ()++#include <sys/stat.h>+stdFileMode :: FileMode+stdFileMode = (#const S_IRUSR) .|. (#const S_IWUSR)++++getSymbolicLinkStatus :: FilePath -> IO FileStatus+getSymbolicLinkStatus fp = +  do_stat (\p -> (fp `withCString` (`lstat` p)))++#define _WIN32_WINNT 0x0500+foreign import stdcall "winbase.h CreateHardLinkW" c_CreateHardLink :: CWString -> CWString -> Ptr a -> IO CInt++createLink :: FilePath -> FilePath -> IO ()+createLink old new = withCWString old $ \c_old -> withCWString new $ \c_new ->+	throwErrnoPathIf_ (==0) "createLink" new $+		c_CreateHardLink c_new c_old nullPtr
+ src/win32/System/Posix/IO.hsc view
@@ -0,0 +1,69 @@+module System.Posix.IO where++import Foreign.C.String ( withCString )+import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ )++import GHC.Handle ( fdToHandle )++import System.Posix.Internals ( c_open, c_close, c_dup2 )+import System.Posix.Types ( Fd(..), FileMode )+import System.IO ( Handle )++import Data.Bits ( (.|.) )+++stdOutput :: Fd+stdOutput = Fd 1++stdError :: Fd+stdError = Fd 2++data OpenFileFlags = + OpenFileFlags {+  append :: Bool,+  exclusive :: Bool,+  noctty :: Bool,+  nonBlock :: Bool,+  trunc :: Bool+ }+++-- Adapted from System.Posix.IO in ghc+#include <fcntl.h>++openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd+openFd name how maybe_mode off = do+  withCString name $ \s -> do+   fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)+   return (Fd fd)+ where+   all_flags = binary .|. creat .|. flags .|. open_mode+   flags =+    (if append off    then (#const O_APPEND)   else 0) .|.+    (if exclusive off then (#const O_EXCL)     else 0) .|.+    (if trunc off     then (#const O_TRUNC)    else 0)+   binary = (#const O_BINARY)+   (creat, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) maybe_mode+   open_mode = case how of+                ReadOnly  -> (#const O_RDONLY)+                WriteOnly -> (#const O_WRONLY)+                ReadWrite -> (#const O_RDWR)++closeFd :: Fd -> IO ()+closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd)+++fdToHandle :: Fd -> IO Handle+fdToHandle fd = GHC.Handle.fdToHandle (fromIntegral fd)++dupTo :: Fd -> Fd -> IO Fd+dupTo (Fd fd1) (Fd fd2) = do+  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)+  return (Fd r)++data OpenMode = ReadOnly | WriteOnly | ReadWrite++defaultFileFlags :: OpenFileFlags+defaultFileFlags = OpenFileFlags False False False False False++
+ src/win32/send_email.c view
@@ -0,0 +1,211 @@+++#include <windows.h>+#include <mapi.h>+#include <stdio.h>++#include "send_email.h"++typedef struct sMapiFuns {+    LPMAPILOGON logon;+    LPMAPISENDMAIL sendmail;+    LPMAPIRESOLVENAME resolve;+    LPMAPIFREEBUFFER free_buf;+    LPMAPILOGOFF logoff;+    HMODULE dll;+} MapiFuns;+++int load_dll(const char* name, MapiFuns* funs);+void free_dll(MapiFuns* funs);++void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup);++int send_email(const char *sendname, +               const char *recvname, +               const char *ccname, +               const char *subj,+               const char *body,+               const char *path)+{+    FLAGS flags;+    MapiMessage msg;+    ULONG send_res;+    MapiRecipDesc orig;+    MapiRecipDesc recips[2];+    MapiRecipDesc *orig_lookup, *recip_lookup, *cc_lookup;+    int num_recip = 1, return_code = -1;+    MapiFileDesc attachment;+    MapiFileTagExt file_type;+    const char *filename;+    char *attachment_path = 0;+    MapiFuns funs;+    +    if(load_dll("mapistub.dll", &funs) || load_dll("mapi32.dll", &funs)) {+        return_code=0;+    } else {+        fprintf(stderr, "Unable to load mapistub.dll or mapi32.dll: Bailing out. \n");+        return_code=-1;+    }++    if(return_code==0) {+        LHANDLE session;+        /* logon seems to be necessary for outlook express, sometimes,+        and doesn't seem to hurt, otherwise.+        */+        funs.logon(0, 0, 0, MAPI_LOGON_UI, 0, &session);++        +        orig_lookup = recip_lookup = cc_lookup = NULL;+        +        get_recipient(&funs, sendname, MAPI_ORIG, &orig, &orig_lookup);+        get_recipient(&funs, recvname, MAPI_TO, &recips[0], &recip_lookup);++        if (ccname && strlen(ccname) > 0) {+            get_recipient(&funs, ccname, MAPI_CC, &recips[1], &cc_lookup);+            num_recip++;+        }++        memset(&msg, 0, sizeof(msg));+        msg.lpOriginator = &orig;+        msg.lpRecips = recips;+        msg.lpszMessageType = "text/plain";+        msg.lpszNoteText = (LPSTR) body;+        msg.lpszSubject = (LPSTR)subj;+        msg.nRecipCount = num_recip;+        msg.flFlags = 0;++        if (path) {+            attachment_path = strdup(path);+            /* convert / to \  (thunderbird doesn't like /) */+            char *p = attachment_path;+            while ((p = strchr(p, '/')))+                *p = '\\';++            /* find filename */+            filename = strrchr(attachment_path, '\\');+            if (filename == 0)+                filename = attachment_path;+            else+                filename++;++            memset(&attachment, 0, sizeof(attachment));+            attachment.nPosition = -1;+            attachment.lpszPathName = (LPTSTR)attachment_path;+            attachment.lpszFileName = (LPTSTR)filename;++            attachment.lpFileType = &file_type;+            +            memset(&file_type, 0, sizeof(file_type));+            file_type.lpTag = "text/plain";+            file_type.cbTag = sizeof(file_type.lpTag);++            msg.nFileCount = 1;+            msg.lpFiles = &attachment;+        }++        flags = 0;+        send_res = funs.sendmail(0, 0, &msg, flags, 0);++        if (send_res == SUCCESS_SUCCESS)+            return_code = 0;+        else {+            return_code=-1;+            if(send_res==MAPI_E_USER_ABORT)                 fprintf(stderr, "MAPI error: User aborted.\n");+            else if(send_res== MAPI_E_FAILURE)              fprintf(stderr, "MAPI error: Generic error.\n");+            else if(send_res== MAPI_E_LOGIN_FAILURE)        fprintf(stderr, "MAPI error: Login failure.\n");+            else if(send_res== MAPI_E_DISK_FULL)            fprintf(stderr, "MAPI error: Disk full.\n");+            else if(send_res== MAPI_E_INSUFFICIENT_MEMORY)  fprintf(stderr, "MAPI error: Insufficient memory.\n");+            else if(send_res== MAPI_E_ACCESS_DENIED)        fprintf(stderr, "MAPI error: Access denied.\n");+            else if(send_res== MAPI_E_TOO_MANY_SESSIONS)    fprintf(stderr, "MAPI error: Too many sessions\n");+            else if(send_res== MAPI_E_TOO_MANY_FILES)       fprintf(stderr, "MAPI error: Too many files.\n");+            else if(send_res== MAPI_E_TOO_MANY_RECIPIENTS)  fprintf(stderr, "MAPI error: Too many recipients.\n");+            else if(send_res== MAPI_E_ATTACHMENT_NOT_FOUND) fprintf(stderr, "MAPI error: Attachment not found.\n");+            else if(send_res== MAPI_E_ATTACHMENT_OPEN_FAILURE)  fprintf(stderr, "MAPI error: Failed to open attachment.\n");+            else if(send_res== MAPI_E_ATTACHMENT_WRITE_FAILURE) fprintf(stderr, "MAPI error: Failed to write attachment.\n");+            else if(send_res== MAPI_E_UNKNOWN_RECIPIENT)    fprintf(stderr, "MAPI error: Unknown recipient\n");+            else if(send_res== MAPI_E_BAD_RECIPTYPE)        fprintf(stderr, "MAPI error: Bad type of recipent.\n");+            else if(send_res== MAPI_E_NO_MESSAGES)          fprintf(stderr, "MAPI error: No messages.\n");+            else if(send_res== MAPI_E_INVALID_MESSAGE)      fprintf(stderr, "MAPI error: Invalid message.\n");+            else if(send_res== MAPI_E_TEXT_TOO_LARGE)       fprintf(stderr, "MAPI error: Text too large.\n");+            else if(send_res== MAPI_E_INVALID_SESSION)      fprintf(stderr, "MAPI error: Invalid session.\n");+            else if(send_res== MAPI_E_TYPE_NOT_SUPPORTED)   fprintf(stderr, "MAPI error: Type not supported.\n");+            else if(send_res== MAPI_E_AMBIGUOUS_RECIP)      fprintf(stderr, "MAPI error: Ambigious recipient.\n");+            else if(send_res== MAPI_E_MESSAGE_IN_USE)       fprintf(stderr, "MAPI error: Messag in use.\n");+            else if(send_res== MAPI_E_NETWORK_FAILURE)      fprintf(stderr, "MAPI error: Network failure.\n");+            else if(send_res== MAPI_E_INVALID_EDITFIELDS)   fprintf(stderr, "MAPI error: Invalid editfields\n");+            else if(send_res== MAPI_E_INVALID_RECIPS)       fprintf(stderr, "MAPI error: Invalid recipient(s)\n");+            else if(send_res== MAPI_E_NOT_SUPPORTED)        fprintf(stderr, "MAPI error: Operation not supported.\n");+            else fprintf(stderr, "MAPISendMail returned %ld\n", send_res);+        }++        +        if (orig_lookup) funs.free_buf(orig_lookup);+        if (recip_lookup) funs.free_buf(recip_lookup);+        if (cc_lookup) funs.free_buf(cc_lookup);+        if (attachment_path) free(attachment_path);++        funs.logoff(session, 0, 0, 0);+    }+    free_dll(&funs);+    return return_code;+}++void get_recipient(MapiFuns* funs, const char *name, ULONG recipClass, MapiRecipDesc *desc, lpMapiRecipDesc *desc_lookup) {+    ULONG ret = funs->resolve(0, 0, (LPSTR) name, 0, 0, desc_lookup);+    if (ret == SUCCESS_SUCCESS) {+        memcpy(desc, *desc_lookup, sizeof(MapiRecipDesc));+    } else {+        /* Default to something sensible if MAPIResolveName is not supported +         * by the mail client (thunderbird)+         */+        memset(desc, 0, sizeof(MapiRecipDesc));+        desc->lpszName = (LPSTR)name;+        desc->lpszAddress = (LPSTR)name;+        desc->lpEntryID = 0;+        desc->ulEIDSize = 0;+    }+    desc->ulRecipClass = recipClass;+}+++int load_dll(const char* name, MapiFuns* funs) {+    funs->dll = 0;+    funs->dll = LoadLibrary(name);+    if(funs->dll!=NULL) {+        /* We try first loading by easy name, then by ordinal, and then by other names seen */+        funs->logon     = (LPMAPILOGON)         GetProcAddress(funs->dll, "MAPILogon");+        if(funs->logon==NULL)+            funs->logon     = (LPMAPILOGON)         GetProcAddress(funs->dll, (LPCSTR)209);++        funs->logoff    = (LPMAPILOGOFF)        GetProcAddress(funs->dll, "MAPILogOff");+        if(funs->logoff==NULL)+            funs->logoff    = (LPMAPILOGOFF)        GetProcAddress(funs->dll, (LPCSTR)210);++        funs->resolve   = (LPMAPIRESOLVENAME)   GetProcAddress(funs->dll, "MAPIResolveName");+        if(funs->resolve==NULL)+            funs->resolve   = (LPMAPIRESOLVENAME)   GetProcAddress(funs->dll, (LPCSTR)219);++        funs->free_buf  = (LPMAPIFREEBUFFER)    GetProcAddress(funs->dll, "MAPIFreeBuffer");+        if(funs->free_buf==NULL)+            funs->free_buf  = (LPMAPIFREEBUFFER)    GetProcAddress(funs->dll, (LPCSTR)16);+        if(funs->free_buf==NULL)+            funs->free_buf  = (LPMAPIFREEBUFFER)    GetProcAddress(funs->dll, "MAPIFreeBuffer@4");++        funs->sendmail  = (LPMAPISENDMAIL)      GetProcAddress(funs->dll, "MAPISendMail");+        if(funs->sendmail==NULL)+            funs->sendmail  = (LPMAPISENDMAIL)      GetProcAddress(funs->dll, (LPCSTR)211);+    }+    return +            funs->dll!=NULL+        &&  funs->logon!=NULL+        &&  funs->logoff!=NULL+        &&  funs->resolve!=NULL+        &&  funs->free_buf!=NULL+        &&  funs->sendmail!=NULL;+}+void free_dll(MapiFuns* funs) {+    if(funs->dll!=NULL) FreeLibrary(funs->dll);+    funs->dll=NULL;+}+
+ src/win32/send_email.h view
@@ -0,0 +1,9 @@++int send_email(const char *sendname, +               const char *recvname, +               const char *ccname, +               const char *subj,+               const char *body,+               const char *path);++
+ src/win32/sys/mman.h view
@@ -0,0 +1,7 @@++#include <sys/types.h>++void *mmap(void *start, size_t length, int prot, int flags, int fd, off_t offset);+int munmap(void *start, size_t length);++
+ src/witnesses.hs view
@@ -0,0 +1,21 @@+import Darcs.Patch.Real+import Darcs.Patch.Properties+import Darcs.Patch.Bundle+import Darcs.Patch+import Darcs.Repository.ApplyPatches+import Darcs.Patch.Match+import Darcs.Repository.HashedRepo+import Darcs.Resolution+import Darcs.Patch.Check+import Darcs.Repository.Pristine+import Darcs.Repository.DarcsRepo+import Darcs.Repository.Internal+import Darcs.Commands.Unrevert+import Darcs.Commands.WhatsNew+import Darcs.Commands.Show+import Darcs.Commands.Unrecord+import Darcs.Commands.Dist+import Darcs.Commands.TransferMode+import Darcs.Commands.GZCRCs++main = return ()
+ tests/EXAMPLE.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test for issueNNNN - <SYNOPSIS: WHAT IS THE BUG?  THIS SYNOPSIS+## SHOULD BE ONE OR TWO SENTENCES.>+##+## Copyright (C) YEAR  AUTHOR+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+darcs init      --repo S+mkdir R/d/ R/e/                 # Change the working tree.+echo 'Example content.' >R/d/f+darcs record    --repo R -lam 'Add d/f and e.'+darcs mv        --repo R d/f e/+darcs record    --repo R -am 'Move d/f to e/f.'+darcs push      --repo R S -a   # Try to push patches between repos.+darcs push      --repo S R+rm -rf R/ S/                    # Clean up after ourselves.
+ tests/add-formerly-pl.sh view
@@ -0,0 +1,63 @@+#!/usr/bin/env bash++# Some tests for 'darcs add'++. lib++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init++# Make sure that messages about directories call them directories+mkdir foo.d+mkdir oof.d+darcs add foo.d+darcs add oof.d+not darcs add foo.d 2> log+grep -i directory log+# Try adding the same directory when it's already in the repo+not darcs add foo.d oof.d 2> log+grep -i directories log++# Make sure that messages about files call them files+touch bar+touch baz+darcs add bar+darcs add baz+not darcs add bar 2> log+grep -i 'following file is' log+not darcs add bar baz 2> log+grep -i 'following files are' log++# Make sure that messages about both files and directories say so+not darcs add bar foo.d 2> log+grep -i 'files and directories' log++# Make sure that parent directories are added for files+mkdir -p a.d/aa.d/aaa.d+mkdir -p b.d/bb.d+touch a.d/aa.d/aaa.d/baz+touch a.d/aa.d/aaa.d/bar+darcs add a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log+test ! -s log # no output++# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs.+mkdir c.d+touch c.d/baz+darcs add c.d/baz c.d 2> log+test ! -s log # no output++# Make sure that add output looks good when adding files in subdir+mkdir d.d+touch d.d/foo+darcs add -rv d.d | grep 'd.d/foo'++# 'adding a non-existent dir and file gives the expected message+not darcs add notadir/notafile 2> log+grep -i 'does not exist' log++cd ..+rm -rf temp1
+ tests/add.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo bar+darcs add foo bar++for (( i=0 ; i < 5; i=i+1 )); do+  echo $i >> file-$i;+  darcs add file-$i+done++cd ..++rm -rf temp1+
+ tests/add_in_subdir.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+mkdir dir+echo zig > dir/foo+darcs add dir dir/foo+darcs record -a -m add_foo+# Create second repo inside the first+darcs init --repodir=temp2+cd  temp2+darcs pull -a ../../temp1+darcs changes -s | grep "A ./dir/foo"+# no differences+diff ../../temp1/dir/foo dir/foo+cd ..++rm -rf temp1
+ tests/addexitval.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++set -ev++rm -rf tmp+mkdir tmp+cd tmp+darcs init++empty='test ! -s'+nonempty='test -s'++rm -f foo+darcs add foo >stdout 2>stderr && exit 1 || true+$empty stdout+$nonempty stderr++>foo+darcs add foo >stdout 2>stderr+$empty stdout+$empty stderr++darcs add foo >stdout 2>stderr && exit 1 || true+$empty stdout+$nonempty stderr++rm foo+darcs add foo >stdout 2>stderr && exit 1 || true+$empty stdout+$nonempty stderr++cd ..+rm -rf tmp
+ tests/addmv.sh view
@@ -0,0 +1,20 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x+darcs mv foo zig+darcs mv bar foo+darcs mv zig bar+darcs record -a -m swap_foo_bar -A x+cd ../temp2+darcs init+darcs pull -v -a ../temp1+cd ..+rm -rf temp1 temp2+
+ tests/addrace.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+echo zig > foo+darcs add foo+#sleep 1+darcs record -a -m add_foo -A x+cd ../temp2+darcs init+darcs pull -a ../temp1+cd ..+cmp temp1/foo temp2/foo+rm -rf temp1 temp2+
+ tests/addrm.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+touch foo+darcs add foo+darcs record -a -m add_foo -A x+darcs remove foo+darcs record -a -m del_foo -A x+cd ../temp2+darcs init+darcs pull --all ../temp1+cd ..+rm -rf temp1 temp2+
+ tests/amend-cancelling.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+set -ev++# This checks for a possible bug in patch selection where the no available+# patches case is hit.++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch A+darcs add A+darcs record -am A+echo 'l1' >> A+darcs record -am l1+darcs amend-record -a --patch 'A'++cd ..+rm -rf temp1
+ tests/amend-record.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash++# Testing amend-record.++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# do some work here+cd temp1+# Plain amend-record+touch foo+darcs add foo+darcs record -a -m add_foo+echo 'another line' > foo+echo y | darcs amend -a foo | grep -i 'amending changes'+darcs changes -v | grep 'another line'+# amend-record of removed file+touch bar1+touch bar2+cat > bar1 << FOO+a line+b line+FOO+darcs add bar1 bar2+darcs record -a -m add_bars+rm -f bar2+echo y | darcs amend -a | grep -i 'finished amending'+# Special case: patch is empty after amend+cp foo foo.old+echo 'another line' >> foo+darcs record -a -m add_line foo | grep -i 'finished recording'+mv foo.old foo+echo y | darcs amend -a foo | grep -i 'amending changes'+# Amend --author, -m, etc+echo "another line" >> foo+echo y | darcs amend -a -m new_name foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_name+echo "another line" >> foo+echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_author+cd ..++rm -rf temp1
+ tests/annotate.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+mkdir a b+touch a/a b/b+darcs add --rec .+darcs record -a -m ab -A test+darcs annotate a/a+# annotate --xml should encode angle brackets in user name+touch c+darcs add c+darcs record -a -m foo -A 'Mark Stosberg <a@b.com>'+darcs annotate --xml c | grep "&lt;a\@b.com&gt;"+cd ..+rm -rf temp
+ tests/apply-hunks.sh view
@@ -0,0 +1,63 @@+#!/usr/bin/env bash+set -ev++rm -rf temp0 temp1 temp2++# step 1+mkdir temp0+cd temp0+darcs init --darcs-2+echo m1 > foo+darcs add foo+darcs record -a -m m1 -A moi --ignore-times+cd ..++# step 2+darcs get temp0 temp1+cd temp1+echo a1 > foo+darcs record foo -a -m a1 -A moi --ignore-times+cd ..+++# step 3+cd temp0+echo m2 > foo+darcs record -a -m m2 -A moi --ignore-times+cd ..+++# step 4+cd temp1+darcs pull -a+echo m2-a1 > foo+darcs record -a -m 'Fix conflict m2-a1' -A moi --ignore-times+cd ..++#step 5+cd temp0+echo m3 > foo+darcs record -a -m m3 -A moi --ignore-times+cd ..++#step 6+darcs get temp0 temp2+cd temp2+echo b1 > foo+darcs record -a -m b1 -A moi --ignore-times+cd ..++#step 7+cd temp0+echo m4 > foo+darcs record -a -m m4 -A moi --ignore-times+cd ..++#step 8+cd temp1+darcs pull -a+echo m2-a1-m4 > foo+echo y | darcs mark-conflicts+cd ..++rm -rf temp0 temp1 temp2
+ tests/ask_deps.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init+cat > _darcs/prefs/defaults <<.+ALL author test+ALL ignore-times+ALL ask-deps+.++# add three depending patches for file 'a'+# expect no dependency questions+# 'q' will abort and cause future failure if an unexpected dependency is asked+touch a+darcs add a+echo q | darcs rec -am a0+darcs ann -p a0+echo 1 > a+echo q | darcs rec -am a1+darcs ann -p a1+echo 2 > a+echo q | darcs rec -am a2+darcs ann -p a2++# add some patches for file 'b'+# expect no dependency questions for file 'b',+# but every time expect questions for the three patches of file 'a'+# every 'n' should continue to ask about the next patch+# the first 'y' should make all following dependencies of 'a' implicit and stop asking+# 'q' will abort and cause future failure if an unexpected dependency is asked+touch b+darcs add b+# test 0+echo n/n/n/q | tr / \\012 | darcs rec -am b0+darcs ann -p b0+# test 1+echo 1 > b+echo n/n/y/q | tr / \\012 | darcs rec -am b1+darcs ann -p b1 | grep '^\[a0'+# test 2+echo 2 > b+echo n/y/q | tr / \\012 | darcs rec -am b2+darcs ann -p b2 | grep '^\[a1'+# test 3+echo 3 > b+echo y/q | tr / \\012 | darcs rec -am b3+darcs ann -p b3 | grep '^\[a2'++cd ..+rm -rf temp+
+ tests/bad-format.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs initialize --old-fashioned+echo A > foo+darcs add foo+darcs record -a -m AA -A x+echo '<UGLY HTML-LIKE GARBAGE RETURNED BY BAD HTTP SERVER>' > _darcs/format+cd ..++# ensure that we successfully get repositories even if they have a bogus+# format file, as can happen if no _darcs/format is present (i.e. it's+# generated by an older darcs) and an http server fails to produce a 404+# error code.  This is issue757.++darcs get temp1 temp2++echo intentional-error >> temp2/_darcs/format++cat temp2/_darcs/format++rm -rf temp1++not darcs get temp2 temp1 2> err++cat err+grep intentional-error err+grep 'understand repository format' err++rm -rf temp1 temp2
+ tests/bad-match-pattern.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash++# This is a test for issue761, which pointed out that we didn't check the+# syntax of --match patterns until after having spent considerable time+# doing considerable work.  So here we construct a very invalid repository,+# and check that darcs fails *before* it notices that it's pulling from a+# bad repository.  Thus we verify that we aren't doing any work prior to+# checking the flags.++set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m 'add two files'+darcs tag -m tag+rm foo bar+darcs record -a -m 'rm two files'+darcs tag -m tag2++rm -rf _darcs/inventories/*+rm -rf _darcs/patches/*++cd ..++mkdir temp2+cd temp2+darcs init+! darcs pull --match 'foobar' ../temp1 2> error+cat error++grep foobar error++rm -rf temp1 temp2+
+ tests/bad_pending_after_pull.sh view
@@ -0,0 +1,51 @@+#!/usr/bin/env bash++set -ev++rm -fr temp1 temp2++mkdir temp1+cd temp1+darcs init++echo abc > A+darcs add A+echo def > B1+darcs add B1+# darcs record -all --patch-name patch1 # this way it doesn't trigger the bug+for i in 1 2 3 4 5 6 7 8 9 11; do echo y; done | darcs record --patch-name patch1++darcs mv B1 B2+darcs record --all --patch-name patch2+cd ..++mkdir temp2+cd temp2+darcs init+darcs pull --all ../temp1+darcs whatsnew | grep 'No changes'+cd ..++rm -fr temp1 temp2++# issue494: note that in this test, we deliberately select filenames+# with a backwards sorting order+mkdir temp1+cd temp1+darcs init+echo abc > b+darcs add b+darcs record --all -m patch1+darcs mv b a+echo def > a+darcs record --all -m patch2+cd ..++mkdir temp2+cd temp2+darcs init+darcs pull --all ../temp1+darcs whatsnew | grep 'No changes'+cd ..++rm -fr temp1 temp2
+ tests/binary.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+set -ve+binary=example_binary.png+function checkbinary(){+  cmp $binary ../temp1/$binary+}+rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+cp ../$binary .+darcs add $binary+darcs record -am P1+cd ../temp2+darcs init+test ! -e $binary+darcs pull ../temp1 -a+checkbinary+darcs obliterate -a+test ! -e $binary+darcs pull ../temp1 -a+checkbinary+darcs unrecord -a+checkbinary+darcs revert -a+test ! -e $binary+darcs unrevert -a+checkbinary+rm -rf temp1 temp2
+ tests/changes.sh view
@@ -0,0 +1,71 @@+#!/usr/bin/env bash+set -ev++# Some tests for 'darcs changes'++rm -rf temp1+mkdir temp1+cd temp1+darcs init++date >> date.t+darcs add date.t++darcs record -A 'Mark Stosberg <a@b.com>' -a -m foo date.t++####++darcs changes date.t > out # trivial case first+cat out+grep foo out++darcs changes --last=1 date.t > out+cat out+grep foo out++darcs changes --last 1 --summary date.t > out+cat out+grep foo out++darcs changes --last=1 --xml > out+cat out+grep '&lt;a@b.com&gt;' out # check that --xml encodes < and >++###++# Add 6 records and try again+for i in 0 1 2 3 4 5; do+    date >> date.t+    darcs record -a -m "foo record num $i" date.t+done++darcs changes date.t > out+cat out+grep foo out++darcs changes --last=1 date.t > out+cat out+grep foo out++darcs changes --last 1 --summary date.t > out+cat out+grep foo out++###++darcs changes --context --from-patch='num 1' --to-patch 'num 4' > out+cat out+grep 'num 4' out+grep 'num 3' out+grep 'num 2' out+grep 'num 1' out++###++date >> second_file.t+darcs add second_file.t++darcs record -a -m adding_second_file second_file.t++cd ..+rm -rf temp1
+ tests/changes_send_context.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++# RT#544 using context created with 8-bit chars;+rm -rf temp1++mkdir temp1++cd temp1+darcs init+touch foo+darcs record -la -m 'add\212 foo' | grep 'Finished record'+darcs changes --context >context+date > foo+darcs record -a -m 'date foo' | grep 'Finished record'+darcs send -a -o patch --context context . | grep 'Wrote patch to'+cd ..+rm -rf temp1
+ tests/changes_with_move.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash++# Some tests for the output of changes when combined with move.++. lib++rm -rf temp1++mkdir temp1+cd temp1+darcs init+date > foo+darcs add foo+darcs record -m 'add foo' -a+mkdir d+darcs add d+darcs record -m 'add d' -a+darcs mv foo d+darcs record -m 'mv foo to d' -a+darcs mv d directory+darcs record -m 'mv d to directory' -a+echo 'How beauteous mankind is' > directory/foo+darcs record -m 'modify directory/foo' -a+darcs changes directory/foo > log+grep 'add foo' log+grep 'mv foo to d' log+echo 'O brave new world' > directory/foo+# darcs should also take unrecorded moves into account+darcs mv directory/foo directory/bar+darcs changes directory/foo > log+grep 'mv foo to d' log+echo 'That has such people in it' > directory/foo+darcs add directory/foo+darcs record -m 'mv foo then add new foo' -a+darcs annotate directory/bar > log+grep 'How beauteous mankind is' log+grep 'O brave new world' log+cd ..++rm -rf temp1
+ tests/check.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash+## Ensure that "darcs check --test" succeeds when run in a complete+## repository with a dummy test that always succeeds.+##+## Copyright (C) 2008  David Roundy+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R+darcs setpref   --repo R test true+darcs record    --repo R -am 'true test'+touch R/f+darcs record    --repo R -lam 'added foo'+darcs check     --repo R --test+rm -rf R                        # Clean up after ourselves.
+ tests/checkpoint.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++# A test for unrecording checkpoint tags, inspired by issue517++set -ev++darcs --version++rm -rf temp temp1 temp2+mkdir temp++# This the last commands would blow up if the "--darcs-2" format wasn't used.+darcs init --darcs-2 --repodir temp+touch temp/x+darcs rec -lam xx --repodir temp+darcs tag -m yy --repodir temp+touch temp/z+darcs rec -lam zz --repodir temp+darcs optimize --checkpoint --repodir temp+darcs get --partial temp temp1+echo 'y' |  darcs unrec -p TAG --repodir temp1++# Now, the real tests. Do they return sensible results? +darcs get --partial temp1 temp2;+echo 'n' | darcs unrec --repodir temp1 -p 'zz'++rm -rf temp temp1 temp2;+darcs init --darcs-2 --repodir temp+touch temp/x+darcs rec -lam xx --repodir temp+darcs tag -m yy --repodir temp+touch temp/z+darcs rec -lam zz --repodir temp+darcs optimize --checkpoint --repodir temp+darcs get --partial temp temp1+echo 'y' |  darcs unrec -p TAG --repodir temp1++# Now, the real tests. Do they return sensible results? +darcs get --partial temp1 temp2;+echo 'n' | darcs unrec --repodir temp1 -p 'zz'++rm -rf temp temp1 temp2;
+ tests/conflict-doppleganger.sh view
@@ -0,0 +1,225 @@+#!/usr/bin/env bash++. lib++# Tests for the doppleganger conflict bug.++# For Zooko, with love+# Also, for issue81.++rm -rf temp+mkdir temp+cd temp++# check that dopplegangers conflict in --old-fashioned+rm -rf tmp_dopple tmp_ganger+mkdir tmp_dopple+cd tmp_dopple+darcs init --old-fashioned++darcs show repo | grep darcs-1.0+touch a.txt+darcs add a.txt+darcs record -A base -am 'adding a.txt'+cd ..++darcs get tmp_dopple tmp_ganger++for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    cd $repo+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+grep 'conflict' out++# check that dopplegangers conflict in --hashed+rm -rf tmp_dopple tmp_ganger+mkdir tmp_dopple+cd tmp_dopple+darcs init --hashed++darcs show repo | grep hashed+touch a.txt+darcs add a.txt+darcs record -A base -am 'adding a.txt'+cd ..++darcs get tmp_dopple tmp_ganger++for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    cd $repo+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+grep 'conflict' out+cd ..++# check that dopplegangers do not conflict in --darcs-2+rm -rf tmp_dopple tmp_ganger+mkdir tmp_dopple+cd tmp_dopple+darcs init --darcs-2++darcs show repo | grep darcs-2+touch a.txt+darcs add a.txt+darcs record -A base -am 'adding a.txt'+cd ..++darcs get tmp_dopple tmp_ganger++for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    cd $repo+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+not grep 'conflict' out+cd ..++# Checking that resolution dopplegangers conflict in --old-fashioned-inventory+rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger+mkdir temp0+cd temp0+darcs init --old-fashioned-inventory+darcs show repo | grep darcs-1.0+cd ..++# Create a conflict+darcs get --old-fashioned-inventory temp0 temp1+cd temp1+darcs show repo+darcs show repo | grep darcs-1.0+echo temp1 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp1 a.txt'+cd ..+darcs get temp0 temp2+cd temp2+echo temp2 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp2 a.txt'+cd ..++# Resolve the conflict the same way on both sides+for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    darcs get temp1 $repo+    cd $repo+    darcs pull -a ../temp2+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+grep conflict out+cd ..++# Checking that resolution dopplegangers conflict in --hashed+rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger+mkdir temp0+cd temp0+darcs init --hashed+darcs show repo | grep hashed+cd ..++# Create a conflict+darcs get temp0 temp1+cd temp1+echo temp1 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp1 a.txt'+cd ..+darcs get temp0 temp2+cd temp2+echo temp2 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp2 a.txt'+cd ..++# Resolve the conflict the same way on both sides+for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    darcs get temp1 $repo+    cd $repo+    darcs pull -a ../temp2+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+grep conflict out+cd ..+++# Checking that resolution dopplegangers do not conflict in --darcs-2+rm -rf temp0 temp1 temp2 tmp_dopple tmp_ganger+mkdir temp0+cd temp0+darcs init --darcs-2+darcs show repo | grep darcs-2+cd ..++# Create a conflict+darcs get temp0 temp1+cd temp1+darcs show repo | grep darcs-2+echo temp1 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp1 a.txt'+cd ..+darcs get temp0 temp2+cd temp2+echo temp2 > a.txt+darcs add a.txt+darcs record  -A base -am 'adding temp2 a.txt'+cd ..++# Resolve the conflict the same way on both sides+for repo in tmp_dopple tmp_ganger; do+    echo working on $repo+    darcs get temp1 $repo+    cd $repo+    darcs pull -a ../temp2+    echo "text which appears in both places at once" > a.txt+    darcs record -A $repo -am "recording an identical change in $repo"+    cd ..+done++# Now that the conflict has been set up, try pull one patch from the other.+cd tmp_ganger+darcs pull -a ../tmp_dopple > out+cat out+not grep conflict out+cd ..++cd ..+rm -rf temp
+ tests/conflict-fight-failure.sh view
@@ -0,0 +1,54 @@+#!/bin/env bash+#+# Test darcs conflict fight scenario.+#+# Set up two repos RA and RB. Create conflict in RB. +# After resolving conflict in RB, pull new patch from RA.+# Repeat, rinse.+#+# Author: Pekka Pessi+#++set -ev++record="record --ignore-time --all --author X"++rm -rf RA RB+mkdir RA++cd RA+echo 0 > file+darcs init+darcs add file+darcs $record -m0 file+cd ..++darcs get RA RB++# Create conflict in RB+cd RB+echo let it b > file+darcs $record -m B+cd ..++for i in 1 2 3 4 5 # 6 7 8 9 10 11 12+do+  echo Create new patch A$i in RA+  cd RA+  echo a$i > file+  darcs $record -m A$i+  cd ..++  echo Pull patch A$i from RA and get a conflict+  cd RB+  time darcs pull ../RA --verbose --all --patch "^A$i\$"+  cd ..++  echo Resolve conflict and start fighting by recording B$i+  cd RB+  echo let it b > file+  darcs $record -m B$i+  cd ..+done++rm -rf RA RB
+ tests/conflict-fight.sh view
@@ -0,0 +1,78 @@+#!/usr/bin/env bash++set -ev++rm -rf temp0 temp1 temp2++# step 1+mkdir temp0+cd temp0+darcs init --darcs-2+echo temp0 > _darcs/prefs/author+echo m1 > foo+darcs add foo+darcs record -a -m m1 --ignore-times+cd ..++# step 2+darcs get temp0 temp1+cd temp1+echo temp1 > _darcs/prefs/author+echo a1 > foo+darcs record foo -a -m a1 --ignore-times+cd ..+++# step 3+cd temp0+echo m2 > foo+darcs record -a -m m2 --ignore-times+cd ..+++# step 4+cd temp1+darcs pull -a+echo m2-a1 > foo+darcs record -a -m 'Fix conflict m2-a1' --ignore-times+echo a2 > foo+darcs record -a -m a2 --ignore-times+cd ..++#step 5+cd temp0+echo m3 > foo+darcs record -a -m m3 --ignore-times+cd ..++#step 6+darcs get temp0 temp2+cd temp2+echo temp2 > _darcs/prefs/author+echo b1 > foo+darcs record -a -m b1 --ignore-times++cd ..++#step 7+cd temp0+echo m4 > foo+darcs record -a -m m4 --ignore-times+cd ..++#step 8+cd temp1+darcs pull -a+echo m2-a1-m4 > foo+darcs record -a -m 'Fix three-way m2/m2-a1/m4' --ignore-times+echo a3 > foo+darcs record -a -m a3 --ignore-times+cd ..++#step 9+cd temp1+darcs pull -av ../temp2+cd ..++rm -rf temp0 temp1 temp2+
+ tests/diff.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++rm -rf temp-$$+mkdir temp-$$+cd temp-$$+set -e+darcs initialize+echo text > afile.txt+darcs add afile.txt+darcs record --author me --all --no-test --patch-name init+darcs diff+darcs diff -p . --store > diffinmem+darcs diff -p . > diffondisk+diff diffinmem diffondisk+cd ..++rm -rf temp-$$
+ tests/directory_confusion.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash+set -ev++T=temp+rm -rf "$T"+mkdir "$T"+echo "$T"+cd "$T"+set -e+darcs initialize+echo text > afile.txt+darcs add afile.txt+darcs record --author me --all --no-test --patch-name init+mkdir d+darcs add d+mkdir d/e+darcs add d/e+darcs mv afile.txt d/e/afile.txt+echo altered_text > d/e/afile.txt+darcs record --author me --all --no-test --patch-name confusion+test ! -f _darcs/pristine/afile.txt+echo y/d/y | tr / \\012 | darcs unrecord+rm -rf "$T"
+ tests/disable.sh view
@@ -0,0 +1,20 @@+#!/usr/bin/env bash+. lib++# Some tests for 'darcs whatsnew '++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch look_summary.txt+# --disable works on command line+not darcs whatsnew -sl --disable 2> log+grep -i disable log+# --disable works from defaults+echo 'whatsnew --disable' > _darcs/prefs/defaults+not darcs whatsnew -sl 2> log+grep -i disable log+cd ..++rm -rf temp1
+ tests/dist.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo+darcs record -a -m add_foo | grep -i "finished recording"+darcs dist+cd ..++rm -rf temp1
+ tests/double-unrevert.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+set -ev++# This demonstrates a bug that happens if you revert followed by+# a partial unrevert and a full unrevert.  It requires that+# the second unrevert is working with patches who's contents need+# to be modified by the commute in the first unrevert.++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo line1 >> A+echo line2 >> A+echo line3 >> A+echo line4 >> A+echo line5 >> A+echo line6 >> A+darcs add A+darcs record -am A+sed 's/line2/Line2/' A  > A1; rm A; mv A1 A+sed '4d' A > A1; rm A; mv A1 A+sed 's/line6/Line6/' A > A1; rm A; mv A1 A+darcs revert -a+echo nyn | darcs unrev+darcs unrev -a++cd ..+rm -rf temp1
+ tests/example_binary.png view

binary file changed (absent → 6742 bytes)

+ tests/external.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash++# Some tests for launching external commands++. lib++rm -rf temp1++touch_fakessh='./touch-fakessh'+if echo $OS | grep -i windows; then+  touch_fakessh="touch_fakessh.bat"+fi+export DARCS_SSH=$touch_fakessh+export DARCS_SCP=$touch_fakessh+export DARCS_SFTP=$touch_fakessh+rm -rf 'fakessh'+rm -rf 'touch-fakessh'++# make our ssh command one word only+echo 'echo hello > fakessh' > $touch_fakessh+chmod u+x $touch_fakessh+# first test the DARCS_SSH environment variable+not darcs get example.com:foo+grep hello fakessh+rm -f fakessh++# now make sure that we don't launch ssh for nothing+mkdir temp1+cd temp1+darcs init+cd ..+darcs get temp1 > log+not grep fakessh log+not darcs get http://example.com/foo+not grep fakessh log+cd ..+rm -rf temp1
+ tests/filepath.sh view
@@ -0,0 +1,114 @@+#!/usr/bin/env bash++# Some tests for proper handling of filepaths++. lib++DIR=`pwd`++rm -rf temp1 temp2++# Make sure that init works with --repodir+darcs init --repodir=temp1+test -d temp1/_darcs++# add some meat to that repository+cd temp1+touch baz+darcs add baz+darcs record -m moo -a+cd ..++# ----------------------------------------------------------------------+# local vs remote filepaths+# ----------------------------------------------------------------------++# trick: OS-detection (if needed)+if echo $OS | grep -i windows; then+  echo This test does not work on Windows+else+  darcs get temp1 temp2+  cd temp2+  mkdir -p dir+  darcs add dir+  cd dir+  touch foo:bar+  darcs add --reserved-ok foo:bar+  cd ../..+  rm -rf temp2+fi++# ----------------------------------------------------------------------+# repodir stuff+# ----------------------------------------------------------------------+mkdir -p temp1/non-darcs+# FIXME: This test does not seem to make much sense+# --repodir is not recursive+not darcs get temp1/non-darcs 2> log+grep "Not a repository" log+rm -rf temp1/non-darcs+rm -rf non-darcs++# get accepts --repodir.+darcs get --repodir=temp2 temp1 | grep -i "Finished getting"+test -d temp2/_darcs+rm -rf temp2+# get accepts absolute --repodir.+darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished getting"+test -d temp2/_darcs++# changes accepts --repodir.+darcs changes --repodir=temp1 | grep -i "moo"+# changes accepts absolute --repo.+darcs changes --repo="${DIR}/temp1" | grep -i "moo"+# changes accepts relative --repo.+darcs changes --repo=temp1 | grep -i "moo"+# [issue467] context --repodir+darcs changes --context --repodir=temp1 | grep 'Context:'++# dist accepts --repodir.+darcs dist --repodir=temp1 | grep -i "Created dist"++# optimize accepts --repodir.+darcs optimize --reorder-patches --repodir=temp1 | grep -i "done optimizing"++# repair accepts --repodir.+darcs repair --repodir=temp1 | grep -i "already consistent"++# replace accepts --repodir.+darcs replace --repodir=temp1 foo bar++# setpref accepts --repodir.+darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test"++# trackdown accepts --repodir.+darcs trackdown --repodir=temp1 | grep -i "Success!"++# ----------------------------------------------------------------------+# converting between absolute and relative paths+# ----------------------------------------------------------------------++rm -rf temp3+darcs get temp1 temp3+cd temp3+mkdir -p a/b+cd ..++cd temp2+echo hello 1 >> baz+darcs record -m hello1 -a+echo hello 2 >> baz+darcs record -m hello2 -a+cd ..++# can handle .. path+cd temp3+darcs pull ../temp2 -p1 --all | grep -i 'Finished pulling'+darcs pull --dry-run | grep hello2+cd a/b+#[issue268] repodir with subdir+darcs pull --dry-run | grep hello2+cd ..+cd ..++rm -rf log temp1 temp2 temp3
+ tests/get.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch t.t+darcs add t.t+darcs record -am "initial add"+darcs changes --context > my_context+DIR=`pwd`+abs_to_context="${DIR}/my_context"+cd ..+rm -rf temp2+darcs get temp1 --context="${abs_to_context}" temp2+rm -rf temp1 temp2
+ tests/get_tag.sh view
@@ -0,0 +1,87 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs initialize+echo ALL ignore-times >> _darcs/prefs/defaults+echo A > foo+darcs add foo+darcs record -a -m AA -A x+echo B > foo+darcs record -a -m BB -A x+echo C > foo+darcs record -a -m CC -A x+darcs tag -m 1.0 -A x+cp foo foo_version_1.0+echo D > foo+darcs record -a -m DD -A x+echo E > foo+darcs record -a -m EE -A x+echo F > foo+darcs record -a -m FF -A x+++# Check that get store commuted patches+cd ..+darcs get --tag 1.0 --repo-name temp2 temp1+cmp temp2/foo temp1/foo_version_1.0+rm -rf temp1 temp2 temp3++mkdir temp1+cd temp1+darcs init+cat > file <<EOF+1+2+3+4+EOF+darcs rec -Ax -alm 'Add file'+cat > file <<EOF+2+3+4+EOF+darcs rec -Ax -alm 'Remove line 1'+cat > file <<EOF+2+4+EOF+darcs rec -Ax -alm 'Remove line 3'+cd ..+mkdir temp2+cd temp2+darcs init+echo y/n/y | tr / \\012 | darcs pull ../temp1+darcs tag -Ax -m Tag+darcs push -a ../temp1+cd ..+darcs get --tag=Tag temp1 temp3+cd temp3+darcs check+cd ..+rm -rf temp1 temp2 temp3++# Check that pending looks ok+mkdir temp1+cd temp1+darcs init+mkdir d+darcs add d+darcs rec -Ax -am 'add d'+darcs tag -Ax t+rmdir d+darcs rec -Ax -am 'rm d'+cd ..+darcs get --tag t temp1 temp2+cd temp2+if [ -f _darcs/patches/pending ]; then+	if grep -v '^[{}]$' _darcs/patches/pending >/dev/null; then+		cat _darcs/patches/pending+		exit 1+	fi+fi+cd ..+rm -rf temp1 temp2
+ tests/gzcrcs.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash+## Test for gzcrcs command - check and repair corrupted CRCs on+## compressed files+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++# need to do this before loading lib as that sets -e+darcs gzcrcs --help > /dev/null+if [ $? == 2 ] ; then echo gzcrcs not supported by this darcs ; exit 0 ; fi++. ../tests/lib                  # Load some portability helpers.+rm -rf maybench-crc+gunzip -c repos/maybench-crc.tgz | tar xf -+cd maybench-crc+not darcs gzcrcs --check+darcs gzcrcs --repair+darcs gzcrcs --check+cd ..+rm -rf maybench-crc
+ tests/harness.sh view
@@ -0,0 +1,16 @@+#!/usr/bin/env bash++set -ev++# Print some stuff out for debugging if something goes wrong:+echo $HOME+echo $PATH+which darcs+command -v darcs++# Check things that should be true when all the testscripts run++test -f "$HOME"/harness.sh || { echo "HOME=\"$HOME\" is not the test suite directory"; exit 1; }++homedirname=`dirname "$HOME"`+command -v darcs | grep "$homedirname"
+ tests/hashed_inventory.sh view
@@ -0,0 +1,194 @@+#!/usr/bin/env bash++set -ev++# We'd just use `diff -x _darcs -r' if -x was portable.+diffx () {+    { find $1 -type f; find $2 -type f; } |+      sed  -e '/.*\/_darcs\//d' -e 's;^[^/]*;;' | grep -v darcs.tix | sort | uniq |+      {+	while read part; do+	    diff -c $1$part $2$part+	done+      }+}++makepristine () {+    rm -rf pristine+    mkdir pristine+    for i in `darcs show files --no-files --no-pending`; do+        echo mkdir -p pristine/$i;+        mkdir -p pristine/$i;+    done+    for i in `darcs show files --no-directories --no-pending`; do+        echo darcs show contents $i ">" pristine/$i;+        darcs show contents $i > pristine/$i;+        cat pristine/$i;+    done+}++++rm -rf temp1 temp2 temp3 temp4 temp5+mkdir temp1+cd temp1+darcs init --hashed+touch foo+darcs add foo+darcs rec -m t1 -a -A tester+echo 1 >> foo+darcs what -s | grep -v No\ changes+darcs what -l | grep -v No\ changes+darcs what -sl | grep -v No\ changes+makepristine+cd ..++darcs get temp1 temp2+cd temp2+darcs changes+makepristine+cd ..++darcs get --hashed temp1 temp3+cd temp3+darcs changes+cp _darcs/hashed_inventory inv+darcs optimize+diff -c inv _darcs/hashed_inventory+rm inv+makepristine+cd ..+cat temp3/pristine/foo++diffx temp2 temp3+diff -rc temp1/pristine temp3/pristine+diff -rc temp2/pristine temp3/pristine++cd temp1+darcs record -a -A tester -m t2+darcs push ../temp2 -a+darcs push ../temp3 -a+makepristine+cd ..++cd temp3+makepristine+cd ..+cd temp2+makepristine+cd ..++diffx temp2 temp3+diff -rc temp1/pristine temp3/pristine+diff -rc temp2/pristine temp3/pristine++cd temp1+date > foo+darcs record -a -A tester -m t3+makepristine+cd ../temp2+darcs pull -a+makepristine+cd ../temp3+darcs pull -a+darcs check+makepristine+cd ..++diffx temp2 temp3+diff -rc temp1/pristine temp3/pristine+diff -rc temp2/pristine temp3/pristine++cd temp1+darcs put --hashed ../temp4+cd ..+cd temp4+makepristine+cd ..++diffx temp2 temp4+diff -rc temp2/pristine temp4/pristine++cd temp1+darcs tag -A tagger -m atag+darcs check+darcs optimize+darcs check+darcs changes | grep t1+cd ..++cd temp3+date > foobarpatch+darcs add foobarpatch+darcs record -a -A silly -m foobarpatch+darcs check+darcs optimize+darcs check+darcs pull -a ../temp1+darcs check+darcs optimize --reorder-patches+darcs check+grep 'Starting with inventory' _darcs/hashed_inventory+cd ..++cd temp1+darcs pull -a ../temp3+cd ..++diff -c temp1/_darcs/hashed_inventory temp3/_darcs/hashed_inventory++cd temp4+darcs pull -p foobarpatch -a ../temp3+darcs pull -a ../temp1+darcs optimize --reorder+darcs check+darcs push ../temp1+cd ..++diff temp1/_darcs/hashed_inventory temp4/_darcs/hashed_inventory++rm -rf temp3+darcs get --old-fashioned temp1 temp3++rm -rf "$HOME"/.darcs/sources+echo cache:"$HOME"/.darcs/cache > "$HOME"/.darcs/sources+darcs get --hashed temp3 temp5+rm -rf temp5+# check that sources directory was created:+cd "$HOME"/.darcs/sources && cd -++darcs get temp1 temp5 --hashed --old-fashioned+cd temp5+darcs obliterate --last 3 -a+darcs pull ../temp1 -a+darcs obliterate --last 3 -a+darcs pull ../temp2 -a+darcs check+darcs obliterate --last 3 -a+darcs pull ../temp3 -a+darcs obliterate --last 3 -a+darcs pull ../temp4 -a+cd ..++cd temp4+darcs obliterate --last 3 -a+darcs pull ../temp5 -a+cd ..++cd temp3+darcs obliterate --last 3 -a+darcs pull ../temp5 -a+cd ..++cd temp2+darcs obliterate --last 3 -a+darcs pull ../temp5 -a+cd ..++cd temp1+darcs obliterate --last 3 -a+darcs pull ../temp5 -a+cd ..++rm -rf temp1 temp2 temp3 temp4 temp5+
+ tests/haskell_policy.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash++RESULT=tmpfile+ROOT=..+ERRORSTATUS=0++# lookfor ( $1=what, $2=reason, $3=source module exception )+lookfor () {+    rm -f "$RESULT"+    darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do+        grep -Hnwe "$1" "$ROOT/$f" | grep -v "$3\.$1" | \+        grep -v ":[0-9]\+:import " | grep -Fv "ratify $1: " >> "$RESULT"+    done+    if [ -s "$RESULT" ]; then+        echo "Found the following unratified uses of $1:"+        # ugly sed expresion to fix relative paths; think pretty cat+        sed -e 's/[^:]*\/\.\///' "$RESULT"+        echo "$2"+        echo "Comment 'ratify $1: <why>' on the same line to allow it"+        echo+        ERRORSTATUS=1+    fi+    rm -f "$RESULT"+}++# On 2009-02-12 Petr Rockai explained this on darcs-users:+# The problem with Prelude readFile is that it's based on hGetContents, which+# is lazy by definition. This also means that unless you force consumption of+# the produced list, it will keep an fd open for the file, possibly+# indefinitely.  This is called a fd leak. Other than being annoying and if done+# often, leading to fd exhaustion and failure to open any new files (which is+# usually fatal), it also prevents the file to be unlinked (deleted) on win32.+#+# On the other hand, *strict* bytestring version of readFile will read the whole+# file into a contiguous buffer, *close the fd* and return. This is perfectly+# safe with regards to fd leaks. Btw., this is *not* the case with lazy+# bytestring variant of readFile, so that one is unsafe.+lookfor readFile \+        "Prelude.readFile doesn't ensure the file is closed before it is deleted!\nConsider import Data.ByteString.Char8 as B (readFile), B.readFile instead." \+        B # importing readFile from Data.ByteString as B, is allowed++lookfor hGetContents \+        "hGetContents doesn't ensure the file is closed before it is deleted!"++# look for tabs in haskell source+rm -f "$RESULT"+darcs query manifest --repodir="$ROOT" | grep '\.l\?hs$' | while read f; do+    grep -FHnwe "	" "$ROOT/$f" >> "$RESULT"+done+if [ -s "$RESULT" ]; then+    echo "Found the following lines with unwanted tabs:"+    # ugly sed expresion to fix relative paths; think pretty cat+    sed -e 's/[^:]*\/\.\///' "$RESULT"+    echo+    ERRORSTATUS=1+fi+rm -f "$RESULT"++exit "$ERRORSTATUS"
+ tests/hidden_conflict.sh view
@@ -0,0 +1,32 @@+#!/bin/sh++set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init --darcs-2+echo first > a+darcs add a+darcs record -am 'first'+cd ..+darcs get temp1 temp2++cd temp1+echo second > a+darcs record -am 'first to second'+echo first > a+darcs record -am 'second back to first'+cd ..++cd temp2+echo third > a+darcs record -am 'first to third'+cd ..++cd temp1+darcs pull -a ../temp2 | grep conflict+grep third a+cd ..++rm -rf temp1 temp2
+ tests/hidden_conflict2.sh view
@@ -0,0 +1,70 @@+#!/usr/bin/env bash+set -ev++# A test for a missed resolution, inspired by bug #10 in RT++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+cd ..+mkdir temp2+cd temp2+darcs init+cd ..++# set up temp1+cd temp1+cat > A << FOO+i++m+b+v+FOO+darcs add A+darcs record -m 'add' --all+cd ..++# set up temp2+cd temp2+darcs pull --all ../temp1+cat > A << FOO+J+i++C2++m+D+b+v+FOO+darcs record  -m 'change2' --all+cd ..++# generate a conflict+cd temp1+cat > A << FOO+I+i++C1++m+b++FOO+darcs record -m 'change1' --all+darcs pull --all ../temp2+# we should have a marked conflict now.+grep 'v v' A+# we resolve it simply by removing conflict markers.+sed -e '/\^ \^|\*\*|v v/d' A > temp+mv temp A+darcs record -m resolution --all+# now mark-conflicts shouldn't find any unmarked conflicts+darcs mark-conflicts | grep "No conflicts to mark"+cd ..++rm -rf temp1 temp2
+ tests/ignore-this.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash++. lib+++rm -rf temp1+mkdir temp1+cd temp1+darcs init++touch foo+darcs add foo++cat > log <<EOF+add file foo+Ignore-this: My private secret.+EOF++echo n | not darcs record -a --logfile log > out+cat out+grep Proceed out++darcs whatsnew++echo y | darcs record -a --logfile log++not darcs whatsnew++darcs changes > out+cat out+not grep 'My private secret' out++darcs changes --xml > out+cat out+grep 'My private secret' out++cd ..+rm -rf temp1
+ tests/ignoretimes.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash++set -ev++rm -rf temp1++mkdir temp1+cd temp1+darcs init+echo -e 'foo\nbar\nbaz' > f+darcs rec -Ax -alm p1+echo -e 'foo\nbar\nwibble' > f+darcs rec -Ax -alm p2+sleep 1 # ensure the timestamps would differ after this change alone+echo -e 'baz\nbar\nwibble' > f++# check that wh (without --ignore-times) sees the change now+darcs wh > whatsnew+grep 'foo' whatsnew++# the problematic unpull+darcs unpull --last 1 -a --ignore-times++# whatsnew will now think there are no changes without --ignore-times+darcs wh > whatsnew+grep 'foo' whatsnew++cd ..+rm -rf temp1
+ tests/illegal_mv.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs initialize+echo text > afile.txt+darcs add afile.txt+darcs record --author me --all --no-test --patch-name init+mkdir d+echo The following mv should fail, since d isnt in the repo.+if darcs mv afile.txt d/afile.txt; then+false+fi++# Now clean up.+cd ..+rm -rf temp+
+ tests/impossible_unrevert.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+echo ALL ignore-times > _darcs/prefs/defaults+echo a > foo+darcs add foo+darcs record -a -m aa -A test+echo b > foo+echo y | darcs revert -a+echo y/d/y | tr / \\012 | darcs unrecord+# since the unrevert is impossible, we should fail if it succeeds...+echo y | darcs unrevert && exit 1 || true++# now let's try a possible unrevert, just for fun...+echo b >> foo+darcs record -a -m bb -A test+echo f/b | tr / \\012 > foo+darcs record -a -m 'aaa becomes f' -A test+date >> foo+echo y | darcs revert -a+echo y/d/y | tr / \\012 | darcs unpull+# Now add the date back on at the end:+echo y | darcs unrevert+echo 'M ./foo +1' > correct_summary+darcs whatsnew --dont-look-for-adds --summary > actual_summary+diff -c correct_summary actual_summary++cd ..+rm -rf temp
+ tests/init.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2++mkdir temp1+cd temp1+darcs init+test -d _darcs+not darcs init+cd ..++# Some tests for the repodir flag+mkdir temp2+darcs init --repodir temp2+test -d temp2/_darcs++rm -rf temp1 temp2
+ tests/invalid_pending_after_mv_to_self.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash++# A regression test for issue567++set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+mkdir dir+touch dir/t.t+darcs add dir+darcs add dir/t.t+darcs record -am 'initial add'++# grand finale? Can we move the file to itself? +darcs mv dir/t.t dir/++cd ..++rm -rf temp
+ tests/issue1012_unrecord_remove.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev+rm -rf temp1+mkdir temp1+cd temp1+darcs --version+darcs init+echo temp1 >File.hs+darcs add File.hs+darcs record File.hs -a -m "add File"+rm File.hs+darcs record -a -m "rm File"+darcs cha+darcs unrecord -p "rm File" -a+darcs cha+darcs record -a -m "re-rm File"+cd ..+rm -rf temp1
+ tests/issue1017_whatsnew_stack.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+printf "File contents" > foo+darcs add foo+darcs record -a -m 'foo' foo+for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16; do cat foo foo > foo2; mv foo2 foo; done+darcs what+cd ..
+ tests/issue1039.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+++. lib++# pull from not empty repo to empty repo+rm -rf temp1 temp2+mkdir temp1 temp2++cd temp1+darcs init+echo a > a+darcs add a+darcs record --all --patch-name=a+cd ../temp2+darcs init+darcs pull --all --dont-allow-conflicts ../temp1+test `darcs changes --count` = "1"+cd ..++# push from not empty repo to empty repo+rm -rf temp1 temp2+mkdir temp1 temp2++cd temp1+darcs init+cd ../temp2+darcs init+echo a > a+darcs add a+darcs record --all --patch-name=a+darcs push --all ../temp1+cd ../temp1+test `darcs changes --count` = "1"+cd ..++# send from not empty repo to not empty repo+rm -rf temp1 temp2+mkdir temp1 temp2++cd temp1+darcs init+echo a > a+darcs add a+darcs record --all --patch-name=a++for i in 1 2 3 4 5 6 7 8 9; do+    echo Change number $i >> a+    darcs record -a -m "change a $i"+done++cd ../temp2+darcs init+echo b > b+darcs add b+darcs record --all --patch-name=b++for i in 1 2 3 4 5 6 7 8 9; do+    echo Change number $i >> b+    darcs record -a -m "change b $i"+done++echo no | darcs send --all --to=random@random --sendmail-command=false ../temp1+echo yes | not darcs send --all --to=random@random --sendmail-command=false ../temp1+not darcs send --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1+cd ..++rm -rf temp1 temp2
+ tests/issue1041.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2++# this should fail, since temp1 doesn't exist...+not darcs get temp1 temp2++# verify that temp2 wasn't created+not cd temp2++rm -rf temp1 temp2
+ tests/issue1043_geteff_a.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash++set -ev+rm -rf temp1 temp2++# creating the fork point+mkdir temp1+cd temp1+darcs init+cat > foo << FOO+original - apple+original - banana+FOO+darcs add foo+darcs record -am init+cd ..+darcs get temp1 temp2++# do some work in the mainline+cd temp1+cat > foo << FOO+conflict 1 - artichoke+original - banana+FOO+darcs record -am 'conflict 1a'+cat > foo << FOO+conflict 1 - artichoke+conflict 1 - brocolli+FOO+darcs record -am 'conflict 1b'+cd ..++# do some work in the branch+cd temp2+cat > foo << FOO+conflict 2 - aardvark+original - banana+conflict 2 - cougar+FOO+darcs record -am 'conflict 2'+cd ..++# in the branch, pull from the mainline and resolve the conflict+cd temp2+darcs pull -a ../temp1 --allow-conflicts+cat > foo << FOO+resolution+original - apple+original - banana+FOO+darcs record -am 'resolve conflicts 2,1a,1b'+cd ..++# do some extra work in the mainline+cd temp1+cat > foo << FOO+original - apple+FOO+darcs record -am 'conflict 1c'+cd ..++# in the branch, pull from the mainline again+cd temp2+darcs pull -a ../temp1 --allow-conflicts+cd ..++rm -rf temp1 temp2
+ tests/issue1043_geteff_b.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash++set -ev+rm -rf temp1 temp2++# creating the fork point+mkdir temp1+cd temp1+darcs init+cat > foo << FOO+original - apple+original - banana+FOO+darcs add foo+darcs record -am init+cd ..+darcs get temp1 temp2++# do some work in the mainline+cd temp1+cat > foo << FOO+original - apple+conflict 1 - brocolli+FOO+darcs record -am 'conflict 1b'+cat > foo << FOO+conflict 1 - artichoke+original - banana+FOO+darcs record -am 'conflict 1a'+cd ..++# do some work in the branch+cd temp2+cat > foo << FOO+conflict 2 - aardvark+original - banana+conflict 2 - cougar+FOO+darcs record -am 'conflict 2'+cd ..++# in the branch, pull from the mainline and resolve the conflict+cd temp2+darcs pull -a ../temp1 --allow-conflicts+cat > foo << FOO+resolution+original - apple+original - banana+FOO+darcs record -am 'resolve conflicts 2,1a,1b'+cd ..++# do some extra work in the mainline+cd temp1+cat > foo << FOO+original - apple+FOO+darcs record -am 'conflict 1c'+cd ..++# in the branch, pull from the mainline again+cd temp2+darcs pull -a ../temp1 --allow-conflicts+cd ..++rm -rf temp1 temp2
+ tests/issue1057.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash+## Test for issue1057 - when pulling from a symlink to the current+## repository, Darcs should detect that it *is* the current repo.+##+## Copyright (C) 2008  Thorkil Naur+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf temp+mkdir temp+cd temp++mkdir repo+cd repo+darcs init+cd ..++ln -s repo srepo+cd srepo+DIR=`pwd`+echo $DIR+not darcs pull --debug -a "$DIR" 2> out+cat out+grep 'Can.t pull from current repository' out+cd ..++cd ..+rm -rf temp
+ tests/issue1078_symlink.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash++. lib++if echo $OS | grep -i windows; then+    echo this test does not work on windows because+    echo windows does not have symlinks+    exit 0+fi++rm -rf temp1 temp2+mkdir temp1+ln -s temp1 temp2+cd temp2+darcs init+touch a b+DIR=`pwd`+darcs add "${DIR}/../temp1/a" # should work, just to contrast with the case below+darcs add "${DIR}/b"          # this is the case we are testing for+cd ..+rm -rf temp1 temp2
+ tests/issue1101.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+set -ev++DARCS_EDITOR=echo+export DARCS_EDITOR+export SENDMAIL=`which true`++rm -rf temp1 temp2+mkdir temp1 temp2++cd temp2+darcs init++# setup test+cd ../temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x++# Test that --cc is also printed as recipient in case of success+darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com++# Test that --cc is also printed as recipient in case of error+darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com++cd ..+rm -rf temp1 temp2
+ tests/issue1105.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash++. lib++rm -rf temp+mkdir temp+cd temp+darcs init+darcs changes++echo changes summary > _darcs/prefs/defaults+darcs changes+echo changes summary arg > _darcs/prefs/defaults+not darcs changes+echo ALL summary > _darcs/prefs/defaults+darcs changes+echo ALL summary arg > _darcs/prefs/defaults+not darcs changes++echo changes last 10 > _darcs/prefs/defaults+darcs changes+echo changes last > _darcs/prefs/defaults+not darcs changes+echo ALL last 10 > _darcs/prefs/defaults+darcs changes+echo ALL last > _darcs/prefs/defaults+not darcs changes++echo changes author me > _darcs/prefs/defaults+not darcs changes+echo ALL author me > _darcs/prefs/defaults+darcs changes+echo ALL unknown > _darcs/prefs/defaults+not darcs changes++cd ..+rm -rf temp
+ tests/issue1110_get_hashed.sh view
@@ -0,0 +1,10 @@+#!/usr/bin/env bash+set -ev+rm -rf temp1 temp1-h+mkdir temp1+cd temp1+darcs init --old-fashioned-inventory+cd ..+darcs get --hashed temp1 temp1-h+test -e temp1-h/_darcs/hashed_inventory+rm -rf temp1 temp1-h
+ tests/issue1110_get_old-fashioned.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+set -ev++rm -rf temp0 temp1+# sanity check+mkdir temp0+cd temp0+darcs init --old-fashioned+cd ..+darcs get --old-fashioned temp0 temp1+test -e temp1/_darcs/inventory+rm -rf temp0 temp1++# get from hashed+mkdir temp0+cd temp0+darcs init --hashed+cd ..+darcs get --old-fashioned temp0 temp1+test -e temp1/_darcs/inventory+rm -rf temp0 temp1++# get from darcs-2+mkdir temp0+cd temp0+darcs init --darcs-2+cd ..+darcs get --old-fashioned temp0 temp1 > log+grep 'Warning' log+rm -rf temp0 temp1
+ tests/issue1111-pull-intersection.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash++. lib+# This test script is in the public domain.+++rm -rf temp1 temp2 temp3++mkdir temp1+cd temp1+darcs initialize+echo A > A+darcs add A+darcs record -a -m Aismyname+echo B > B+darcs add B+darcs record -a -m Bismyname++cd ..+darcs get temp1 temp2++cd temp2+darcs obliterate --last 1 -a+echo C > C+darcs add C+darcs record -a -m Cismyname+cd ..++mkdir temp3+cd temp3+darcs init+darcs pull -a -v --intersection ../temp1 ../temp2++darcs changes > out+cat out+grep Aismyname out+not grep Bismyname out+not grep Cismyname out+cd ..++rm -rf temp1 temp2 temp3
+ tests/issue1139-diff-last.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash+set -ev++rm -rf temp-$$+mkdir temp-$$+cd temp-$$+set -e+darcs initialize+echo text > foo+darcs add foo+darcs rec -am 'add foo'+darcs annotate -p .++echo newtext > foo+darcs record -am 'modify foo'++darcs diff --store --last=1 > out1+cat out1+grep text out1+grep foo out1++darcs diff --last=1 > out+cat out+grep text out+grep foo out++diff -u out1 out++cd ..++rm -rf temp-$$
+ tests/issue1139-diff-with-no-args.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+set -ev++rm -rf temp-$$+mkdir temp-$$+cd temp-$$+set -e+darcs initialize+echo text > foo+darcs add foo+darcs record -am 'add foo'+echo newtext > foo+darcs wh++darcs diff --store > out1+cat out1+grep text out1+grep foo out1++darcs diff > out+cat out+grep text out+grep foo out++diff out out1++cd ..++rm -rf temp-$$
+ tests/issue1162_add_nonexistent_slash.sh view
@@ -0,0 +1,16 @@+#!/bin/sh++set -ev++not () { "$@" && exit 1 || :; }++rm -rf temp+mkdir temp+cd temp+darcs init+not darcs add a/ 2> err+cat err+grep 'does not exist (No such file or directory)' err+cd ..++rm -rf temp
+ tests/issue1248.sh view
@@ -0,0 +1,20 @@+#!/usr/bin/env bash+## Test for issue1248 - darcs doesn't handle darcs 1 repos with compressed+## inventories+##+## Placed into the public domain by Ganesh Sittampalam, 2009++. lib+rm -rf temp1+mkdir temp1+cd temp1+darcs init --old-fashioned+touch foo+darcs rec -a -m'foo' -l --author=me@me+darcs tag --author=me@me foo+darcs check+darcs optimize --reorder+darcs check+darcs optimize --compress+darcs check+rm -rf temp1
+ tests/issue1269_setpref_predist.sh view
@@ -0,0 +1,28 @@+#!/bin/sh++set -ev++not () { "$@" && exit 1 || :; }++rm -rf temp+rm -rf dist1269.tar.gz+mkdir temp+cd temp++darcs init+printf "Line1\nLine2\nLine3\n" > foo+darcs record -alm Base++darcs setpref predist false++# It is a bug in darcs if the dist succeeds. It should+# fail with a non-zero exit code+not darcs dist -d dist1269++# It is a bug in darcs if the dist file has been created+# it should /not/ be created if the predist cmd returned+# a non-zero exit code+not test -f dist1269.tar.gz++cd ..+rm -rf temp
+ tests/issue1373_replace_token_chars.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Test for issue1373 - check that --token-chars [^ \t] is allowed.+## While we're at it, check some other things *aren't* allowed.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf temp                     # Another script may have left a mess.+darcs init --repodir temp+replace () { darcs replace --repodir temp --token-chars "$1" x y; }+## These are not well-formed tokens.+not replace ''+not replace 'a'+not replace ']a['+not replace '[]'+not replace '[^]'+## These are well-formed, but allow tokens to contain whitespace.+not replace $'[ ]'+not replace $'[\t]'+not replace $'[\n]'+not replace $'[\r]'+not replace $'[\v]'+not replace $'[^ ]'+not replace $'[^\t]'+not replace $'[^\n]'+not replace $'[^\r]'+not replace $'[^\v]'+rm -rf temp                     # Clean up after ourselves.
+ tests/issue1446.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+## Test for issue1446 - darcs amend-record -m foo destroys long description without warning+##+## Copyright (C) 2009  Dmitry Kurochkin+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repo.++touch R/f+darcs add f     --repo R+echo 'patch name' > R/patchinfo+echo 'patch description' >> R/patchinfo+darcs record -a --logfile=R/patchinfo --repo R+darcs changes   --repo R | grep 'patch name'+darcs changes   --repo R | grep 'patch description'++echo 'y' | darcs amend-record -p 'patch name' -m 'new name' --repo R+darcs changes   --repo R | grep 'new name'+darcs changes   --repo R | grep 'patch description'++echo content > R/f+echo 'another name' > R/patchinfo+echo 'another description' >> R/patchinfo+darcs record -a --logfile=R/patchinfo --repo R+darcs changes   --repo R | grep 'another name'+darcs changes   --repo R | grep 'another description'++echo 'y' | darcs amend-record -p 'another name' -m 'one more name' --repo R+darcs changes   --repo R | grep 'one more name'+darcs changes   --repo R | grep 'another description'++rm -rf R/                       # Clean up after ourselves.
+ tests/issue1465_ortryrunning.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue1465 - ortryrunning should try RHS if AND ONLY IF the+## LHS actually failed wasn't found or wasn't executable.+##+## Copyright (C) 2009  Trent W. Buck+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. ../tests/lib                  # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repo.+mkdir R/d                       # Change the working tree.++# Set the editor to a program that just fails (VISUAL), make Darcs use+# it (--edit), and then make sure when it brokenly launches a fallback+# editor, that editor will exit because stdin isn't a tty (/dev/null).+not env -u TERM VISUAL=false </dev/null &>R/log \+darcs record    --repo R -lam 'Initial commit.' --edit++# If Darcs did the right thing, the output won't make any mention of+# the fallback editors.+not egrep -i 'not found|vi|emacs|nano|edit' R/log++rm -rf R/                       # Clean up after ourselves.
+ tests/issue154_pull_dir_not_empty.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash+## Test for issue154 - when applying a patch that removes a directory,+## don't remove the directory from the working tree unless it's empty.+##+## Copyright (C) 2008  Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+mkdir d+darcs add d+darcs record -a -m "Added directory d"+darcs get ./ puller+cd puller+touch d/moo+darcs add d/moo+cd ..+rm -rf d+darcs record -a -m "Remove directory d"+cd puller+echo y | darcs pull -a .. > log+grep -i "backing up" log+grep -i "finished pulling" log+cd ..+rm -rf temp1
+ tests/issue157_rollback_conflict.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash++# issue157: A test for how rollback handles dependencies and conflicts.++. lib++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init --darcs-2+cd ..++# do some work here+cd temp1+echo a > foo+# Create three patches+darcs record -lam AA+echo b > foo+darcs record  -lam BB+echo c > foo+darcs record  -lam CC+# Rollback the last one+darcs rollback -a -p CC -m 'rollback CC'+grep b foo # reality check+cd ..++# Now get just the first two patches into a new repo...ignoring the third patch and the rollback.+darcs get --to-patch BB temp1 temp2+cd temp2+# Now in the second repo, rollback the second patch.+darcs rollback -a -p BB -m 'rollback BB'+grep a foo # reality check+# Finally, pull the third patch and the rollback of it.+# Because the two patches should cancel each other other, there should be no change here.+darcs pull -a ../temp1+# expect a conflict between the contents being 'a' or 'b'+grep "v v v" foo+grep a foo+grep b foo+cd ..++rm -rf temp1 temp2
+ tests/issue174_obliterate_before_a_tag.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash++# issue174: behave better when we want to obliterate a patch that comes before a tag.+. lib++rm -rf temp1++mkdir temp1+cd temp1+darcs init+# Setup: Create a patch, a tag and another patch.+touch a.txt+darcs add a.txt+darcs record -am 'adding a' a.txt+darcs tag "first tag";+touch b.txt+darcs add b.txt+darcs record --ignore-time -a -m 'adding b' b.txt+darcs obliterate -p "adding a" -a > log+not grep "no patch" log+cd ..++rm -rf temp1
+ tests/issue184_add.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash++. lib++# For issue184: recording files in directories that haven't explicity been added.++rm -rf temp1+mkdir temp1+cd temp1+darcs init+mkdir new+mkdir new/dir+touch new/dir/t.t+darcs add new/dir/t.t+darcs record -am test new/dir/t.t > log+not grep "don't want to record" log+cd ..++rm -rf temp1
+ tests/issue194.sh view
@@ -0,0 +1,26 @@+set -ev++rm -rf temp1 temp2++mkdir temp1; cd temp1 ; darcs init ; cd ..+darcs get temp1 temp2+cd temp2/ ; echo 'x' > _darcs/prefs/author ; cd ..+cd temp1/ ; echo 'x' > _darcs/prefs/author ; cd ..++cd temp1/+touch test ; darcs record+darcs add test     ; darcs record -a -m 'test'+darcs mv test best ; darcs record -a -m 'test -> best'+darcs mv best test ; darcs record -a -m 'best -> test'+cd ..++cd temp2/+touch test2+darcs add test2     ; darcs record -a -m 'test2'+darcs mv test2 best ; darcs record -a -m 'test2 -> best'+darcs mv best test2 ; darcs record -a -m 'best -> test2'++darcs pull ../temp1/ -a+cd ..++rm -rf temp1 temp2
+ tests/issue244_changes.sh view
@@ -0,0 +1,18 @@+#!/usr/bin/env bash+set -ev++# Issue244+# darcs changes should be able to pull up the history for a file+#   using its moved and not-yet recorded new name++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch b+darcs add b+darcs record -am 11+darcs mv b c+darcs changes c | grep 11+cd ..+rm -rf temp1
+ tests/issue257.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash+set -ev++rm -rf tempc+mkdir tempc+cd tempc+darcs init+echo foo > foo.c+darcs rec -Ax -alm init+cd ..+rm -rf temps+darcs get tempc temps+cd temps+echo server >> foo.c+darcs rec -Ax -alm server+cd ../tempc+echo client >> foo.c+darcs rec -Ax -alm client+if darcs push -a ../temps; then+        false+fi+cd ..+rm -rf tempc temps
+ tests/issue279_get_extra.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++# issue279: a conflict case resulting in "bug in get_extra" with old+# format repos and "Malformed patch bundle" with darcs-2 repos.++. lib++rm -rf temp1 temp_a temp_b temp_c temp_d+mkdir temp1+cd temp1+darcs init --darcs-2+echo 0 > f+darcs add f+darcs record -am 00+cd ..++for r in a b c d; do+  darcs put --repodir temp1 temp_$r+  cd temp_$r;+  echo $r > f+  darcs record -am "patch:$r";+  cd ..+done++cd temp_d+darcs pull -a ../temp_a+darcs pull -a ../temp_b+darcs pull -a ../temp_c+cd ..+cd temp_c+darcs pull -a ../temp_a+darcs pull -a ../temp_b+echo rc > f+darcs record -a -m rc+cd ..+cd temp_d+darcs pull -a ../temp_c > log+not grep -i "no remote changes" log+not grep -i get_extra log+cd ..++rm -rf temp1 temp_a temp_b temp_c temp_d log
+ tests/issue381.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+set -ev++# for issue381: "darcs send -o message --edit-description doesn't work"++DARCS_EDITOR=echo+export DARCS_EDITOR++rm -rf temp1 temp2+mkdir temp1 temp2++cd temp2+darcs init+cd ..++cd temp1+darcs init+echo Hello world > foobar+darcs add foobar+darcs record -a -A me -m add_foobar++# Test that editor is called when --output is used with --edit-description+echo This is a note > note+cat > editor <<EOF+#!/usr/bin/env bash+echo I am running the editor+echo the file is \$1+mv \$1 \$1-temp+echo hello world >> \$1+cat \$1-temp >> \$1+echo >> \$1+echo finished editing >> \$1+echo I am done running the editor+EOF++chmod +x editor++DARCS_EDITOR='bash editor' darcs send --debug --author=me -a --output=bundle --edit-description ../temp2++echo === beginning of bundle > ===+cat bundle+echo === end of bundle > ===++grep ' add_foobar' bundle+grep 'finished editing' bundle++IFS=' ' darcs send --author=me -a --subject="it works" --to user@place.org --sendmail-command='grep "^Subject: it works$" %<' ../temp2++cd ..+rm -rf temp1 temp2
+ tests/issue436.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+# this test fails in the darcs 1 format+darcs init --darcs-2+echo A > f+darcs add f+darcs record --ignore-times -a -m A+cd ..++darcs get temp1 temp2++cd temp1+echo C > f+darcs record --ignore-times -a -m A-C+cd ..++cd temp2+echo B > f+darcs record --ignore-times -a -m A-B+echo A > f+darcs record --ignore-times -a -m B-A+(darcs push -a || :) 2> push-result+grep "Refusing to apply" push-result+cd ..++rm -rf temp1 temp2
+ tests/issue458.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+### http://bugs.darcs.net/issue458+### darcs get --set-scripts-executable ignores umask+set -ev++## Windows doesn't support proper permissions.++if echo $OS | grep -i windows; then+    echo Windows does not support posix permissions+    exit 0+fi++rm -rf temp+mkdir temp+cd temp++mkdir repo1+darcs initialize --repodir repo1+printf >repo1/x '#!/bin/sh\ntrue'   # make a shebang'd script+darcs record --repodir repo1 -lam x x+umask 077                       # DENY ALL access to group, all+darcs get --set-scripts-executable repo1 repo2+ls -l repo2/x | cut -f 1 -d\  > mode+echo -rwx------ > desired-mode+diff -u desired-mode mode++cd ..+rm -rf temp
+ tests/issue525_amend_duplicates.sh view
@@ -0,0 +1,24 @@+#!/bin/sh++set -ev++## I would use the builtin !, but that has the wrong semantics.+not () { "$@" && exit 1 || :; }++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo first > a+darcs add a+darcs record -am 'first'+echo replace first with something else > a+darcs record -am 'mistake'+echo first > a+echo on second thought >> a+echo ya | darcs amend-record -a+darcs changes --last=1 -v > output+cat output+not grep first output+cd ..+rm -rf temp1
+ tests/issue53.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash+++. lib++if echo $OS | grep -i windows; then+    echo This test does not work under Windows+    exit 0+fi++# pull from not empty repo to empty repo+rm -rf temp1+mkdir temp1++cd temp1+darcs init+echo a > Aux.hs+not darcs add Aux.hs+darcs add --reserved-ok Aux.hs+echo b > foo+darcs add foo+darcs record -am 'two files'+not darcs mv foo com1+darcs mv --reserved-ok foo com1+cd ..++rm -rf temp1
+ tests/issue538.sh view
@@ -0,0 +1,117 @@+#!/bin/env bash+# A test for issue 538 - that an executable test script will run successfully if+# it is recorded with --set-scripts-executable.++set -ev++if echo $OS | grep -i windows; then+    echo I do not know how to run a test program under windows+    exit 0+fi++function make_repo_with_test {+    mkdir temp1 ; cd temp1 ; darcs init+    echo "#!/bin/sh" > test.sh+    echo "echo 'hello world'" >> test.sh+    darcs add test.sh+    darcs record --author=test@test -am test+    darcs setpref test './test.sh'+}++# test record with --set-scripts-executable+rm -rf temp1+make_repo_with_test+touch blaat+darcs add blaat+if darcs record --set-scripts-executable -A test@test -am blaat ; then+    echo "ok 1"+else+    echo "not ok 1 recording second patch failed (because test failed?)"+    exit 1+fi+cd ..++# test record without --set-scripts-executable +rm -rf temp1+make_repo_with_test+touch blaat+darcs add blaat+if darcs record --dont-set-scripts-executable -A test@test -am blaat ; then+    echo "not ok 2 recording second patch succeeded though test script should not be executable"+    exit 1+else+   echo "ok 2"+fi+cd ..++# test amend-record with --set-scripts-executable+rm -rf temp1+make_repo_with_test+touch blaat+darcs add blaat+if echo y | darcs amend-record --set-scripts-executable -A test@test -a ; then+    echo "ok 3"+else+    echo "not ok 3 amending patch failed (because test failed?)"+    exit 1+fi+cd ..++# test amend-record without --set-scripts-executable+rm -rf temp1+make_repo_with_test+touch blaat+darcs add blaat+if echo y | darcs amend-record --dont-set-scripts-executable -A test@test -a /dev/null ; then+    echo "not ok 4 amending patch succeeded even though --dont-set-scripts-executable specified"+    exit 1+else +    echo "ok 4"+fi+cd ..++# trackdown with --set-scripts-executable+rm -rf temp1+make_repo_with_test+if darcs trackdown --set-scripts-executable | grep 'Success!' ; then+    echo "ok 5"+else+    echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)"+    exit 1+fi+cd ..++# trackdown without --set-scripts-executable+rm -rf temp1+make_repo_with_test+if darcs trackdown --dont-set-scripts-executable | grep 'Noone passed the test!' ; then+    echo "ok 6"+else+    echo "not ok 6 tracking down did not find failure even though --dont-set-scripts-executable was given"+    exit 1+fi+cd ..++# check trackdown with files that become scripts during trackdown+rm -rf temp1+mkdir temp1 ; cd temp1 ; darcs init+echo "#!/bin/sh" > test.sh+echo "./helper.sh" >> test.sh+echo "#!/bin/sh" > helper.sh+echo "echo 'helper speaking'" >> helper.sh+darcs add test.sh+darcs add helper.sh+darcs record -am 'valid helper' -A test+echo 'this is definitely not a valid script' > helper.sh+darcs record -am 'invalid helper' -A test+darcs setpref test './test.sh'+darcs trackdown --set-scripts-executable > trackdown-out+if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then+    echo "ok 7"+else +    echo "not ok 7 either no failure or no success (both should occur)"+    exit 1+fi+cd ..++rm -rf temp1
+ tests/issue588.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash++# For issue588, "amend-record --look-for-adds end up with two "addfile" entries"++set -ev++rm -rf temp1+darcs init --repodir temp1++# Setup f with contents foo.+echo foo > temp1/f+darcs add --repodir temp1 f+darcs rec --repodir temp1 -am p1++# Remove f, and amend p1, but only the hunk not the rmfile.+# Here we use look-for-adds to trigger the bug+rm temp1/f+echo yyd | darcs amend-record --repodir temp1 --look-for-adds++darcs changes --repodir temp1 --last 1 -v++echo show the buggy pending+cat temp1/_darcs/patches/pending++echo bar > temp1/f+echo y | darcs amend-record --repodir temp1 --all++darcs changes --repodir temp1 --last 1 -v++darcs check --repodir temp1 --no-test++rm -rf temp1
+ tests/issue595_get_permissions.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash++# Issue595+#+# A test for running "darcs get" when the parent directory has restrictive+# permissions.  The bug is that darcs trys to "chdir" to the current directory+# using the full path.  The permissions on the parent directory prevent this+# from working, even though the current repo and the remote have sufficient+# permissions.+#+# The real-world case where this would happen would be a web-server with+# restrictive permissions on "/home", with a user running darcs within that.++. lib++abort_windows++rm -rf temp1 temp2++# Set up a "remote" repo+mkdir tmp_remote+cd tmp_remote+darcs 'init'+cd ..++DIR=`pwd`+# Set up a directory with restrictive permissions+mkdir -p tmp_restrictive/liberal+cd tmp_restrictive/liberal+chmod 0111 ../../tmp_restrictive+# sanity check that we can cd out and back+cd ../..; cd tmp_restrictive/liberal+# TODO: we avoid this test on Solaris because it seems we can't create+# anything in tmp_restrictive/liberal+touch can_touch+if [ -e can_touch ]; then+  if hwpwd; then+    darcs get "$DIR/tmp_remote" 2> log+    not grep -i 'permission denied' log+  else+    echo "Apparently I can't do `basename $0` on this platform"+  fi+else+  echo "Can't do `basename $0` on this platform"+fi+cd "$DIR"+# We have to fix the permissions, just so we can delete it.+chmod 0755 tmp_restrictive++rm -rf tmp_remote tmp_restrictive
+ tests/issue612_repo_not_writeable.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++# Test that darcs fails appropriately when the target repo inventory file is not writable.+# See issue612++. lib++abort_windows++if grep old-fashioned .darcs/defaults; then+  echo This test does not work with old-fashioned inventories+  exit 0+fi++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+touch t.t+darcs add t.t+darcs record -am "initial add"+if [ -e _darcs/inventories ]; then+  chmod 0555 _darcs/inventories/*+  chmod 0555 _darcs/inventories+fi+if [ -e _darcs/inventory ]; then+  chmod 0555 _darcs/inventory+fi+cd ..++darcs get temp1 temp2+cd temp2+echo new >> t.t+darcs record -am "new patch"+not darcs push -a ../r1 2> log+grep failed log+cd ..++chmod -R 0755 temp1+rm -rf temp1 temp2++
+ tests/issue691.sh view
@@ -0,0 +1,12 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+echo 'record patch-name' > _darcs/prefs/defaults # patch-name requires an argument+echo 'ALL unified foobar' >> _darcs/prefs/defaults # unified takes no argument+darcs record && exit 1+darcs whats && exit 1+rm -rf temp
+ tests/issue706.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash+set -ev++# for issue706: "Filenames with spaces issue"++DARCS_EDITOR=echo+export DARCS_EDITOR++rm -rf temp+mkdir temp+cd temp+darcs init++touch 'A B'++darcs add 'A B'+darcs rec -a -m 'a b' -A me+ls+darcs check++cd ..+rm -rf temp
+ tests/issue709_pending_look-for-adds.sh view
@@ -0,0 +1,56 @@+#!/bin/sh+set -ve++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++# Here we check whether recording just one of two --look-for-add+# addfiles causes any trouble (which it doesn't)++date > f1+date > f2+echo yyd | darcs record -l -m ff++cat _darcs/patches/pending++not darcs wh+rm f2++# Try recording a file add without --look-for-adds, with a setpref+# patch present that we don't record.++darcs setpref boringfile .boring++echo bar > bar+darcs add bar+echo yyd | darcs record -mbar++cat _darcs/patches/pending++darcs whatsnew -s++test -z "`darcs whatsnew -s`"++# Now try the same thing using --look-for-adds++echo foo > foo++darcs wh -l++# remove any files added by profiling or hpc...+rm -f darcs.tix darcs.prof++echo yyd | darcs record --look-for-adds -mfoo++cat _darcs/patches/pending++darcs whatsnew -s++test -z "`darcs whatsnew -s`"++cd ..+rm -rf temp1
+ tests/issue70_setpref.sh view
@@ -0,0 +1,62 @@+#!/usr/bin/env bash+## Test for issue70 - unrecorded (pending) changes to preferences+## should coalesce; if you set the same preference more than once in+## the same patch, only the last change should actually be recorded.+##+## Copyright (C) 2005  Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+darcs setpref predist apple+darcs setpref predist banana+darcs setpref predist clementine+darcs record -a  -m manamana+darcs changes --verbose > log+not grep apple log+not grep banana log+grep clementine log+cd ..+rm -rf temp1++# not sure what i'm going for here - if coalescing happens strictly+# before commuting, no problem, but what if patches are commuted+# before coalescing?+mkdir temp1+cd temp1+darcs init+darcs setpref predist apple+darcs setpref predist banana+darcs setpref predist apple+darcs setpref predist clementine+darcs setpref predist banana+darcs record -a  -m manamana+darcs changes --verbose > log+not grep apple log+not grep clementine log+grep banana log+cd ..+rm -rf temp1
+ tests/issue803.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash++# http://bugs.darcs.net/issue803: Darcs 2.0 regression on manual renames+++. lib++rm -rf temp+mkdir temp+cd temp+darcs init++touch a.txt+darcs add a.txt+darcs record -a -m "First" -A me++mkdir subdir+darcs add subdir+darcs record -a -m "Second" -A me++mv a.txt subdir/+darcs mv a.txt subdir/a.txt+darcs record -a -m "Third" -A me++darcs changes --last 1 -v > stdout+cat stdout++not grep 'rmfile' stdout++cd ..+rm -rf temp
+ tests/issue844_gzip_crc.sh view
@@ -0,0 +1,20 @@+#!/usr/bin/env bash+set -ev+rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo > a+darcs add a+darcs record a -a -m "init"+cd ..++mkdir temp2+cd temp2+darcs init+darcs pull ../temp1 -a+darcs optimize --compress+for f in _darcs/patches/*-*; do+	gzip -t < "$f"+done+rm -rf temp1 temp2
+ tests/issue864_replace_in_moved.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash++# Issue 864++# darcs mv file1 file2+# edit file2+# darcs replace fails if new token includes some existing edits++# Regression in darcs2 - it works in darcs1 1.0.9++set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+cat <<EOF > file1+aa+bb+cc+aa+bb+cc+EOF+darcs add file1+darcs record -a -m "0" --author X++cat <<EOF > file1+aaaa+bb+cc+aa+bb+cc+EOF++darcs replace aa aaaa file1 > out+cat out+grep 'Skipping file' out && exit 1++darcs mv file1 file2++cat <<EOF > file2+aaaa+beebee+cc+aa+bb+cc+EOF++darcs replace bb beebee file2 > out+cat out+grep 'Skipping file' out && exit 1++cd ..+rm -rf temp
+ tests/issue885_get_to_match.sh view
@@ -0,0 +1,34 @@+#!/bin/sh++# Issue885: Regression: "darcs get --to-match" does not work anymore under 2.0+++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo first > a+darcs add a+darcs record -am 'first'+firsthash=`darcs changes --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"`+echo second > b+darcs add b+darcs record -am 'second'++# Pulling that patch works ok+cd ..+rm -rf temp2+mkdir temp2+cd temp2+darcs init+echo darcs pull -v -a --match "hash $firsthash" ../temp1+darcs pull -v -a --match "hash $firsthash" ../temp1++# Getting up-to that patch does not+cd ..+rm -rf temp3+echo darcs get -v --to-match "hash $firsthash" temp1 temp3+darcs get -v --to-match "hash $firsthash" temp1 temp3+
+ tests/issue966_diff.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp; cd temp+darcs init+echo "aaa diff" > file+darcs add file+darcs record -a -m "aaa"+echo "bbb diff" >> file+darcs record -a -m "bbb"++darcs diff --patch "aaa" | grep "aaa diff"+darcs diff --patch "bbb" | grep "bbb diff"++darcs tag release-1+darcs optimize++echo "ccc diff" >> file+darcs record -a -m "ccc"+darcs diff --patch "ccc" | grep "ccc diff"++# here is where we have a problem+darcs diff --patch "aaa" | grep "aaa diff"+darcs diff --patch "bbb" | grep "bbb diff"
+ tests/justrm.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo+darcs record -a -m add_foo -A x+rm foo+darcs whatsnew+cd ..+rm -rf temp1+
+ tests/lazy-optimize-reorder.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2 temp3+mkdir temp1+cd temp1+darcs init++# this test only applies to hashed formats+if cat _darcs/inventory; then exit 0; fi++date > f1+darcs add f1+darcs record -am 'add f1'++darcs tag -m 'tag f1'++date > f2+darcs add f2+darcs record -am 'add f2'+cd ..++darcs get --lazy temp1 temp2++darcs get --lazy temp2 temp3++cd temp2++# Run darcs changes so we pull in the inventories (but no the patches)+darcs changes++# Remove original repository, so we have no references to changes f1 and f2.+rm -rf ../temp1++# Now we should be unable to read some of the history+darcs changes -s > out+cat out+grep unavailable out++date > f3+darcs add f3+darcs record -am 'add f3'++darcs tag -m 'tag 123'+cd ..++cd temp3+date > f4+darcs add f4+darcs record -am 'add f4'+darcs pull -av++# Here's the point of this test: we should be able to optimize+# --reorder without being able to read all the patches in the+# repository.+darcs optimize --reorder++# Just a double-check: we shouldn't be able to check in this case.+not darcs check++cd ..++rm -rf temp1 temp2 temp3 temp4
+ tests/lib view
@@ -0,0 +1,18 @@+# This is a -*- sh -*- library.+set -ev++## I would use the builtin !, but that has the wrong semantics.+not () { "$@" && exit 1 || :; }++# trick: OS-detection (if needed)+abort_windows () {+if echo $OS | grep -i windows; then+  echo This test does not work on Windows+  exit 0+fi+}++pwd() {+    ghc --make "$TESTS_WD/hspwd.hs"+    "$TESTS_WD/hspwd"+}
+ tests/look_for_add.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash++cat > empty_pending <<EOF+{+}+EOF+check_empty_pending() {+  echo ================ pending ==================+  cat _darcs/patches/pending+  echo ================ pending ==================+  [ -z _darcs/patches/pending ] || cmp _darcs/patches/pending ../empty_pending+}++set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+mkdir dir+darcs record -a -m add_dir -A x --look-for-adds+check_empty_pending+echo zig > dir/foo+echo zag > foo+mkdir dir2+echo hi > dir2/foo2+darcs record -a -m add_foo -A x --look-for-adds+check_empty_pending+cd ../temp2+darcs init+darcs pull -a ../temp1+cd ..+cmp temp1/dir2/foo2 temp2/dir2/foo2+cmp temp1/dir/foo temp2/dir/foo+cmp temp1/foo temp2/foo+rm -rf temp1 temp2+
+ tests/mark-conflicts.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash++# Automated tests for "darcs mark-conflicts".++# The builtin ! has the wrong semantics for not.+not () { "$@" && exit 1 || :; }++mkdir temp1+cd temp1+darcs init+echo "Conflict, Base ." > child_of_conflict+darcs add child_of_conflict+darcs record -am 'Conflict Base'+cd ..+darcs get temp1 temp2++# Add and record differing lines to both repos+cd temp1+echo "Conflict, Part 1." > child_of_conflict+darcs record -A author -am 'Conflict Part 1'+cd ..+cd temp2+echo "Conflict, Part 2." > child_of_conflict+darcs record -A author -am 'Conflict Part 2'+cd ..++cd temp1+darcs pull -a ../temp2 > log+grep conflict log+grep finished log+grep 'v v' child_of_conflict+darcs revert -a+not grep 'v v' child_of_conflict+darcs mark-conflicts+grep 'v v' child_of_conflict+cd ..++rm -rf temp1 temp2
+ tests/match-date.sh view
@@ -0,0 +1,196 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+# Some tests for the '--match' flag, specifically the date-matching++reset_repo () {+  cd ..+  rm -rf temp1+  mkdir temp1+  cd temp1+  darcs init+  touch bar+  darcs add bar+}++create_entry () {+  echo $1 >> bar+  echo "$1/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar+}++create_entry_now () {+  echo today >> bar+  darcs record -m "" bar -a -A tester+}++# parse_date just checks for parsing, while match_date checks for an actual match.+# It's better if we can use "match_date", but we have to be able to construct such a date+# based on a date dynamically generated by this test script.++# alternately, it might be more useful to build a random date string generator+# using QuickCheck... for any n random CalendarTimes, have it generate some+# possible variants and roundtrip them to see if they match++parse_date () {+  darcs changes --match "date \"$1\"" > log+  not grep fancy log+}++match_date () {+  darcs changes --match "date \"$1\"" > log+  grep tester log+  not grep fancy log+}++nomatch_date () {+  darcs changes --match "date \"$1\"" > log+  not grep tester log+  not grep fancy  log+}++mkdir temp1+cd temp1+reset_repo++# this block of dates should all refer to the same thing+year=1973+mm=02+dd=04+hhmmss="15:08"+create_entry "$year-$mm-$dd $hhmmss"+echo "/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar+match_date "$year-$mm-$dd"+match_date "$year$mm$dd"+match_date "$year-$mm"+match_date "$year$mm"+match_date "$year"++# week dates. note that 2007 was selected as it starts on Monday+reset_repo+create_entry "2007-01-04 15:00"+match_date '2007-W01-4'+nomatch_date '2007-W01-1'+match_date '2007W014'+match_date '2007-W01'+nomatch_date '2007-W02-1'+create_entry "2007-01-08 15:00"+match_date '2007-W02'+match_date '2007-W02-1'+create_entry "2007-05-20 15:00"+match_date '2007-W20'+nomatch_date '2007-W21'+nomatch_date '2007-W19'+# ordinal dates. eh... why not?+match_date '2007-004'; # fourth day of 2007+match_date '2007004'+nomatch_date '2007-005'++# midnight and zero+reset_repo+create_entry "1992-10-15 00:00"+match_date '1992-10-14 24:00'+match_date '1992-10-15 00:00'++# all the same date/time+reset_repo+create_entry "1992-02-12T22:32:11"+match_date '1992-02-12T22:32:11'+match_date '1992-02-12 22:32:11'+match_date '1992-02-12T223211.0000'++# english dates - the old hard coded from < darcs 1.0.6+reset_repo+year=`date +%Y`+mm=`date +%m`+dd=`date +%d`+hhmmss=`date +%k:%M:%S`+tz=`date +%z`+create_entry "$(($year-1))-$mm-$dd"+nomatch_date 'today'+nomatch_date 'yesterday'+nomatch_date 'day before yesterday'+nomatch_date 'last week'+nomatch_date 'last month'+# note: this test might fail if you run it just before midnight+reset_repo+create_entry_now+match_date 'today'+nomatch_date 'yesterday'+nomatch_date 'day before yesterday'+match_date 'last week'+match_date 'last month'++reset_repo+create_entry "$(($year-1))-$mm-$dd"+# english dates - new possibilities+nomatch_date 'yesterday at 14:00:00'+match_date 'last 3 years'+match_date 'last year'+nomatch_date '2 days ago'+nomatch_date 'last month 13:00'+nomatch_date '3 days before last week'+reset_repo+create_entry_now+match_date 'day after yesterday'+match_date 'week after last week'+create_entry "1992-10-02 00:15"+match_date '15 minutes after 1992-10-02'+reset_repo+create_entry "1992-10-02 00:15+05"+# note that earlier dates will always match+match_date '15 minutes after 1992-10-02 00:00+05';   # same time+match_date '15 minutes after 1992-10-01 23:00+04';   # same time+nomatch_date '15 minutes after 1992-10-02 01:00+05'; # 1 hour later+nomatch_date '15 minutes after 1992-10-02 00:00+04'; # 1 hour later+nomatch_date '1 hour, 15 minutes after 1992-10-02 00:00+05'; # 1 hour later+match_date '1 hour, 15 minutes after 1992-10-02 00:00+06'; # same time+match_date '1 hour, 15 minutes after 1992-10-01 23:00+05'; # same time++reset_repo+create_entry_now+create_entry 1992-10-02 00:15+# english intervals+nomatch_date 'between last fortnight and day before yesterday'+match_date 'between last fortnight and today'+match_date 'in the last 45 seconds'+match_date 'after 1992'++# iso 8601 intervals+parse_date '1992-10-02 00:00Z/1992-10-02 00:16Z'+match_date '1992-10-02 00:00/1992-10-02 00:16'+match_date 'between 1992-10-02 00:00 and 1992-10-12 00:16'+parse_date 'P3YT3M/1992'+parse_date '1992/P3Y3M4DT5H3M2S'+parse_date '1992/P3Y3M'++# stuff from the manual+reset_repo+create_entry_now+nomatch_date 'between 2004-03-12 and last week'+match_date 'last week'+parse_date 'yesterday'+parse_date 'today 14:00'+nomatch_date '3 days before last year at 17:00'+# We can't in general parse the raw date output by darcs.  If we change the+# format to not include timezone information, this would be possible.  But+# maybe that's not desireable.  For now, we just won't test the raw date.+#match_date "$raw_date"+parse_date 'after 2005'+parse_date 'in the last 3 weeks'+parse_date 'P3M/2006-03-17'+parse_date '2004-01-02/2006-03-17'+parse_date 'P2M6D'++# cvs dates+parse_date '2006/01/19 21:14:20 UTC'+# We can't handle all timezones in the old style dates+# so this test will not work everywhere+# match_date "$year/$mm/$dd $hhmmss $tz"++reset_repo+create_entry '2038-01-01'+match_date 'after 2037'++rm -rf temp1 temp2
+ tests/match.sh view
@@ -0,0 +1,97 @@+#!/usr/bin/env bash++# Some tests for the '--match' flag++. lib++# set up the repository+rm -rf temp1                    # another script may have left a mess.+mkdir temp1+cd temp1+darcs init+cd ..++# create three patches - the property we exploit to determine+# if a matcher does the right thing is that each patch has a+# different author+cd temp1+touch bar+darcs add bar+darcs record -a -m "first patch"  bar -A author1+echo foo > bar+darcs record -a -m "\"second\" \\ patch" bar -A author2+echo blop > bar+darcs record -a -m "second" bar -A author3+cd ..++# -------------------------------------------------------------------+# single matchers+# -------------------------------------------------------------------++cd temp1+# matching on author really matches on that, and not something else+darcs changes --match='author "first patch"' > log+not grep '.' log+# normal changes shows both authors and patch names+darcs changes > log+grep author1 log+grep author2 log+grep author3 log+grep 'first patch' log+grep '"second" \\ patch' log+grep -v patch log | grep second+# exact+darcs changes --match='exact second' > log+not grep author1 log+not grep author2 log+grep author3 log+# name+darcs changes --match='name second' > log+not grep author1 log+grep author2 log+grep author2 log+# author+darcs changes --match='author author1' > log+grep author1 log+not grep author2 log+not grep author3 log+#hash+darcs changes --xml-output --match='exact "\"second\" \ patch"' > log+hash=`grep hash log | sed -e "s/.*hash='//" -e "s/'.*//"`+echo $hash+darcs changes --match="hash $hash"+not grep author1 log+grep author2 log+not grep author3 log+cd ..++# -------------------------------------------------------------------+# matching on combinations+#+# uses the setup from the atomic patches+# -------------------------------------------------------------------++cd temp1+# or+darcs changes --match='author author1 || author author2' > log+grep author1 log+grep author2 log+not grep author3 log+# and+darcs changes --match='name second && author author2' > log+not grep author1 log+grep author2 log+not grep author3 log+# not+darcs changes --match='not name second' > log+grep author1 log+not grep author2 log+not grep author3 log+# grouping+darcs changes --match='(not name second) || (author author3)' > log+grep author1 log+not grep author2 log+grep author3 log+cd ..++rm -rf temp1
+ tests/merge_three_patches.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+set -ev++rm -rf tempOld tempA tempB+mkdir tempOld tempA+cd tempOld+darcs initialize+echo record author me > _darcs/prefs/defaults+echo ALL all >> _darcs/prefs/defaults+#echo ALL verbose >> _darcs/prefs/defaults+echo ALL ignore-times >> _darcs/prefs/defaults+echo A > foo+echo B >> foo+echo C >> foo+echo D >> foo+echo E >> foo+echo F >> foo+echo G >> foo+echo H >> foo+darcs add foo+darcs record -m Old+cd ..++cd tempA+darcs initialize+cp ../tempOld/_darcs/prefs/defaults _darcs/prefs+darcs pull ../tempOld+cp foo temp+cat temp | grep -v A | grep -v B | grep -v D | sed s/E/e/ \+    | grep -v G | sed s/H/h/ > foo+darcs record -m AA+cd ..++darcs get tempOld tempB+cd tempB+cp ../tempOld/_darcs/prefs/defaults _darcs/prefs+echo 7 > foo+darcs record -m BB+darcs pull ../tempA+darcs record -m "conflict resolution"+cd ..++cd tempA+darcs pull ../tempB+darcs annotate -p B+darcs annotate -p resolution+cd ..++cmp tempA/foo tempB/foo++rm -rf tempOld tempA tempB+
+ tests/mergeresolved.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash+set -ev++rm -rf fooOld tempA tempB+mkdir fooOld tempA tempB+cd fooOld+darcs init+echo record author me > _darcs/prefs/defaults+echo ALL all >> _darcs/prefs/defaults+#echo ALL verbose >> _darcs/prefs/defaults+echo ALL ignore-times >> _darcs/prefs/defaults+echo Old > foo+darcs add foo+darcs record -m Old+cd ..++cd tempA+darcs init+cp ../fooOld/_darcs/prefs/defaults _darcs/prefs+darcs pull ../fooOld+echo A > foo+darcs record -m AA+cd ..++cd tempB+darcs init+cp ../fooOld/_darcs/prefs/defaults _darcs/prefs+darcs pull ../fooOld+echo B > foo+darcs record -m BB+darcs pull ../tempA+echo A > foo+darcs record -m "ok A's fine."+cd ..++# At this point, tempB and tempA should agree--since the conflict was+# resolved in favor of tempA.+cmp tempB/foo tempA/foo++cd tempA+echo AA > foo+darcs record -m "AA -- upping the ante."+cd ..++cd tempB+darcs pull ../tempA+cd ..++cd tempA+darcs pull ../tempB+cd ..++# At this point, tempB and tempA should agree since we have pulled both ways.+cmp tempB/foo tempA/foo++rm -rf fooOld tempA tempB+
+ tests/merging_newlines.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash++# trick: requiring something to fail+. lib++# A test for darcs resolve detecting a conflict, inspired by bug #152 in RT++rm -rf temp1 temp2++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+echo "apply allow-conflicts" > _darcs/prefs/defaults+# note: to make this pass, change echo to echo -n+# is that right?+echo "from temp1" > one.txt+darcs add one.txt+darcs record -A bar -am "add one.txt"+echo >> one.txt+darcs wh -u+cd ..++darcs get temp1 temp2+cd temp2+# reality check+darcs show files | grep one.txt+echo "in tmp2" >> one.txt+darcs whatsnew -s | grep M+darcs record -A bar -am "add extra line"+darcs annotate -p . -u+darcs push -av > log+cat log+not grep -i conflicts log+cd ..++rm -rf temp1 temp2
+ tests/mv-formerly-pl.sh view
@@ -0,0 +1,136 @@+#!/usr/bin/env bash++# Some tests for 'darcs mv'++. lib++rm -rf temp+mkdir temp+cd temp+darcs init++###++echo adding a directory with more than one .. in it should work.+mkdir foo.d+mkdir foo.d/second+mkdir foo.d/second/third+mkdir foo.d/other+++touch ./foo.d/other/date.t+darcs add -r foo.d++cd foo.d/second/third++darcs mv ../../other/date.t ../../other/date_moved.t++cd ../../..+echo darcs refuses to move to an existing file+touch ping+touch pong+darcs add ping pong+not darcs mv ping pong &> out+cat out+grep 'already exists' out++# case sensitivity series+# -----------------------+# these are tests designed to check out darcs behave wrt to renames+# where the case of the file becomes important++# are we on a case sensitive file system?+touch is_it_cs+rm -f IS_IT_CS++if test -e is_it_cs; then+  echo This is a case-sensitive file system.+else+  echo This is NOT a case-sensitive file system.+fi++# if the new file already exists - we don't allow it+# basically the same test as mv ping pong, except we do mv ping PING+# and both ping and PING exist on the filesystem+echo "case sensitivity - simply don't allow mv if new file exists"+touch 'cs-n-1'; touch 'CS-N-1';+touch 'cs-y-1'; touch 'CS-Y-1';+darcs add cs-n-1 cs-y-1++if test -e is_it_cs; then+  # regardless of case-ok, we do NOT want this mv at all+  not darcs mv cs-n-1 CS-Y-1 &> out+  cat out+  grep 'already exists' out++  not darcs mv --case-ok cs-n-1 CS-Y-1 &> out+  cat out+  grep 'already exists' out+fi++# if the new file does not already exist - we allow it+echo "case sensitivity - the new file does *not* exist"+touch 'cs-n-2';+touch 'cs-y-2';+darcs add cs-n-2 cs-y-2+# these mv's should be allowed regardless of flag or filesystem+darcs mv cs-n-2 CS-N-2+darcs mv --case-ok cs-y-2 CS-Y-2++# parasites - do not accidentally overwrite a file just because it has a+# similar name and points to the same inode.  We want to check if a file if the+# same NAME already exists - we shouldn't care about what the actual file is!+echo "case sensitivity - inode check";+touch 'cs-n-3';+touch 'cs-y-3';+darcs add cs-n-3 cs-y-3++if ln cs-n-3 CS-N-3; then # checking if we support hard links+  ln cs-y-3 CS-Y-3+  # regardless of case-ok, we do NOT want this mv at all+  not darcs mv cs-n-3 CS-N-3 &> out+  cat out+  grep 'already exists' out++  not darcs mv --case-ok cs-y-3 CS-Y-3 &> out+  cat out+  grep 'already exists' out+fi++# parasites - we don't allow weird stuff like mv foo bar/foo just because+# we opened up some crazy exception based on foo's name+echo 'refuses to move to an existing file with same name, different path'+touch 'cs-n-4'; touch 'foo.d/cs-n-4';+touch 'cs-y-4'; touch 'foo.d/cs-y-4';+darcs add cs-n-4+# regardless of case-ok, we do NOT want this mv at all+not darcs mv cs-n-4 foo.d/cs-n-4 &> out+cat out+grep 'already exists' out++not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 &> out+cat out+grep 'already exists' out++# ---------------------------+# end case sensitivity series++touch abs_path.t+darcs add abs_path.t+REPO_ABS=`pwd`+darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t+darcs mv abs_path_new.t "$REPO_ABS/abs_path.t"+++# issue608++   touch 'gonna_be_deleted';+   darcs add gonna_be_deleted+   darcs record -am 'added doomed file'+   rm gonna_be_deleted+   darcs record -am 'deleted file'+   touch 'new_file';+   darcs add new_file+   darcs mv new_file gonna_be_deleted++
+ tests/mv-test-suite.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init++date > foo+darcs record -a -m add_foo -A x --look-for-adds++# add a test file+echo 'test ! -e foo' > test.sh+darcs add test.sh+darcs record -a -m add_test++darcs setpref test 'ls && bash test.sh'+darcs record -a -m settest -A x --no-test++darcs mv foo bar+darcs record --debug -a -m mvfoo -A x++darcs check++cd ..+rm -rf temp1+
+ tests/mv.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+echo hi world > temp.c+darcs add temp.c+darcs record --all -A test --patch-name=hi+echo goodbye >> temp.c+darcs whatsnew+darcs record -a -A au -m bye+echo bar > bar.c+darcs add bar.c+darcs record -a -m one -A ex+darcs mv bar.c zig.c+darcs whatsnew+darcs record -a -m two -A ex+mkdir baz+darcs add baz+darcs whatsnew+darcs record -a -m three -A ex+darcs mv zig.c baz/bar.c+darcs whatsnew+darcs record -a -m four -A ex+darcs mv baz temp+darcs whatsnew+darcs record -a -m five -A ex++darcs mv temp temp 1> stdout 2> stderr || true+grep 'Cannot rename a file or directory onto itself' stderr++cd ..++rm -rf temp+mkdir temp+cd temp+darcs init+echo hi world > a+darcs add a+darcs record --all -m lower+cd ..+darcs get temp temp1+cd temp+darcs mv a A+echo goodbye > A+darcs record --all -m 'to upper'+cd ../temp1+darcs pull -a++cd ..+rm -rf temp temp1
+ tests/mv_and_remove_tests.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init+touch fee fi fo fum+darcs add f*+darcs record --author me --all --no-test --patch-name add+mkdir d+darcs add d+darcs mv f* d+darcs remove d/fi+cd d+darcs remove fo+echo let us have fun > fun+darcs add fun+darcs mv fun fum ..+darcs record --author me --all --no-test --patch-name mv+cd ..++if darcs show files | egrep '^./fee$'; then false; else true; fi+test ! -f fee+darcs show contents d/fee | cmp d/fee -++test ! -f fi+test -f d/fi+if darcs show files | egrep '^./fi$'; then false; else true; fi+if darcs show files | egrep '^./d/fi$'; then false; else true; fi++test ! -f fo+test -f d/fo+if darcs show files | egrep '^./fo$'; then false; else true; fi+if darcs show files | egrep '^./d/fo$'; then false; else true; fi++darcs show contents fun | cmp fun -+darcs show contents fum | cmp fum -++darcs mv fun d+darcs record -A me -a --no-test -m "fun again"+darcs show content d/fun | cmp d/fun -+test ! -f fun+if darcs show files | egrep '^./fun$'; then false; else true; fi++# Now clean up.+cd ..+rm -rf temp+
+ tests/mv_then_add.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init+touch fee fi fo fum+darcs add f*+darcs record --author me --all --no-test --patch-name add+darcs mv fee foo+touch fee+darcs add fee+darcs record --author me --all --no-test --patch-name newfee+darcs mv fi fib+darcs record --author me --all --no-test --patch-name mvfi+date > fi+darcs add fi +darcs record --author me --all --no-test --patch-name newfi++cd ..++rm -rf temp+
+ tests/network/changes.sh view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+set -ev++# Demonstrates issue385+darcs changes --repo=http://darcs.net GNUmakefile --last 300
+ tests/network/get.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp2 temp3++#"$DARCS" get http://darcs.net temp++darcs get --lazy http://darcs.net temp2++darcs get --lazy --tag . http://darcs.net temp3++cd temp2+darcs obliterate --from-tag . -a+darcs pull --tag . -a+cd ..++diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory++rm -rf temp temp2 temp3
+ tests/network/lazy-get.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp2 temp3++darcs get --lazy http://darcs.net/repos/franchise temp++darcs get --lazy temp temp2++rm -rf temp++cd temp2++test ! -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a++darcs annotate -p 'initial minimal version'++test -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a++cd ..++rm -rf temp temp2 temp3
+ tests/nodeps.sh view
@@ -0,0 +1,81 @@+#!/usr/bin/env bash+set -ev++# Test the --no-deps option with Send, Push, Pull, Obliterate and Unrecord.+#+# Create four patches with dependencies.+#   file 'f': patch 'fa' and 'fb'+#   file 'g': patch 'ga' and 'gb'+# The 'b' patches depend on the 'a' patches.++rm -rf tmp1+mkdir tmp1+cd tmp1+darcs init+echo 'record no-ask-deps' >> _darcs/prefs/defaults+echo 'record ignore-times' >> _darcs/prefs/defaults+echo 'a' > f+darcs add f+darcs rec -am 'fa' f+echo 'a' > g+darcs add g+darcs rec -am 'ga' g+echo 'b' > f+darcs rec -am 'fb' f+echo 'b' > g+darcs rec -am 'gb' g+++mkdir d+darcs init --repodir d+++# Try to Send all 'b' and 'g' patches. The two 'g' patches should succeed,+# but the 'fb' patch depends on the unselected 'fa' patch, an should be+# skipped.++darcs send -o bundle -a -p '[bg]' --no-deps d+grep '^\[ga$' bundle+grep '^\[fb$' bundle && exit 1+++# Try to Push all 'b' and 'g' patches. Expect same result as for Send.++darcs push -a -p '[bg]' --no-deps d+cd d+darcs changes | grep '^  \* ga$'+darcs changes | grep '^  \* fb$' && exit 1+# stay in d !!+++# Try to Pull all 'b' and 'g' patches. Expect same result as for Send.++# already in d+rm -rf *; darcs init+darcs pull -a -p '[bg]' --no-deps ..+darcs changes | grep '^  \* ga$'+darcs changes | grep '^  \* fb$' && exit 1+cd ..+++# Try to Obliterate all 'a' and 'g' patches. The two 'g' patches should+# succeed, but the 'fa' patch depends on the unselected 'fb' patch, an+# should be skipped.++darcs get . tmp; cd tmp+echo y/y/y/q | tr / \\012 | darcs obliterate -p '[ag]' --no-deps+darcs changes | grep '^  \* gb$' && exit 1+darcs changes | grep '^  \* fa$'+cd ..+++# Try to Unrecord all 'a' and 'g' patches. Expect same result as for+# Obliterate.++# in "top" tmp repo -- destroys it!+echo y/y/y/q | tr / \\012 | darcs unrecord -p '[ag]' --no-deps+darcs changes | grep '^  \* gb$' && exit 1+darcs changes | grep '^  \* fa$'++cd ..+rm -rf tmp1
+ tests/nonewline.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1+darcs init+echo -n zig > foo+darcs add foo+sleep 1+darcs record -a -m add_foo -A x+#sleep 1+echo -n zag >> foo+darcs record --ignore-time -a -m mod_foo -A x+cd ../temp2+darcs init+darcs pull -a ../temp1+cd ..+cmp temp1/foo temp2/foo+rm -rf temp1 temp2+
+ tests/obliterate-add.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo foo > foo+darcs add foo++darcs record -a -m 'addfoo'++darcs obliterate -a++not darcs whatsnew++cd ..+rm -rf temp1
+ tests/obliterate-formerly-pl.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+# Some tests for 'darcs obliterate'++. lib++rm -rf temp1++# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++cd temp1+touch a.txt+darcs add a.txt+darcs record -a -m 'adding a' a.txt+touch b.txt+darcs add b.txt+darcs record -a -m 'adding b' b.txt+# extra confirmation for --all+echo an | darcs obliterate -p add | grep -i "really obliterate"+# --last=1+echo n  | darcs obliterate --last 1 | grep -i adding+# automatically getting dependencies+date >> a.txt+darcs record -a -m 'modifying a' a.txt+echo n | darcs obliterate -p 'adding a' > log+grep -i "modifying a" log+grep -i "No patches selected" log+cd ..+rm -rf temp1
+ tests/obliterate.sh view
@@ -0,0 +1,51 @@+#!/usr/bin/env bash+set -ev++rm -rf tempA+mkdir tempA+cd tempA+darcs initialize+echo hello world > foo+darcs add foo+darcs record -a -m hellofoo++echo goodbye world >> foo+darcs record -a -m goodbyefoo++darcs replace world bar foo+echo Hi there foo > bar+darcs add bar+darcs record -a -m addbar++darcs mv bar baz+darcs replace bar baz foo+darcs record -a -m bar2baz++echo Do not love the baz, or anything in the baz. >> foo+darcs record -a -m nolove++darcs mv baz world+darcs replace baz world foo+darcs record -a -m baz2world++darcs whatsnew | grep 'No changes'++grep 'love the world' foo++echo y | darcs obliterate -p baz2world++darcs whatsnew | grep 'No changes'++grep 'love the baz' foo++echo y | darcs obliterate -p bar2baz++grep 'love the bar' foo++echo y | darcs obliterate -p nolove++grep 'love' foo && exit 1 || true++cd ..+rm -rf tempA+
+ tests/optimize.sh view
@@ -0,0 +1,16 @@+#!/usr/bin/env bash+set -ev++# tests for "darcs optimize"++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo+darcs record -a -m add_foo+darcs optimize --reorder-patches| grep -i "done optimizing"+cd ..++rm -rf temp1
+ tests/optimize_relink.sh view
@@ -0,0 +1,59 @@++#!/usr/bin/env bash++# For issue600, testing optimize --relink ++set -ev++## We don't support hard links on Windows.++if echo $OS | grep -i windows; then+    echo darcs does not support hard links on Windows+    exit 0+fi++## compare succeeds if there are hard links+compare () {+  echo 'use File::Basename; $res=0; while ($fn=<'$1'/*>) { $fn2="'$2'/" . basename($fn); @fd1=lstat($fn); @fd2=lstat($fn2); $res += ($fd1[1] != $fd2[1]);}; exit($res);' | perl+}++rm -rf temp+mkdir temp+cd temp++mkdir x+darcs init --repodir x+cd x+date > foo+darcs add foo+darcs record -a -A me -m 'addfoo'+cd ..++## Does the filesystem support hard linking at all?+mkdir z1+echo "hi" > z1/foo+mkdir z2+if ! ln z1/foo z2/foo ; then+  echo No ln command for `pwd` - assuming no hard links.+  exit 0+fi+if ! compare z1 z2 ; then+  echo Filesystem for `pwd` does not support hard links.+  exit 0+fi+# workaround for SunOS cp which does not support `-a' option but also+# doesn't fail when it is encountered.+cp -r x y++## Now try relinking using darcs.+rm -rf z+darcs optimize --verbose --relink --repodir x --sibling y+rm -rf x/_darcs/patches/pend* y/_darcs/patches/pend*+if compare x/_darcs/patches y/_darcs/patches+then echo darcs --relink is working, hard links were done.+else echo darcs --relink is not working, it did not make any hard links.+     exit 2+fi++cd ..+rm -rf temp
+ tests/output.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2 temp3+mkdir temp2+cd temp2+darcs init+cd ..++mkdir temp1+cd temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m foobar -A author+darcs send -a --dont-edit-description -o ../temp3 ../temp2+test -f ../temp3++darcs send -a --dont-edit-description -o ../temp2/patchfile ../temp2+test -f ../temp2/patchfile++mkdir subdir+darcs send -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2+test -f ../temp2/patchfile1++cp ../temp3 correct++cd subdir+darcs send -a --dont-edit-description -o ../patchfile ../../temp2+diff -u ../patchfile ../correct++rm ../patchfile+darcs send -a --dont-edit-description -o - ../../temp2 > ../patchfile+grep -v Creating ../patchfile | diff -u ../correct -++darcs apply --repodir=../../temp2 --dry-run ../patchfile > out+cat out+grep foobar out++cd ../..++cd temp2++darcs apply --dry-run ../temp3 > out+cat out+grep foobar out++darcs apply --dry-run ../temp1/correct > out+cat out+grep foobar out++darcs apply --dry-run ../temp1/patchfile > out+cat out+grep foobar out++darcs apply --dry-run ../temp3 > out+cat out+grep foobar out++darcs apply --dry-run ../temp3 > out+cat out+grep foobar out++cd ..++rm -rf temp1 temp2 temp3+
+ tests/overriding-defaults.sh view
@@ -0,0 +1,61 @@+#!/usr/bin/env bash++. lib++rm -rf temp+mkdir temp+cd temp+darcs init+darcs setpref test false+darcs record --no-test -a -m 'add failing test'++# should pass with --no-test+darcs check --no-test++# should fail when test is run+not darcs check --test++# should pass with --no-test in defaults+echo check --no-test > _darcs/prefs/defaults+darcs check+not darcs check --test++# should fail with --test in defaults+echo check --test > _darcs/prefs/defaults+not darcs check+darcs check --no-test++# check global defaults+cp ~/.darcs/defaults defaults.backup+trap "cp defaults.backup ~/.darcs/defaults" EXIT+rm _darcs/prefs/defaults++# --no-test works in global defaults+echo check --no-test > ~/.darcs/defaults+darcs check+not darcs check --test++# --test works in global defaults+echo check --test > ~/.darcs/defaults+not darcs check+darcs check --no-test++# Verify that per-repository defaults override global defaults++# --no-test in repository defaults overrides global --test+echo check --test > ~/.darcs/defaults+echo check --no-test > _darcs/prefs/defaults+darcs check+not darcs check --test++# --test in repository defaults overrides global --no-test+echo check --no-test > ~/.darcs/defaults+echo check --test > _darcs/prefs/defaults+not darcs check+darcs check --no-test++trap - EXIT+cp defaults.backup ~/.darcs/defaults++cd ..+rm -rf temp
+ tests/partial.sh view
@@ -0,0 +1,60 @@+#!/usr/bin/env bash++# A partial get of a repo shall have the same _darcs/pristine as the original++set -ev++rm -rf temp+mkdir temp+cd temp++# Create a development repo, do some work++darcs initialize --darcs-2+echo ALL ignore-times >> _darcs/prefs/defaults+touch a+darcs add a+darcs record -a -m aa -A x+touch b+darcs add b+darcs record -a -m bb -A x++# Create a release repo, pull the good patches and tag it++mkdir _rel+cd _rel+darcs initialize --darcs-2 +darcs pull -a --patch a ..+darcs tag -m tt -A x+cd ..++# Pull the tag to the devel repo and continue developement++darcs pull -a _rel+touch c+darcs add c+darcs record -a -m cc -A x++# Create a checkpoint and get a partial temp repo++darcs tag -A x --checkpoint first_checkpoint +darcs get --partial . _partial++# We should have all our devel files++cd _partial+cat a+cat b+cat c++# This is a regression test for issue406+darcs tag -A x --checkpoint checkpointing_a_partial++cd ..++# With the darcs-2 format, doing a get on a partial repo succeeds.+# With the darcs-1 format it would be required to add the --partial flag, or darcs would give an error. +darcs get _partial _second_partial++cd ..+rm -rf temp
+ tests/pending.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp_0+mkdir temp+cd temp+darcs init+date > bla+darcs add bla+darcs record -a --patch-name=11+echo hello > world+darcs add world+darcs whatsnew --dont-look-for-adds > wn1+cd ..+darcs get temp+cd temp_0+date > bla2+date >> bla+darcs add bla2+darcs record -a --patch-name=22+darcs push -a ../temp+cd ..+cd temp+darcs whatsnew --dont-look-for-adds > wn2+diff wn1 wn2++darcs record -a -m 'cleaning up for new test.'+date > foo.jpg+darcs add foo.jpg+darcs whatsnew++darcs remove foo.jpg+darcs whatsnew && exit 1++cd ..++rm -rf temp temp0
+ tests/pending_has_conflicts.sh view
@@ -0,0 +1,62 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++date > date.t+date > date_moved.t++write_buggy_pending () {+cat > _darcs/patches/pending <<EOF+{+addfile ./date.t+addfile ./date_moved.t+move ./date.t ./date_moved.t+}+EOF+}+write_buggy_pending++echo now watch the fireworks as all sorts of things fail+not darcs whatsnew &> out+cat out+grep 'pending has conflicts' out++echo pending should now be fixed but there are no changes+not darcs whatsnew++write_buggy_pending++darcs revert -a &> out+cat out+grep 'pending has conflicts' out++echo pending should now be emptied+darcs revert -a++write_buggy_pending++darcs record -a -m foo &> out+cat out+grep 'pending has conflicts' out++darcs record -a -m foo++darcs changes -v++darcs repair &> out+cat out+grep 'The repository is already consistent' out++write_buggy_pending++darcs repair &> out+cat out+grep 'The repository is already consistent' out++cd ..+rm -rf temp1
+ tests/perms.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash+set -ev++uname | grep "MINGW" > /dev/null && exit 0++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo record author me > _darcs/prefs/defaults+echo ALL all >> _darcs/prefs/defaults+echo ALL verbose >> _darcs/prefs/defaults+echo ALL ignore-times >> _darcs/prefs/defaults+touch foo+darcs add foo+darcs record -m add_foo+echo hello >> foo+darcs record -m mod_foo+cd ..+darcs get --repo-name temp2 temp1+cd temp2+cp ../temp1/_darcs/prefs/defaults _darcs/prefs+echo y/d/y | tr / \\012 | darcs unpull --interactive+test -f foo -a ! -s foo+chmod +x foo+test -x foo+darcs pull ../temp1+test -x foo+cd ..+rm -rf temp1 temp2+
+ tests/posthook.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash++set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo++# Check that posthook works...+darcs whatsnew -s --posthook 'touch posthook-ran'+test -f posthook-ran+rm posthook-ran++# Check that posthook works with defaults...+echo ALL --posthook touch posthook-ran > _darcs/prefs/defaults+darcs whatsnew -s+test -f posthook-ran+rm posthook-ran++echo Successful.++cd ..+rm -rf temp1
+ tests/prefs.sh view
@@ -0,0 +1,16 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs initialize --old-fashion+echo ALL ignore-times >> _darcs/prefs/defaults+cp _darcs/prefs/boring .boring+darcs add .boring+darcs setpref boringfile .boring+darcs record -a -m p1 -A me+cd ..+darcs get --hashed temp1 temp2+cmp temp1/_darcs/prefs/prefs temp2/_darcs/prefs/prefs+rm -rf temp1 temp2
+ tests/prefs_binary.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash++# Test that _darcs/prefs/binaries+. lib+rm -rf temp1++mkdir temp1+cd temp1+darcs init+mkdir d+touch d/t.t+darcs add d/t.t+darcs record -am "initial record"+echo 'some change' >> d/t.t+echo n | darcs record --interactive > log+# pre-test: plain text files are not binary+not grep binary log+echo 'd/t' >>  _darcs/prefs/binaries+echo n | darcs record --interactive > log+grep binary log+cd ..++rm -rf temp1
+ tests/prehook.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo++# Check that prehook runs+darcs whatsnew -s --prehook 'touch prehook-ran'+test -f prehook-ran+rm prehook-ran++# Check that --prehook works with defaults...+echo ALL --prehook touch prehook-ran > _darcs/prefs/defaults+darcs whatsnew -s+test -f prehook-ran+rm prehook-ran+++echo Successful.++cd ..+rm -rf temp1
+ tests/printer.sh view
@@ -0,0 +1,83 @@+#!/usr/bin/env bash++# Some tests for 'darcs printer (the output formating)'++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch a+darcs add a+darcs rec -a -m add++env+# clear all output formating environment variables+for e in DARCS_DONT_ESCAPE_ISPRINT DARCS_USE_ISPRINT\+         DARCS_DONT_ESCAPE_8BIT\+         DARCS_DONT_ESCAPE_EXTRA DARCS_ESCAPE_EXTRA\+         DARCS_DONT_ESCAPE_TRAILING_SPACES\+         DARCS_DONT_COLOR DARCS_ALWAYS_COLOR DARCS_ALTERNATIVE_COLOR\+         DARCS_DONT_ESCAPE_ANYTHING; do+    unset $e+done+env++# make sure the locale is c+export LC_ALL=C++test_line () {+    rm -f a+    echo $1 > a+    darcs whatsnew | fgrep $2+}+++# First check escaping and coloring.  Use whatsnew, since that is the+# most common use of escapes.++# test the defaults+# - no color to pipe+# - don't escape 7-bit ASCII printables, \n,\t and space (we can't test \n)+# - escape control chars with ^+# - escape other chars with \xXX+test_line " !#%&',-0123456789:;<=>"\+          " !#%&',-0123456789:;<=>"+test_line "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"\+          "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"+test_line "\`abcdefghijklmnopqrstuvwxyz"\+          "\`abcdefghijklmnopqrstuvwxyz"+test_line "\t\"\$()*+./?\@[\\]^{|}"\+          "\t\"\$()*+./?\@[\\]^{|}"+# skip ^@ and ^Z since they make darcs treat the file as binary+# don't put any space control chars at end of line+# ascii control chars are escaped with ^+test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0D\x0E')\+          '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^M_][_^N_]'+test_line $(printf '\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19')\+          '[_^O_][_^P_][_^Q_][_^R_][_^S_][_^T_][_^U_][_^V_][_^W_][_^X_][_^Y_]'+test_line $(printf '\x1B') '[_^[_]'+test_line $(printf '\x1C') '[_^\_]'+test_line $(printf '\x1D') '[_^]_]'+test_line $(printf '\x1E') '[_^^_]'+test_line $(printf '\x1F') '[_^__]'+test_line $(printf '\x7F') '[_^?_]'+# other chars are escaped with \xXX+test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\+          '[_\80_][_\81_][_\82_][_\83_][_\84_][_\85_][_\86_][_\87_][_\88_][_\89_][_\8a_][_\8b_][_\8c_][_\8d_][_\8e_][_\8f_]'+test_line $(printf '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F')\+          '[_\90_][_\91_][_\92_][_\93_][_\94_][_\95_][_\96_][_\97_][_\98_][_\99_][_\9a_][_\9b_][_\9c_][_\9d_][_\9e_][_\9f_]'+test_line $(printf '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF')\+          '[_\a0_][_\a1_][_\a2_][_\a3_][_\a4_][_\a5_][_\a6_][_\a7_][_\a8_][_\a9_][_\aa_][_\ab_][_\ac_][_\ad_][_\ae_][_\af_]'+test_line $(printf '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF')\+          '[_\b0_][_\b1_][_\b2_][_\b3_][_\b4_][_\b5_][_\b6_][_\b7_][_\b8_][_\b9_][_\ba_][_\bb_][_\bc_][_\bd_][_\be_][_\bf_]'+test_line $(printf '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF')\+          '[_\c0_][_\c1_][_\c2_][_\c3_][_\c4_][_\c5_][_\c6_][_\c7_][_\c8_][_\c9_][_\ca_][_\cb_][_\cc_][_\cd_][_\ce_][_\cf_]'+test_line $(printf '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF')\+          '[_\d0_][_\d1_][_\d2_][_\d3_][_\d4_][_\d5_][_\d6_][_\d7_][_\d8_][_\d9_][_\da_][_\db_][_\dc_][_\dd_][_\de_][_\df_]'+test_line $(printf '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF')\+          '[_\e0_][_\e1_][_\e2_][_\e3_][_\e4_][_\e5_][_\e6_][_\e7_][_\e8_][_\e9_][_\ea_][_\eb_][_\ec_][_\ed_][_\ee_][_\ef_]'+test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\+          '[_\f0_][_\f1_][_\f2_][_\f3_][_\f4_][_\f5_][_\f6_][_\f7_][_\f8_][_\f9_][_\fa_][_\fb_][_\fc_][_\fd_][_\fe_][_\ff_]'+rm -rf temp1
+ tests/pull-dont-prompt-deps.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash++set -ev++# Check that the right patches get pulled using --dont-prompt-for-dependencies++rm -rf temp1+rm -rf temp2+mkdir temp2+mkdir temp1+cd temp2+darcs init+cd ..+cd temp1+darcs init+echo foo > f+darcs record -Ax -alm foo1+echo bar > b+darcs rec -Ax -alm bar1+echo foo2 > f+darcs record -Ax -alm foo2+echo bar2 > b+darcs record -Ax -alm bar2+cd ../temp2+echo y | darcs pull ../temp1 --dont-prompt-for-dependencies -p foo2 --dry-run > toto+#on the previous line, we don't get asked about foo1.+grep foo toto | wc -l | grep 2+#but we send it anyway.+grep bar toto | wc -l | grep 0+cd ..+rm -rf temp1 temp2
+ tests/pull-union.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++. lib++# This test script is in the public domain.+++rm -rf temp1 temp2 temp3++mkdir temp1+cd temp1+darcs initialize+echo A > A+darcs add A+darcs record -a -m A+echo B > B+darcs add B+darcs record -a -m B++cd ..+darcs get temp1 temp2++cd temp2+darcs obliterate --last 1 -a+echo C > C+darcs add C+darcs record -a -m C+cd ..++mkdir temp3+cd temp3+darcs init+darcs pull -a -v ../temp1 ../temp2++darcs changes > out+cat out+grep A out+grep B out+grep C out+cd ..++rm -rf temp1 temp2 temp3
+ tests/pull.sh view
@@ -0,0 +1,154 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2++mkdir temp1+cd temp1+darcs init++cd ..+mkdir temp2+cd temp2+darcs init++mkdir one+cd one+mkdir two+cd two+echo darcs pull should work relative to the current directory+darcs pull -a ../../../temp1 | grep -i 'No remote changes to pull in'++echo -- darcs pull should pull into repo specified with --repo+cd ../..  # now in temp2+darcs add one;+darcs record --patch-name uno --all+cd ..     # now outside of any repo+darcs pull --repodir temp1 --all temp2 | grep -i 'Finished pulling.' # temp2 is not relative to temp1++# set up server repo+date > temp2/one/date.t+darcs add --repodir ./temp2 one/date.t+darcs record --repodir ./temp2 -a -m foo++# set up client repo for failure+if echo $OS | grep -i windows; then+    echo this test does not work on windows because it+    echo is not possible to chmod -r+elif whoami | grep root; then+    echo root never gets permission denied+else+    chmod a-rwx ./temp1/one # remove all permissions+    not darcs pull --repodir ./temp1 -a 2> err+    chmod u+rwx temp1/one # restore permission+    cat err+    grep 'permission denied' err+    rm -rf temp1/one+fi++cd temp1++echo Before trying to pull from self, defaultrepo is something else+not grep temp1 _darcs/prefs/defaultrepo++#return special message when you try to pull from yourself+DIR="`pwd`"+not darcs pull --debug -a "$DIR" 2> out+cat out+grep 'Can.t pull from current repository' out++not darcs pull --debug -a . 2> out+cat out+grep 'Can.t pull from current repository' out++# and do not update the default repo to be the current di+not grep temp1 _darcs/prefs/defaultrepo++rm -f _darcs/prefs/defaultrepo+not darcs pull 2> err+grep 'please specify one' err+echo . > _darcs/prefs/defaultrepo+not darcs pull --debug 2> err+grep 'Can.t pull from current repository' err++not darcs pull --debug ../* 2> out+cat out+not grep 'Can.t pull from current repository' out+cd .. # now outside of any repo++cd temp1+echo a > foo+darcs record -lam AA+echo b > foo+darcs record -lam BB+echo c > foo+darcs record -lam CC+darcs rollback -p CC -a -m unC+cd ..+rm -rf temp2+darcs get --to-patch B temp1 temp2+cd temp2+sleep 1 # So that rollback won't have same timestamp as get.+darcs rollback -p BB -a -m unB+darcs revert -a+darcs pull -a ../temp1 2> err2+not grep 'Error applying patch' err2+cd ..++cd temp1+echo -n foo > baz+darcs add baz+darcs record  -am newbaz+cd ../temp2+darcs pull -a | grep Finished+echo -n bar > baz+darcs record  -am bazbar+cd ../temp1+darcs pull ../temp2 -a+echo -n bar > correct_baz+diff baz correct_baz+cd ..++#   my $test_name = "when a patch creating a directory is attempted to be applied+#       while a directory with that name already exists, a warning is raised, but+#       the pull succeeds.";+mkdir temp1/newdir+cd temp1+darcs add newdir+darcs record -am newdir+cd ../temp2+mkdir newdir+darcs pull -a ../temp1 &> out2+cat out+grep Backing out2+grep 'Finished pulling' out2+grep newdir out2+cd ..++rm -rf temp1 temp2+++# A test for issue662, which triggered:+#  darcs failed:  Error applying hunk to file ./t.t+#  Error applying patch to the working directory.++rm -rf tmp;+darcs init --hashed --repodir=tmp+touch tmp/t.t+cd tmp+darcs add t.t+echo 'content'>t.t+darcs record -am 'initial add' --ignore+echo 'content: remote change'>t.t+darcs record -am 'remote change' --ignore+darcs put tmp2+cd tmp2+darcs obliterate --last 1 --all;+echo 'content: local change'> t.t+darcs pull -a ../+darcs w -s+darcs revert -a++cd ../..+rm -rf tmp
+ tests/pull_binary.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++# This test script, originally written by David Roundy and Ian Lynagh is in+# the public domain.++set -ev++rm -rf temp1 temp2++mkdir temp1+cd temp1+darcs init+printf "%01048576d" 0 > foo+darcs record -l -a -A author -m xx+rm foo+darcs record -a -A author -m yy+cd ..++mkdir temp2+cd temp2+darcs init+echo yn | darcs pull ../temp1+rm foo+darcs pull -a+cd ..++rm -rf temp1 temp2
+ tests/pull_compl.sh view
@@ -0,0 +1,121 @@+#!/usr/bin/env bash++# This test script is in the public domain.++set -ev++rm -rf temp1 temp2 temp3 temp4 temp5++mkdir temp1+cd temp1+cat > foo <<EOF+line1+line2+line3+line4+line5+line6+line7+EOF+darcs initialize+darcs add foo+darcs record -a -m addfoo++cd ..+darcs get temp1 temp4++chgrec () {+    set -ev+    sed -e "$1" foo > foo.tmp+    mv foo.tmp foo+    darcs record -a --ignore-times -m "$2"+}++cd temp1+chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2+chgrec 's/line4/Line 4/' Line4++darcs changes | grep ' \*'+echo done with changes on temp1 > /dev/null++cd ..+darcs get temp1 temp2+darcs get temp1 temp3+cd temp1++chgrec 's/line1/line0\nline1/' line0+chgrec 's/Line 4/LINE FOUR/' LINE4+chgrec 's/line7/line7\nLastLine/' LastLine+chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1++darcs changes | grep ' \*'+echo done with changes on temp1 > /dev/null++cd ../temp3+darcs pull -p LastLine -av+chgrec 's/line1$/FirstLine/' FirstLine++cd ../temp4++darcs changes | grep ' \*'+echo done with changes on temp4 > /dev/null++darcs pull ../temp1 --dry-run | grep ' \*'+darcs pull ../temp1 --dry-run | grep ' \*' > p1.out+cat > p1.req <<EOF+  * inssub2+  * Line4+  * line0+  * LINE4+  * LastLine+  * line4.1+EOF+diff p1.req p1.out++darcs pull ../temp1 --dry-run --complement | grep ' \*' > p2.out+diff p1.out p2.out++darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out+cat > p3.req <<EOF+  * line0+  * LastLine+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp3 | grep ' \*' > p4.out+cat > p4.req <<EOF+  * line0+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 | grep ' \*' > p5.out+diff p4.out p5.out++darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out+diff p4.out p6.out++darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out+cat > p7.req <<EOF+  * LastLine+EOF++darcs pull --dry-run --complement ../temp2 ../temp3 > p8.out+grep "No remote changes to pull in!" p8.out++# because duplicates are stripped before performing action,+# this is the same as: darcs pull ../temp1+darcs pull --dry-run --complement ../temp1 ../temp1 > fooout+cat fooout+grep ' \*' fooout > p9.out+diff p1.req p9.out++# so the "null" pull must be tested this way:+darcs get ../temp1 ../temp5+darcs pull --dry-run --complement ../temp1 ../temp5 > p9.out+grep "No remote changes to pull in!" p9.out++darcs pull -av --complement ../temp1 ../temp3+darcs check++cd ..+rm -rf temp1 temp2 temp3 temp4 temp5
+ tests/pull_many_files.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2++if grep old-fashioned .darcs/defaults; then+format=old-fashioned-inventory+elif grep darcs-2 .darcs/defaults; then+format=darcs-2+else format=hashed; fi++mkdir temp2+cd temp2+gunzip -c ../repos/many-files--${format}.tgz | tar xf -+cd ..++mkdir temp1+cd temp1+darcs init+darcs pull -a ../temp2/many-files--${format} > log+grep -i 'finished pulling' log+cd ..+rm -rf temp1++# put things back how we found them.++rm -rf temp1 temp2
+ tests/pull_two.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++# This test script, originally written by David Roundy is in the public+# domain.++set -ev++rm -rf temp1 temp2++mkdir temp1+cd temp1+echo foo > bar+darcs initialize+echo record author me > _darcs/prefs/defaults+darcs add bar+darcs record -a -m addbar++cd ..+darcs get temp1 temp2+cd temp1+date > bar+darcs record -a -m datebar++cd ../temp1+echo aack >> bar+darcs record -a -m aackbar++cd ../temp2++darcs pull -av+darcs check++cd ..+rm -rf temp1 temp2
+ tests/push-dont-prompt-deps.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++set -ev++# Check that the right patches get pushed using --dont-prompt-for-dependencies++rm -rf temp1+rm -rf temp2+mkdir temp2+mkdir temp1+cd temp2+darcs init+cd ..+cd temp1+darcs init+echo foo > f+darcs record -Ax -alm foo1+echo bar > b+darcs rec -Ax -alm bar1+echo foo2 > f+darcs record -Ax -alm foo2+echo bar2 > b+darcs record -Ax -alm bar2+echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto+#on the previous line, we don't get asked about foo1.+grep foo toto | wc -l | grep 2+#but we send it anyway.+grep bar toto | wc -l | grep 0+cd ..+rm -rf temp1 temp2
+ tests/push-dry-run.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+set -ev++# For issue855: wish: avoid taking lock if using --dry-run+chmod -R u+w temp2 || :+rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+cd ..+mkdir temp2+cd temp2+darcs init+touch x+darcs add x+darcs record -am "test"+cd ..+chmod -R u-w temp2+cd temp2+# need to capture this failure so that we can still+# chmod -R u+w the directory even if we fail+darcsexit=0+darcs push --dry-run ../temp1 || darcsexit=$?+cd ..+chmod -R u+w temp2 # so that other scripts can cleanup+if [ $darcsexit -ne 0 ]; then+  exit $darcsexit+fi
+ tests/push-formerly-pl.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash++# Some tests for 'darcs push'++. lib++DIR="`pwd`"++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+cd ..+mkdir temp2+cd temp2+darcs init+cd ..++# push without a repo gives an error+cd temp1+not darcs push -p 123 2> log+grep -i 'missing argument' log+cd ..++mkdir -p temp2/one/two+cd temp2/one/two+# darcs push should work relative to the current directory+darcs push -a ../../../temp1 | grep -i 'No recorded local changes to push'+cd ../../../++# darcs push should push into repo specified with --repo+cd temp2+darcs add one+darcs record --patch-name uno --all+cd ..++darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply'++cd temp1+# Before trying to pull from self, defaultrepo does not exist+test ! -e _darcs/prefs/defaultrepo+# return special message when you try to push to yourself+not darcs push -a "$DIR/temp1" 2> log+grep -i "cannot push from repository to itself" log+# and don't update the default repo to be the current dir+test ! -e _darcs/prefs/defaultrepo+cd ..++rm -rf temp1 temp2
+ tests/push.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp_0+mkdir temp+cd temp+darcs init+echo tester > _darcs/prefs/author+date > bla+darcs add bla+darcs record -a --patch-name=11+cd ..+darcs get temp+cd temp+date > bla2+darcs add bla2+darcs record -a --patch-name=22+darcs push -a ../temp_0+cd ..++rm -rf temp temp_0
+ tests/push_lock.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash++# For issue257: push => incorrect return code when couldn't get lock++set -ev++rm -rf tempc+mkdir tempc+cd tempc+darcs init+echo foo > foo.c+darcs rec -Ax -alm init+cd ..+rm -rf temps+darcs get tempc temps+cd temps+echo server >> foo.c+darcs rec -Ax -alm server+cd ../tempc+echo client >> foo.c+darcs rec -Ax -alm client+if darcs push -a ../temps; then+        false+fi+cd ..+rm -rf tempc temps
+ tests/put.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+cd ..++# put should set default repo+cd temp1+touch 1.txt+darcs add 1.txt+darcs record -a -m foo 1.txt+darcs put ../temp2+test -e _darcs/prefs/defaultrepo+grep temp2 _darcs/prefs/defaultrepo+cd ..++# put to self+cd temp1+not grep temp1 _darcs/prefs/defaultrepo+DIR=`pwd`+# return special message when you try to put put yourself+not darcs put "$DIR" 2> log+not grep temp1 _darcs/prefs/defaultrepo+grep -i "Can't put.*current repository" log+cd ..++rm -rf temp1 temp2
+ tests/query_manifest.sh view
@@ -0,0 +1,90 @@+#!/usr/bin/env bash+set -ev++check_manifest () {+    : > files.tmp+    echo . > dirs.tmp+    echo . > files-dirs.tmp+    for x in $1 ; do+	echo "./$x" >> files.tmp+	echo "./$x" >> files-dirs.tmp+    done+    for x in $2 ; do+	echo "./$x" >> dirs.tmp+	echo "./$x" >> files-dirs.tmp+    done+    darcs query manifest $3 --files --no-directories | sort > darcs-files.tmp+    darcs query manifest $3 --no-files --directories | sort > darcs-dirs.tmp+    darcs query manifest $3 --files --directories | sort > darcs-files-dirs.tmp+    for x in files dirs files-dirs ; do+        sort $x.tmp >sorted-$x.tmp+        diff sorted-$x.tmp darcs-$x.tmp+    done }++rm -rf temp+mkdir temp+cd temp+darcs init++check_manifest "" "" "--no-pending"+check_manifest "" "" "--pending"+touch a b+darcs add a+check_manifest "" "" "--no-pending"+check_manifest "a" "" "--pending"+darcs add b+mkdir c+check_manifest "" "" "--no-pending"+check_manifest "a b" "" "--pending"+darcs add c+touch c/1 c/2+check_manifest "" "" "--no-pending"+check_manifest "a b" "c" "--pending"+darcs add c/1 c/2+check_manifest "" "" "--no-pending"+check_manifest "a b c/1 c/2" "c" "--pending"+mkdir d+touch d/3 d/4+darcs add d/3 d/4+check_manifest "" "" "--no-pending"+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"+darcs record -A test --all --patch-name "patch 1" --skip-long-comment+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"++darcs mv d e+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"+rm c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"+darcs remove c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/2 e/3 e/4" "c e" "--pending"+darcs mv c/2 c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 e/3 e/4" "c e" "--pending"+darcs record -A test --all --patch-name "patch 2" --skip-long-comment+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b c/1 e/3 e/4" "c e" "--pending"++darcs remove c/1+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b e/3 e/4" "c e" "--pending"+darcs remove c+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b e/3 e/4" "e" "--pending"+darcs record -A test --all --patch-name "patch 3" --skip-long-comment+check_manifest "a b e/3 e/4" "e" "--no-pending"+check_manifest "a b e/3 e/4" "e" "--pending"++darcs mv b b2+darcs mv b2 b3+check_manifest "a b e/3 e/4" "e" "--no-pending"+check_manifest "a b3 e/3 e/4" "e" "--pending"+darcs record -A test --all --patch-name "patch 3" --skip-long-comment+check_manifest "a b3 e/3 e/4" "e" "--no-pending"+check_manifest "a b3 e/3 e/4" "e" "--pending"++cd ..+rm -rf temp
+ tests/record-interactive.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++. lib+++rm -rf temp1+mkdir temp1+cd temp1+darcs init++touch foo+darcs add foo+darcs record -a -m addfoo++darcs replace one two foo+darcs replace three four foo+darcs replace five six foo++echo sa | darcs record -m cancelled++darcs whatsnew++darcs changes > ch+not grep cancelled ch++cd ..+rm -rf temp1
+ tests/record.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash++# Some tests for 'darcs record '++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++# issue308 - no patches and no deps for record should abort+darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!"++# RT#476 - --ask-deps works when there are no patches+if echo $OS | grep -i windows; then+  echo This test does not work on Windows+else+  touch t.f+  darcs add t.f+  darcs record  -am add+  echo a | darcs record  -am foo --ask-deps | grep -i 'finished recording'+fi++# RT#231 - special message is given for nonexistent directories+not darcs record -am foo not_there.txt > log+grep -i 'non existent' log++# RT#231 - a nonexistent file before an existing file is handled correctly+touch b.t+darcs record  -am foo a.t b.t > log+grep -i 'non existent files or directories: "a.t"' log++DIR="`pwd`"+touch date.t+darcs add date.t+darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording'++# issue396 - record -l ""+touch 'notnull.t'+darcs record  -am foo -l "" notnull.t | grep -i 'finished recording'++# basic record+date >> date.t+darcs record -a -m basic_record date.t | grep -i 'finished recording'++# testing --logfile+date >> date.t+echo "second record\n" >> log.txt+darcs record  -a -m 'second record' --logfile=log.txt  date.t | grep -i 'finished recording'++cd ..+rm -rf temp1
+ tests/record_editor.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash++# Some tests for 'darcs rec --edit-long-comment'++. lib++abort_windows++rm -rf temp1++export DARCS_EDITOR="/bin/cat -n"+# editor: space in command+mkdir temp1+cd temp1+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'+cd ..+rm -rf temp1++# editor: space in path+mkdir temp2\ dir+cd temp2\ dir+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'+cd ..+rm -rf temp2\ dir++export DARCS_EDITOR='grep "END OF"'+# editor: quoting in command+mkdir temp1+cd temp1+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep 'END OF'+cd ..+rm -rf temp1++export DARCS_EDITOR='/bin/echo'+# editor: evil filename+mkdir temp1+cd temp1+darcs init+touch file.t+darcs add file.t+touch '; test-command'+echo > test-command << FOO+#!/bin/sh+echo EVIL+FOO+chmod u+x test-command+echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log+not grep EVIL log+cd ..+rm -rf temp1
+ tests/recordrace.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+set -ev++rm -rf foo1 foo2+mkdir foo1 foo2+cd foo1+darcs init+echo zig > foo+darcs add foo+sleep 1+darcs record -a -m add_foo -A x+#sleep 1+echo zag >> foo+darcs record --ignore-time -a -m mod_foo -A x+cd ../foo2+darcs init+darcs pull -a ../foo1+cd ..+cmp foo1/foo foo2/foo+rm -rf foo1 foo2+
+ tests/repair-clean.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1++darcs init+touch baz+darcs add baz+darcs record -m moo -a++cat _darcs/patches/pending++darcs changes -v++darcs check++# check that repair doesn't do anything to a clean repository+darcs repair > out+cat out+grep 'already consistent' out++cd ..+rm -rf temp1
+ tests/repair-corrupt.sh view
@@ -0,0 +1,53 @@+. lib++rm -rf bad+mkdir bad+cd bad+darcs init++echo foo > bar+darcs add bar+darcs rec -a -m 'foo'++echo hey > foo+darcs add foo+darcs rec -a -m 'more foo'++hashed=false+test -e _darcs/hashed_inventory && hashed=true++# produce a corrupt patch+echo 'rmfile foo' > _darcs/patches/pending+$hashed || echo -n > _darcs/pristine/foo+darcs rec -a -m 'remove foo'++not darcs check # unapplicable patch!++# stash away contents of _darcs+cp -R _darcs/ _backup_darcs++echo here > bar+darcs rec -a -m 'here'++# corrupt pristine content+$hashed && inv=`grep ^pristine _darcs/hashed_inventory`+cp _backup_darcs/patches/* _darcs/patches/+cp _backup_darcs/*inventory* _darcs/+$hashed && {+    cp _darcs/hashed_inventory hashed.tmp+    sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory+    rm hashed.tmp+}++not darcs check # just a little paranoia++darcs repair # repair succeeds+darcs check # and the resulting repo is consistent++# *AND* it contains what we expect...+darcs show contents bar > foobar+echo foo > foobar1+diff foobar foobar1++cd ..+rm -rf bad
+ tests/repair.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs initialize+echo ALL ignore-times >> _darcs/prefs/defaults+echo A1 > foo+mkdir d+echo A2 > d/bar+darcs add foo+darcs add d+darcs add d/bar+darcs record -a -m AA -A x+echo B > foo+darcs record -a -m BB -A x+echo C > foo+darcs record -a -m CC -A x++for i in _darcs/pristine*; do+  echo Empty the pristine directory: $i+  rm -rf $i+  mkdir $i+done++darcs repair++cd ..+rm -rf temp1
+ tests/replace.sh view
@@ -0,0 +1,61 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init++echo "X X X" > foo+echo $'A A,A\tA,A\vA' >> foo+darcs rec -alm "Added"++# These should fail until replace handles tokens and+# token-chars with leteral spaces in them+darcs replace ' X ' ' XX ' --token-chars '[ X]' foo && exit 1 || true+darcs replace $'A A'  'aaa' --token-chars '[^,]' foo && exit 1 || true+darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo && exit 1 || true+darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo && exit 1 || true++# Check that replace is not fooled by duplicate file names+# (i.e. not trying to performe the replace twice in the same file)+darcs replace X Y foo foo+darcs replace Y Z foo ../temp/foo+darcs replace Z Q foo foo --repodir=../temp/+darcs rec -am "xyzq"+++# Try to "overwrite" a hunk with a replace.+#+# v1.0.8 accepts this without error or warning,+# but should perhaps require the --force option?+#+# current unstable sometimes(!) fails with bug: invalid pending+# which is surely a bug.++# this succeeds+echo "x" > foo+darcs rec -am xx+echo "y" > foo+darcs replace --ignore-times x y foo++# this fails+echo "hej" > foo+darcs rec -am hej+echo "hopp" > foo+darcs replace hej hopp foo++darcs whatsnew++echo "src" > foo+echo "dst" >> foo+darcs rec -am hop+darcs replace src dst foo || true+darcs replace --force src dst foo++darcs whatsnew+darcs whatsnew -ls++cd ..+rm -rf temp
+ tests/replace_after_pending_add.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash++set -ev++rm -fr temp1++mkdir temp1+cd temp1+darcs --version++darcs init++echo a b a b a b > A+darcs add A+if darcs replace a c A | grep Skipping; then+    exit 1+fi+cd ..++rm -fr temp1+
+ tests/replace_after_pending_mv.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash++set -ev++rm -fr temp1++mkdir temp1+cd temp1+darcs init++echo a b a b a b > A+darcs add A+darcs record --all --patch-name=p1+darcs mv A B+if darcs replace a c B | grep Skipping; then+    exit 1+fi+cd ..++rm -fr temp1+
+ tests/repodir.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+### http://bugs.darcs.net/issue496+### _darcs/prefs/defaults ignored when using --repodir++## All these commands SHOULD fail (hence leading NOTs).+. lib++rm -rf temp+mkdir temp+cd temp++mkdir repo+darcs initialize --repodir repo+cd repo+date > foo+darcs add foo+darcs record -a -m auth++echo > _darcs/prefs/defaults ALL disable # try to disable all+not darcs changes+not darcs changes --repodir "`pwd`"++cd ..++not darcs changes --repodir repo+not darcs changes --repodir "`pwd`/repo"++rm -rf temp
+ tests/repoformat.sh view
@@ -0,0 +1,14 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs  init+echo gobbledygook > _darcs/format+cd ..++not darcs get temp1 temp2 2> log+grep -i "can't understand repository format" log+rm -rf temp1 temp2 log
+ tests/repos/README view
@@ -0,0 +1,4 @@++Larger or more complex pre-built repos are stored here for testing. They are+stored as archives for space efficiency, and to emphasize that they are meant+to be read-only.
+ tests/repos/many-files--darcs-2.tgz view

binary file changed (absent → 250790 bytes)

+ tests/repos/many-files--hashed.tgz view

binary file changed (absent → 169112 bytes)

+ tests/repos/many-files--old-fashioned-inventory.tgz view

binary file changed (absent → 87207 bytes)

+ tests/repos/maybench-crc.tgz view

binary file changed (absent → 114197 bytes)

+ tests/revert_interactive.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo hello world > foo+darcs add foo+darcs record -a -m add -A x+echo goodbye world >> foo+echo y/y | tr / \\012 | darcs revert+darcs show contents foo | cmp foo -++# Now let's test a trickier revert where changes commute nontrivially.++cat > foo <<EOF+a+b+c+d+e+EOF++darcs record -a -A me -m cleanup++mv foo foo.tmp+cat foo.tmp | grep -v b | grep -v d > foo++echo "nyy" | darcs revert++DARCS_DONT_COLOR=1 darcs wh > whatsnew+cat > correct <<EOF+hunk ./foo 2+-b+EOF+diff -c correct whatsnew++# Try a situation where earlier (kept) changes are depended upon by the+# changes we want to revert:++darcs record -a -A me -m cleanup++echo hello world > bar+echo hello world > foo+darcs add bar+darcs replace hello goodbye bar foo++echo "cnnnyy/y" | tr / \\012 | darcs revert++DARCS_DONT_COLOR=1 darcs wh > whatsnew+cat > correct <<EOF+addfile ./bar+hunk ./bar 1++goodbye world+hunk ./foo 1+-a+-c+-d+-e++hello world+EOF+diff -c correct whatsnew++cd ..+rm -rf temp1+
+ tests/revert_unrecorded_add.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init++echo stuff > foo+darcs add foo++darcs revert -a
+ tests/rmconflict.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash+set -ev++rm -rf tempA tempB+mkdir tempA tempB+cd tempA+darcs init+touch foo+darcs add foo+darcs record -a -m addA -A x+cd ../tempB+darcs init+darcs pull -a ../tempA+darcs remove foo+# rm foo+darcs record -a -m rmB -A x+cd ../tempA+darcs remove foo+darcs record -a -m rmA -A x+cd ../tempB+darcs pull -a ../tempA+cd ..+rm -rf tempA tempB+
+ tests/rmdir-formerly-pl.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+mkdir foo+echo hello world > foo/bar+echo hello world > foo/baz+mkdir foo/dir+darcs add foo foo/bar foo/dir foo/baz+darcs record -a -m add+rm -rf  foo+darcs show files --no-pending --no-dir > log+grep 'foo/baz' log+grep 'foo/bar' log+darcs show files --no-pending --no-fil > log+grep 'foo/dir' log+grep 'foo$'    log+# now without...+darcs record -a -m del+darcs show files --no-pending --no-dir > log+not grep 'foo/baz' log+not grep 'foo/bar' log+darcs show files --no-pending --no-fil > log+not grep 'foo/dir' log+not grep 'foo$'    log+cd ..++rm -rf temp1
+ tests/rmdir.sh view
@@ -0,0 +1,71 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2 temp3++# initialise temp1+mkdir temp1+cd temp1+darcs initialize+mkdir foo+echo hello world > foo/bar+darcs add foo foo/bar+darcs record -a -m add+cd ..++# get temp1 into temp2+darcs get temp1 temp2+cd temp2+echo hello world > foo/baz+cd ..++# remove a directory from temp1 and record+cd temp1+rm -rf foo+darcs record -a -m del+cd ..++cd temp2+test -e foo/baz+test -e foo/bar+test -d foo++darcs show files --no-pending --no-dir >> files+grep foo/bar files+darcs show files --no-pending --no-fil >> dirs+grep foo dirs+cd ..++darcs pull -a --repodir=temp2 > pullresult+cat pullresult+grep 'Warning: .ot deleting' pullresult++# get temp1 into temp3+darcs get temp1 temp3+cd temp3+darcs obliterate --last 1 -a+echo hello world > foo/baz+cd ..++# remove a directory from temp1 and record+cd temp1+rm -rf foo+darcs record -a -m del+cd ..++cd temp3+test -e foo/baz+test -e foo/bar+test -d foo++darcs show files --no-pending --no-dir >> files+grep foo/bar files+darcs show files --no-pending --no-fil >> dirs+grep foo dirs+cd ..++darcs pull -q -a --repodir=temp3 > pullresult+cat pullresult+test ! -s pullresult++rm -rf temp1 temp2 temp3
+ tests/rollback-nothing.sh view
@@ -0,0 +1,16 @@+#!/usr/bin/env bash++set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+date > file1+darcs add file1+darcs record -am "test"+rm file1+darcs record -am "rm"+echo yd | darcs rollback --last=1 -m 'oops' | grep 'No changes selected'+cd ..+rm -rf temp
+ tests/rollback.sh view
@@ -0,0 +1,34 @@+#!/bin/bash++set -ev++range="0 1 2"++rm -rf temp1 temp2              # clean up when previous run crashed+mkdir temp1 && cd temp1 && darcs init+touch f && darcs add f+for i in $range+do+  echo $i > f && darcs record -A me --ignore-time -m p$i --all f+done++cd .. && mkdir temp2 && cd temp2 && darcs init++set -x++: Demonstrate problem with regrem+for i in $range+do+  darcs pull --patch p$i ../temp1 --all+  if darcs whatsnew ; then+      : Resolve conflict - rollback our patch+      darcs revert --all+      darcs rollback -a --patch-name x0+      darcs revert --all+  fi+  : Create local change and record it+  echo X$i > f && darcs record -A me --ignore-time -m x$i --all f+done++cd ..+rm -rf temp1 temp2
+ tests/sametwice.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo record author me > _darcs/prefs/defaults+echo ALL all >> _darcs/prefs/defaults+echo ALL verbose >> _darcs/prefs/defaults+echo ALL ignore-times >> _darcs/prefs/defaults+touch foo+darcs add foo+darcs whatsnew+darcs record -m add_foo+echo hello >> foo+darcs record -m mod_foo+cd ..+darcs get --repo-name temp2 temp1+cd temp2+cp ../temp1/_darcs/prefs/defaults _darcs/prefs+echo y/d/y | tr / \\012 | darcs unpull --interactive+test -f foo -a ! -s foo+echo hello >> foo+darcs record -m mod_foo_again+darcs pull ../temp1+test -s foo+cd ..+rm -rf temp1 temp2+
+ tests/send-dont-prompt-deps.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++set -ev++# Check that the right patches get sent using --dont-prompt-for-dependencies++rm -rf temp1+rm -rf temp2+mkdir temp2+mkdir temp1+cd temp2+darcs init+cd ..+cd temp1+darcs init+echo foo > f+darcs record -Ax -alm foo1+echo bar > b+darcs rec -Ax -alm bar1+echo foo2 > f+darcs record -Ax -alm foo2+echo bar2 > b+darcs record -Ax -alm bar2+echo y | darcs send ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run > toto+#on the previous line, we don't get asked about foo1.+grep foo toto | wc -l | grep 2+#but we send it anyway.+grep bar toto | wc -l | grep 0+cd ..+rm -rf temp1 temp2
+ tests/send-external.sh view
@@ -0,0 +1,54 @@+#!/usr/bin/env bash+set -ev++DARCS_EDITOR=echo+export DARCS_EDITOR++rm -rf temp1 temp2+mkdir temp1 temp2++cd temp2+darcs init+cd ..++cd temp1+darcs init+date > foobar+darcs add foobar+darcs rec -a -m add-foobar++cat > saveit.sh <<EOF+#!/bin/sh+# send-mail1.sh: Test sendmail command for darcs send 1+# 2008-Oct-06 22.25 / TN+set -ev+echo all: \$0 "\$@" >>saved.out+echo \$6 contains: >>saved.out+ls -ltr >>saved.out+cat "\$6" >>saved.out+echo End of \$6 contents >>saved.out+grep add-foobar \$6+CNT=0+while [ "\$#" != "0" ]; do+  CNT=`expr \$CNT + 1`+  echo \$0: arg[\$CNT] = \"\$1\" >>saved.out+  shift+done+echo \$0: Total \$CNT arguments >>saved.out+echo \$0: Input: >>saved.out+cat >>saved.out+echo \$0: End of input: >>saved.out+EOF++chmod +x saveit.sh++# foobar+darcs send --author=me -a --to=random@random \+    --sendmail-command='bash ./saveit.sh %s %t %c %b %f %a %S %t %C %B %F %A something' ../temp2++cat saved.out+grep add-foobar saved.out+grep 'addfile ./foobar' saved.out++cd ..+rm -rf temp1 temp2
+ tests/send.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+set -ev++DARCS_EDITOR=echo+export DARCS_EDITOR++rm -rf temp1 temp2+mkdir temp1 temp2++cd temp2+darcs init++# setup test+cd ../temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x++# Test that a default preference value is not needed to send+darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' ../temp2++# Test that a default preference will be used when no --to value is specified+echo "default@email" > ../temp2/_darcs/prefs/email+darcs send --author=me -a --sendmail-command='grep "^To: default@email$" %<' ../temp2++# Test that the --to parameter overrides the default value in the repository+darcs send --author=me -a --to=override@default --sendmail-command='grep "^To: override@default$" %<' ../temp2+darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^In-Reply-To: some-thread-id$" %<' ../temp2+darcs send --author=me -a --in-reply-to=some-thread-id --sendmail-command='grep "^References: some-thread-id$" %<' ../temp2++# Test that the --subject parameter sets the subject++# Test that the --output-auto-name parameter outputs what we expect+darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2+darcs send --author=me -a --subject="it works" --output-auto-name ../temp2+cmp test1.dpatch add_foo_bar.dpatch++# test --output-auto-name works with optional argument.+mkdir patchdir+darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2+cmp test1.dpatch patchdir/add_foo_bar.dpatch++# checking --output-auto-name=dir when run in different directory+cd patchdir+rm add_foo_bar.dpatch+darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2+cmp ../test1.dpatch add_foo_bar.dpatch+cd ..++cd ..+rm -rf temp1 temp2
+ tests/send_apply.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2+mkdir temp1 temp2++cd temp2+darcs init++cd ../temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x+darcs mv foo zig+darcs mv bar foo+darcs mv zig bar+darcs record -a -m swap_foo_bar -A x+darcs send --author=me --output=funpatch --dont-sign -a ../temp2+cd ../temp2+darcs apply ../temp1/funpatch+cd ..+cmp temp1/bar temp2/bar+rm -rf temp2++mkdir temp2+cd temp2+darcs init+darcs apply ../temp1/funpatch+## Also test that "darcs apply" can accept a patch on stdin.+darcs obl -a+darcs apply < ../temp1/funpatch+cd ..+cmp temp1/bar temp2/bar+++rm -rf temp1 temp2+
+ tests/set_scripts_executable.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash++# Some tests for the --set-scripts-executable option.++. lib++abort_windows++rm -rf temp1 temp2++mkdir temp1+cd temp1+darcs init+cat > script.pl << FOO+#!/usr/bin/env perl+print "Hello\n";+FOO+chmod 0644 script.pl+date > nonscript+# pre-tests+test -r script.pl+test -r nonscript+test ! -x script.pl+test ! -x nonscript+darcs add script.pl nonscript+darcs record --patch-name 'uno' --all+cd ..++# sans --set-scripts-executable (should not be executable)+mkdir temp2+cd temp2+darcs init+darcs pull -a ../temp1+# sanity check+test -r script.pl+test -r nonscript+# nothing should be executable+test ! -x script.pl+test ! -x nonscript+cd ..+rm -rf temp2++# with --set-scripts-executable+mkdir temp2+cd temp2+darcs init+darcs pull -a ../temp1 --set-scripts-executable+# sanity check+test -r script.pl+test -r nonscript+# script should be executable+test -x script.pl+test ! -x nonscript+cd ..+rm -rf temp2++# now let's try the same thing with get+darcs get --set-scripts-executable temp1 temp2+cd temp2+# sanity check+test -r script.pl+test -r nonscript+# script should be executable+test -x script.pl+test ! -x nonscript+cd ..++rm -rf temp1 temp2
+ tests/setpref.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash+++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo 'test file 1' > foo+darcs record --look-for-adds --all -m"Patch 1"+echo 'test boringfile' > bar+darcs setpref boringfile bar+darcs record --look-for-adds --all -m"Patch 2"+echo 'test file 3' > baz+# there should be no -R+darcs record --look-for-adds --all -m"Patch 3" > ../temp2+cat ../temp2+not grep R ../temp2++cd ..++rm -rf temp1+rm -f temp2
+ tests/several_commands.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo hello world > foo+darcs add foo+darcs record -a -m add -A x+echo goodbye world >> foo+darcs diff+darcs diff -u+darcs whatsnew+darcs whatsnew --summary+echo y | darcs revert -a+darcs show contents foo | cmp foo -+mkdir d+darcs add d+darcs record -a -m 'add dir' -A x+rmdir d+darcs revert -a d+cd ..+rm -rf temp1+
+ tests/show-authors.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+set -ev++rm -rf test+mkdir test+cd test+darcs init+echo zig > foo+darcs add foo+darcs record -a -m add_foo -A x+echo zag >> foo+darcs record -a -m mod_foo -A y+echo bar > foo+darcs record -a -m mod2 -A y++darcs show authors > authors+grep x authors+grep y authors++head -1 authors > first-author+grep y first-author++darcs show authors --verbose+darcs show authors --verbose | grep y | wc -l > num-patches+cat num-patches+grep 2 num-patches++cd ..+rm -rf test+
+ tests/show-bug.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++## All these commands SHOULD fail (hence leading NOTs).+. lib++rm -rf test+mkdir test+cd test++darcs show bug --debug 1> stdout 2> stderr || true++cat stdout+cat stderr++echo The following test will fail if this version of darcs is marked as+echo obsolete.+echo ==================================================================++not grep 'please do not' stderr++# The following test fails if HTTP isn't present, but would be a nice test+# to have in place.++#not grep unable stderr++grep 'fake bug' stderr++cd ..+rm -rf test+
+ tests/show_contents.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo+echo first > foo+darcs record -a -m "first edit" -A author1+echo second > foo+darcs record -a -m "second edit" -A author2+darcs tag t1 -A moi+echo third > foo+darcs record -a -m "third edit" -A author3+echo fourth > foo+darcs record -a -m "fourth edit" -A author4+echo unrecorded > foo+darcs show contents foo | grep fourth+darcs show contents foo -p third | grep third+darcs show contents foo --match="author author1" first | grep first+darcs show contents foo --tag t1 | grep second+cd ..++rm -rf temp1
+ tests/show_tags.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs initialize+echo ALL ignore-times >> _darcs/prefs/defaults+echo A > foo+darcs add foo+darcs record -a -m AA -A x+echo B > foo+darcs record -a -m BB -A x+echo C > foo+darcs record -a -m CC -A x+darcs tag -m 1.0 -A x+echo D > foo+darcs record -a -m DD -A x+echo E > foo+darcs record -a -m EE -A x+echo F > foo+darcs record -a -m FF -A x+darcs tag -m 2.0 -A x++darcs show tags > my+cat my+cat > ref <<EOF+2.0+1.0+EOF++cmp my ref+cd ..++rm -rf temp1
+ tests/sigPIPE.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+set -ev++DARCS_EDITOR=echo+export DARCS_EDITOR++rm -rf temp1+mkdir temp1++cd temp1+darcs init++echo hello world > foo+darcs add foo+darcs record -a --author=me -m "First patch"+i=1+while test $i -le 100; do+  echo foo $i > foo;+  darcs record --ignore-times -a --author=me -m "Patch $i" > bar+  i=`expr $i + 1`+done+darcs tag --author=me -m 'silly tag'+i=1000+while test $i -le 1096; do+  echo foo $i > foo;+  darcs record --ignore-times -a --author=me -m "Patch $i" > bar+  i=`expr $i + 1`+done++darcs --version+darcs changes | head++cd ..+# rm -rf temp1
+ tests/ssh.sh view
@@ -0,0 +1,143 @@+#!/usr/bin/env bash+set -ev++if [ x${REMOTE_DIR} = x ]; then+  REMOTE_DIR=sshtest+fi++if [ x"${USE_PUTTY}" != x ]; then+  DARCS_SSH=plink+  export DARCS_SSH+  DARCS_SCP=pscp+  export DARCS_SCP+  DARCS_SFTP=psftp+  export DARCS_SFTP+fi++if [ x"${USE_CONTROL_MASTER}" != x ]; then+  DARCS_SSH_FLAGS="--ssh-cm"+  export DARCS_SSH_FLAGS+fi++if [ x"${DARCS_SSH}" = x ]; then+  SSH=ssh+else+  SSH=${DARCS_SSH}+fi++rm -rf tempssh+mkdir tempssh+cd tempssh++cleanup () {+  cd ..+  rm -rf tempssh+}++if [ x${REMOTE} = x ]; then+  echo+  echo "Note: to enable full SSH testing, set REMOTE to some SSH path first,"+  echo "      e.g. REMOTE=you@server.org $0"+  cleanup+  exit 0 # exit normally in case we are being run from the shell harness+fi++# ================ Setting up remote repositories ===============+${SSH} ${REMOTE} "\+rm -rf ${REMOTE_DIR}; \+mkdir ${REMOTE_DIR}; \+cd ${REMOTE_DIR}; \+\+mkdir testrepo; cd testrepo; \+darcs init; \+echo moi > _darcs/prefs/author; \+touch a; darcs add a; darcs record a --ignore-times -am 'add file a'; \+echo 'first line' > a; darcs record a --ignore-times -am 'add first line to a'; \+cd ..; \+\+darcs get testrepo testrepo-pull; \+cd testrepo-pull; \+echo moi > _darcs/prefs/author; \+touch b; darcs add b; darcs record b --ignore-times -am 'add file b'; \+echo 'other line' > b; darcs record b --ignore-times -am 'add other line to b'; \+cd ..; \+\+darcs get testrepo testrepo-push; \+darcs get testrepo testrepo-send; \+"++# ================ Settings ===============+echo ${DARCS_SSH_FLAGS}+echo ${DARCS_SSH}+echo ${DARCS_SCP}+echo ${DARCS_SFTP}++# ================ Checking darcs get ==================+${DARCS} get ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS}+# check that the test repo made it over+[ -d testrepo ]+[ -d testrepo/_darcs ]+[ -f testrepo/a ]++# if the above test is disabled we just init a blank repo+# so that the other tests can continue+if [ ! -d testrepo ]; then+  mkdir testrepo+  cd testrepo+  darcs init+  cd ..+fi++# ================ Checking darcs pull =================+${DARCS} get ${DARCS_SSH_FLAGS} testrepo testrepo-pull+cd testrepo-pull+echo yy | ${DARCS} pull ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull+# see if the changes got pulled over+grep "other line" b++cd ..++# ================ Checking darcs push and send ================="+${DARCS} get ${DARCS_SSH_FLAGS} testrepo testrepo-push+cd testrepo-push+echo moi > _darcs/prefs/author+echo "second line" >> a; ${DARCS} record a --ignore-times -am "add second line to a"+touch c; ${DARCS} add c+${DARCS} record --ignore-times -am "add file c" c+echo yy | ${DARCS} push ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push+# check that the file c got pushed over+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-push/c ]"+echo yy | ${DARCS} send ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch+# check that the bundle was created+grep "add file c" mybundle.dpatch+cd ..++# ================ Checking darcs put =================="+cd testrepo+${DARCS} put ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-put+# check that the put was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-put/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-put/a ]"+cd ..++# ======== Checking push over ssh with a conflict ========="+${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-put/_darcs/prefs/defaults"++cd testrepo +echo 'change for remote' > a+darcs record --ignore-times -am 'change for remote'+darcs push -a+darcs ob --last 1 -a+echo 'change for local' > a+darcs record --ignore-times -am 'change for local'++if darcs push -a 2>&1 | grep -q 'conflicts options to apply' ; then+    # do nothing. +    echo "OK";+else+    exit 1;+fi++cd ..++cleanup
+ tests/steve_and_monica_rollback.sh view

file too large to diff

+ tests/tag.sh view

file too large to diff

+ tests/three_way_conflict.sh view

file too large to diff

+ tests/toolbox.sh view

file too large to diff

+ tests/tricky_unrecord.sh view

file too large to diff

+ tests/uniqueoptions.sh view

file too large to diff

+ tests/unpull-formerly-pl.sh view

file too large to diff

+ tests/unpull.sh view

file too large to diff

+ tests/unrecord-add.sh view

file too large to diff

+ tests/unrecord-dont-prompt.sh view

file too large to diff

+ tests/unrecord-remove.sh view

file too large to diff

+ tests/unrecord-setpref.sh view

file too large to diff

+ tests/unrecord.sh view

file too large to diff

+ tests/unrevert-add.sh view

file too large to diff

+ tests/unrevert-replace-moved.sh view

file too large to diff

+ tests/unrevert.sh view

file too large to diff

+ tests/unrevert_cancel.sh view

file too large to diff

+ tests/what_sl.sh view

file too large to diff

+ tests/whatsnew-file.sh view

file too large to diff

+ tests/whatsnew.sh view

file too large to diff

+ tests/workingdir.sh view

file too large to diff