packages feed

darcs (empty) → 2.1.2.1

raw patch · 401 files changed

+53050/−0 lines, 401 filesdep +HTTPdep +arraydep +basebuild-type:Customsetup-changedbinary-added

Dependencies added: HTTP, array, base, bytestring, containers, directory, filepath, haskeline, html, mtl, network, old-time, parsec, process, random, regex-compat, terminfo, unix, zlib

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.
+ Setup.lhs view
@@ -0,0 +1,379 @@+\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)+         , BuildInfo(customFieldsBI), emptyBuildInfo+         , updatePackageDescription )+import Distribution.Package+         ( packageVersion )+import Distribution.Simple.Program+         ( Program(..), simpleProgram, findProgramVersion+         , rawSystemProgramStdoutConf )+import Distribution.Simple.Configure+         ( ccLdOptionsBuildInfo )+import Distribution.Version+         ( Version(versionTags) )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..) )++import Distribution.Simple.Setup+         ( configVerbosity, buildVerbosity, sDistVerbosity, fromFlag )+import Distribution.Simple.BuildPaths+         ( autogenModulesDir )+import Distribution.System+         ( OS(Windows), buildOS )+import Distribution.Simple.Utils+         ( rewriteFile, rawSystemStdout, createDirectoryIfMissingVerbose+         , withFileContents, notice )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text+         ( display )++import Control.Monad ( zipWithM_, when )+import Control.Exception ( bracket, bracket_ )+import System.Directory( doesDirectoryExist, doesFileExist,+                         getDirectoryContents, createDirectory,+                         copyFile, removeDirectoryRecursive,+                         getCurrentDirectory, setCurrentDirectory,+                         removeFile, createDirectoryIfMissing )+import System.IO.Error ( isDoesNotExistError )+import Data.List( isSuffixOf )+import System( system, ExitCode(..) )++import System.FilePath       ( (</>) )+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 = defaultMainWithHooks simpleUserHooks {++  hookedPrograms = [libwwwconfigProgram],+  +  confHook = \(pkg0, pbi) flags -> do+    let verbosity = fromFlag (configVerbosity flags)++    -- Call the ordinary build code+    lbi <- confHook simpleUserHooks (pkg0, pbi) flags++    -- Do some custom stuff:+    let pkg = localPkgDescr lbi+    libwwwBi <- getLibwwwBuildInfo verbosity pkg lbi+    let hbi  = (Nothing, [("darcs", libwwwBi)])+        lbi' = lbi { localPkgDescr = updatePackageDescription hbi pkg } +    generateAutoconfModule verbosity pkg lbi+    return lbi',++  buildHook = \pkg lbi hooks flags -> do+    let verbosity = fromFlag (buildVerbosity flags)+    +    -- Do some custom stuff:+    writeGeneratedModules verbosity pkg lbi+    +    -- Call the ordinary build code+    buildHook simpleUserHooks pkg lbi hooks flags,++  runTests = \ args _ _ _ ->+             sequence_ [ case w of+                           x | x == "bugs" -> allTests Bug+                             | x == "network" -> execTests Network ""+                             | x == "tests" -> allTests Test+                             | otherwise -> fail $ "Unknown test: " ++ x+                         | w <- if null args then ["tests"] else args ],++  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+}++libwwwconfigProgram :: Program+libwwwconfigProgram = (simpleProgram "libwww-config") {+    programFindVersion = findProgramVersion "--version" id+  }++getLibwwwBuildInfo verbosity pkg lbi+  | "x-have-libwww" `elem` customFields = do+    cflags <- libwwwconfig ["--cflags"]+    libs   <- libwwwconfig ["--libs"]+    return (ccLdOptionsBuildInfo (words cflags) (words libs))++  | otherwise = return emptyBuildInfo++  where+    libwwwconfig = rawSystemProgramStdoutConf verbosity+                     libwwwconfigProgram (withPrograms lbi)+    customFields = map fst . customFieldsBI . buildInfo $ darcsExe+    [darcsExe]   = executables pkg++generateAutoconfModule verbosity pkg lbi = do+  bigendian <- fmap not archIsLittleEndian++  let subst "configure_input" = targetFile ++ ". Generated from "+                                  ++ templateFile ++ " by Setup.hs."+      subst "HAVE_HTTP"     = show ("x-have-http" `elem` customFields)+      subst "USE_COLOR"     = show ("x-use-color" `elem` customFields)+      subst "USE_MMAP"     +                | isWindows = show False+                | otherwise = show True+      subst "HAVE_SENDMAIL" = show True+      subst "SENDMAIL"      = "/usr/sbin/sendmail"+      subst "HAVE_MAPI"+                | isWindows = show True+                | otherwise = show False+      subst "DIFF"          = "diff"+      subst "BIGENDIAN"     = show bigendian+      subst other           = unexpected other++  createDirectoryIfMissingVerbose verbosity True targetDir+  withFileContents templateFile+    (rewriteFile targetFile . templateSubstitute subst)++  where+    templateFile = "src/Autoconf.hs.in"+    targetDir    = autogenModulesDir lbi+    targetFile   = targetDir </> "Autoconf.hs"+    unexpected other = error $ "unexpected variable in template file "+                            ++ templateFile ++ ": " ++ show other+    isWindows    = case Distribution.System.buildOS of+                     Windows -> True+                     _       -> False+    customFields = map fst . customFieldsBI . buildInfo $ darcsExe+    [darcsExe]   = executables pkg++archIsLittleEndian :: IO Bool+archIsLittleEndian =+  with (1 :: Word32) $ \p -> do o <- peek $ castPtr p+                                return $ o == (1 :: Word8)++writeGeneratedModules :: Verbosity+                      -> PackageDescription -> LocalBuildInfo -> IO ()+writeGeneratedModules verbosity pkg lbi = do+  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)++  let versionModulePath = autogenModulesDir lbi </> "ThisVersion.hs"+  generateVersionModule verbosity versionModulePath pkg++  let contextModulePath = autogenModulesDir lbi </> "Context.hs"+  generateContextModule verbosity contextModulePath pkg++generateVersionModule verbosity targetFile pkg = do+  let darcsVersion  =  packageVersion pkg+  numPatches <- versionPatches verbosity darcsVersion+  let darcsVersionState = versionStateString numPatches darcsVersion+      subst "DARCS_VERSION"       = display darcsVersion+      subst "DARCS_VERSION_STATE" = darcsVersionState+      subst other                 = unexpected other+  +  withFileContents templateFile+    (rewriteFile targetFile . templateSubstitute subst)+      +  where+    versionStateString :: Maybe Int -> Version -> String+    versionStateString Nothing  _ = "unknown" +    versionStateString (Just 0) v = case versionTags v of+                         ["pre"] -> "prerelease"+                         ["rc"]  -> "release candidate"+                         []      -> "release"+                         _       -> "tag"+    versionStateString (Just 1) _ = "+ 1 patch"+    versionStateString (Just n) _ = "+ " ++ show n ++ " patches"+    templateFile = "src/ThisVersion.hs.in"+    unexpected other = error $ "unexpected variable in template file "+                            ++ templateFile ++ ": " ++ show other++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)+        _         -> 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 verbosity targetFile pkg = do+  ctx <- context verbosity (packageVersion pkg)+  rewriteFile targetFile $ unlines+    ["module Context where"+    ,"context :: String"+    ,"context = " ++ show ctx+    ]++context :: Verbosity -> Version -> IO 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, _) -> x+             (Nothing, Just x) -> x+             (Nothing, Nothing) -> "context not available"+ 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 a = [ if x == '/' then '_' else x | x <- show a ]++harness :: String+harness = "perl ../tests/shell_harness"++isTest :: FilePath -> Bool+isTest = (".sh" `isSuffixOf`)++execTests' :: TestKind -> IO ()+execTests' k =+    do fs <- getDirectoryContents "."+       cwd <- getCurrentDirectory+       let run = filter isTest fs+       res <- Harness.runTests cwd run+       when ((not res) && (k /= Bug)) $ fail "Tests failed"+       return ()++execTests :: TestKind -> String -> IO ()+execTests k fmt = do+  copyFile "dist/build/darcs/darcs" "darcs"+  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"+    execTests' k++allTests :: TestKind -> IO ()+allTests k =+    do test `mapM` repotypes+       return ()+    where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"]+          test = execTests k++----------------------+-- Utility functions+--++templateSubstitute :: (String -> String) -> String -> String+templateSubstitute varSubst = subst+  where+    subst text = case span (/= '@') text of+      (chunk, []) -> chunk+      (chunk, '@':rest) -> case span (/= '@') rest of+        (var, '@':rest) -> chunk ++ varSubst var ++ subst rest++-------------------------------------------------------+-- More 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 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,23 @@+#!/usr/bin/env bash+set -ev++# add should fail on files it can't read (because it would fail to record it later anyway)++if echo $OS | grep -i windows; then+  echo This test does not work on Windows+  exit 0+fi++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch no_perms.txt+chmod 0000 no_perms.txt+# surely there is an easier way to write this 'not'+# i'm think of the 'finally' in try/catch/finally+dacrs add no_perms.txt 2> log && (chmod 0755 no_perms.txt ; exit 1) || chmod 0755 no_perms.txt +grep -i 'permission denied' log++cd ..+rm -rf temp1
+ bugs/bin/darcs view
@@ -0,0 +1,10 @@+#!/bin/sh++if test "x$1" = "x--am-I-the-test-wrapper"+then+    echo "Yes, I am the test wrapper"+    exit 0+fi++test $DARCS || DARCS=$HOME/../darcs+$DARCS "$@"
+ 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/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/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
+ 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/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,34 @@+#!/usr/bin/env bash++# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory++set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+date > file1+date > file2+darcs add file*+darcs record -am "test"++TRACE=`which strace`+if test -x $TRACE+then+    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+else+    echo skipping test since strace was not found+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/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
+ darcs.cabal view
@@ -0,0 +1,371 @@+Name:           darcs+version:        2.1.2.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:+  -- template files+  src/Autoconf.hs.in src/ThisVersion.hs.in ++  -- 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/darcsman.hs, src/unit.lhs,++  -- The tools directory would make a sensible 'darcs-tools' package+  tools/zsh_completion_new, tools/zsh_completion_old, tools/darcs_completion,+  tools/cygwin-wrapper.bash, tools/update_roundup.pl, tools/upload.cgi,+  tools/cgi/darcs.cgi.in, tools/cgi/cgi.conf.in, tools/cgi/README.in+  tools/cgi/xslt/*.xslt, tools/cgi/xslt/*.xml, tools/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,+  tools/cgi/README.in++  -- release data+  release/distributed-version, release/distributed-context++  -- testsuite+  tests/repos/*.tgz tests/repos/README+  tests/*.sh+  tests/network/*.sh+  bugs/*.sh+  bugs/bin/darcs++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 libwww+  description: Use libwww for HTTP support.++flag http+  description: Use the pure Haskell HTTP package for HTTP support.++flag external-bytestring+  description: Use the external bytestring package.++flag external-zlib+  description: Use the external zlib binding package.++flag haskeline+  description: Use the haskeline package for command line editing support.+  default:     False++flag terminfo+  description: Use the terminfo package for enhanced console support.++flag curses+  description: Use libcurses for enhances console support.+  default:     False++flag type-witnesses+  description: Use GADT type witnesses.+  default:     False++flag color+  description: Use ansi color escapes.++flag base3++Executable          darcs+  main-is:          darcs.hs+  hs-source-dirs:   src+  include-dirs:     src++  other-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.Help+                    Darcs.Commands.Init+                    Darcs.Commands.MarkConflicts+                    Darcs.Commands.Mv+                    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.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.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.QuickCheck+                    Darcs.Patch.Read+                    Darcs.Patch.ReadMonads+                    Darcs.Patch.Real+                    Darcs.Patch.Set+                    Darcs.Patch.Show+                    Darcs.Patch.Test+                    Darcs.Patch.TouchesFiles+                    Darcs.Patch.Unit+                    Darcs.Patch.Viewing+                    Darcs.Population+                    Darcs.PopulationData+                    Darcs.PrintPatch+                    Darcs.Progress+                    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+                    RegChars+                    SHA1+                    Ssh+                    URL+                    UTF8+                    Workaround++  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.92,+                   mtl          == 1.1.*,+                   parsec       == 2.1.*,+                   html         == 1.0.*,+                   filepath     == 1.1.*++  if !os(windows)+    build-depends: unix == 2.3.*+    cpp-options:   -DHAVE_SIGNALS++  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 -threaded+  ghc-prof-options: -prof -auto-all++  if flag(curl)+    extra-libraries:   curl+    cpp-options:       -DHAVE_CURL+    c-sources:         src/hscurl.c+    cc-options:        -DHAVE_CURL -DPACKAGE_VERSION="2.1.2"++    if flag(curl-pipelining)+      -- curl 7.19.1 has bug-free pipelining+      pkgconfig-depends: libcurl >= 7.19.1+      cpp-options:       -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT++  else+    if flag(libwww)+      build-tools:    libwww-config >= 5.0+      c-sources:      src/hslibwww.c+      cc-options:     -DHAVE_LIBWWW -DPACKAGE_VERSION="2.1.2"+      cpp-options:    -DHAVE_LIBWWW+      x-have-libwww:+    else+      if flag(http)+        build-depends:    network == 2.2.*,+                          HTTP    >= 3000.0 && < 3001.1+        cpp-options:      -DHAVE_HTTP -DPACKAGE_VERSION="2.1.2"+        x-have-http:++  if flag(external-bytestring)+    build-depends:    bytestring >= 0.9.0 && < 0.10+    cpp-options:      -DHAVE_BYTESTRING++  if flag(external-zlib)+    build-depends:    zlib == 0.5.*+    cpp-options:      -DHAVE_HASKELL_ZLIB+  else+    extra-libraries:  z++  if flag(terminfo)+    build-depends:    terminfo == 0.2.* && >= 0.2.2+    cpp-options:      -DHAVE_TERMINFO++  if flag(curses)+    extra-libraries:  curses+    cpp-options:      -DHAVE_CURSES++  if flag(haskeline)+    build-depends:    haskeline == 0.3.* && >= 0.3.1+    cpp-options:      -DHAVE_HASKELINE++  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
+ release/distributed-context view
@@ -0,0 +1,1 @@+"context not available"
+ release/distributed-version view
@@ -0,0 +1,1 @@+Nothing
+ src/Autoconf.hs.in view
@@ -0,0 +1,71 @@+--+-- System dependent information generated by Autoconf.+--+-- @configure_input@+--+{-# LANGUAGE CPP #-}+{-# OPTIONS -cpp #-}++module Autoconf ( have_libcurl, have_libwww, have_HTTP,+                  use_color, use_mmap, darcs_version, sendmail_path, have_sendmail,+                  have_mapi, diff_program,+                  path_separator, big_endian,+                ) where++import ThisVersion ( darcs_version )++{-# INLINE have_libcurl #-}+have_libcurl :: Bool+#ifdef HAVE_CURL+have_libcurl = True+#else+have_libcurl = False+#endif++{-# INLINE have_libwww #-}+have_libwww :: Bool+#ifdef HAVE_LIBWWW+have_libwww = True+#else+have_libwww = False+#endif++{-# INLINE have_HTTP #-}+have_HTTP :: Bool+have_HTTP = @HAVE_HTTP@++{-# INLINE use_color #-}+use_color :: Bool+use_color = @USE_COLOR@++{-# INLINE use_mmap #-}+use_mmap :: Bool+use_mmap = @USE_MMAP@++{-# INLINE sendmail_path #-}+sendmail_path :: String+sendmail_path = "@SENDMAIL@"++{-# INLINE have_sendmail #-}+have_sendmail :: Bool+have_sendmail = @HAVE_SENDMAIL@++{-# INLINE have_mapi #-}+have_mapi :: Bool+have_mapi = @HAVE_MAPI@++{-# INLINE diff_program #-}+diff_program :: String+diff_program = "@DIFF@"++{-# INLINE path_separator #-}+path_separator :: Char+#ifdef WIN32+path_separator = '\\'+#else+path_separator = '/'+#endif++{-# INLINE big_endian #-}+big_endian :: Bool+big_endian = @BIGENDIAN@
+ src/ByteStringUtils.hs view
@@ -0,0 +1,608 @@+{-# OPTIONS_GHC -fbang-patterns -fffi -cpp #-}+{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP #-}++-----------------------------------------------------------------------------+-- |+-- 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,++        -- 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 Autoconf                 ( use_mmap )++import qualified Data.ByteString            as B+import qualified Data.ByteString.Char8      as BC+#if __GLASGOW_HASKELL__ > 606+import qualified Data.ByteString.Internal   as BI+import Data.ByteString (intercalate, uncons)+import Data.ByteString.Internal (fromForeignPtr)+#else+import qualified Data.ByteString.Base     as BI+#endif++import System.IO+import System.IO.Unsafe         ( unsafePerformIO )++#if __GLASGOW_HASKELL__ > 606+import Foreign.Storable         ( peekElemOff, peek )+#else+import Foreign.Storable         ( peekElemOff, peek, peekByteOff )+import Data.List                ( intersperse )+#endif+import Foreign.Marshal.Alloc    ( free )+import Foreign.Marshal.Array    ( mallocArray, peekArray, advancePtr )+import Foreign.C.Types          ( CInt, CSize )++import Data.Bits                ( rotateL )+import Data.Char                ( chr, ord, isSpace )+import Data.Word                ( Word8 )+import Data.Int                 ( Int32 )+import Control.Monad            ( when )++import Foreign.Ptr              ( nullPtr, plusPtr, Ptr )+import Foreign.ForeignPtr       ( ForeignPtr, withForeignPtr )++#if defined(__GLASGOW_HASKELL__)+import qualified Foreign.Concurrent as FC ( newForeignPtr )+import System.Posix             ( handleToFd )+#endif++#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+#else+import Foreign.C.String ( CString, withCString )+#endif++-- -----------------------------------------------------------------------------+-- obsolete debugging code++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++-- -----------------------------------------------------------------------------+-- 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++#if __GLASGOW_HASKELL__ <= 606+-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing+-- if it is empty.+uncons :: B.ByteString -> Maybe (Word8, B.ByteString)+uncons (BI.PS x s l)+    | l <= 0    = Nothing+    | otherwise = Just (BI.inlinePerformIO $ withForeignPtr x+                                        $ \p -> peekByteOff p s,+                        BI.PS x (s+1) (l-1))+{-# INLINE uncons #-}+-- | /O(1)/ Build a ByteString from a ForeignPtr+fromForeignPtr :: ForeignPtr Word8+               -> Int -- ^ Offset+               -> Int -- ^ Length+               -> B.ByteString+fromForeignPtr fp s l = BI.PS fp s l+{-# INLINE fromForeignPtr #-}+-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of+-- 'ByteString's and concatenates the list after interspersing the first+-- argument between each element of the list.+intercalate :: B.ByteString -> [B.ByteString] -> B.ByteString+intercalate s = B.concat . (intersperse s)+{-# INLINE [1] intercalate #-}+#endif+++------------------------------------------------------------------------+-- 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++-- | Read an entire file, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.++#ifndef HAVE_HASKELL_ZLIB+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++gzReadFilePS :: FilePath -> IO B.ByteString+gzReadFilePS f = do+    h <- openBinaryFile f ReadMode+    header <- B.hGet h 2+    if header /= BC.pack "\31\139"+       then do hClose h+               mmapFilePS f+       else do hSeek h SeekFromEnd (-4)+               len <- hGetLittleEndInt h+               hClose h+#ifdef HAVE_HASKELL_ZLIB+               -- Passing the length to GZ.decompressWith means+               -- that BL.toChunks only 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+               let decompress = GZ.decompressWith GZ.defaultDecompressParams {+                                  GZ.decompressBufferSize = len+                                }+               fmap (B.concat . BL.toChunks . decompress) $+#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+mmapFilePS f = if use_mmap+               then do (fp,l) <- mmap f+                       return $ fromForeignPtr fp 0 l+               else B.readFile f++#if defined(__GLASGOW_HASKELL__)+foreign import ccall unsafe "static fpstring.h my_mmap" my_mmap+    :: CSize -> CInt -> IO (Ptr Word8)+foreign import ccall unsafe "static sys/mman.h munmap" c_munmap+    :: Ptr Word8 -> CSize -> IO CInt+foreign import ccall unsafe "static unistd.h close" c_close+    :: CInt -> IO CInt+#endif++mmap :: FilePath -> IO (ForeignPtr Word8, Int)+mmap f = do+    h <- openBinaryFile f ReadMode+    l <- fromIntegral `fmap` hFileSize h+    -- Don't bother mmaping small files because each mmapped file takes up+    -- at least one full VM block.+    if l < mmap_limit+       then do thefp <- BI.mallocByteString l+               debugForeignPtr thefp $ "mmap short file "++f+               withForeignPtr thefp $ \p-> hGetBuf h p l+               hClose h+               return (thefp, l)+       else do+#if defined(__GLASGOW_HASKELL__)+               fd <- fromIntegral `fmap` handleToFd h+               p <- my_mmap (fromIntegral l) fd+               fp <- if p == nullPtr+                     then+#else+               fp <-+#endif+                          do thefp <- BI.mallocByteString l+                             debugForeignPtr thefp $ "mmap short file "++f+                             withForeignPtr thefp $ \p' -> hGetBuf h p' l+                             return thefp+#if defined(__GLASGOW_HASKELL__)+                     else do+                             fp <- FC.newForeignPtr p+                                   (do {c_munmap p $ fromIntegral l;+                                        return (); })+                             debugForeignPtr fp $ "mmap "++f+                             return fp+               c_close fd+#endif+               hClose h+               return (fp, l)+    where mmap_limit = 16*1024+++-- -------------------------------------------------------------------------+-- 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,49 @@+{-# OPTIONS_GHC -fffi -cpp #-}+{-# 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 )+#if __GLASGOW_HASKELL__ > 606+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+#else+import Data.ByteString.Base (unsafeUseAsCStringLen)+#endif+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 \\+{\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. 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,1589 @@+%  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,+                         isin, arein,+                         definePatches, defineChanges,+                         fixFilePathOrStd, fixUrl,+                         fixSubPaths, areFileArgs,+                         DarcsOption( .. ), option_from_darcsoption,+                         help, list_options, list_files,+                         help_on_match,+                         any_verbosity, disable,+                         notest, test, working_repo_dir,+                         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,+                         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,+                         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, pristine_tree,+                         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,+                         allow_unrelated_repos+                      ) 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 Darcs.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )+#endif++import Darcs.Hopefully ( PatchInfoAnd, info )+import Darcs.Patch ( RepoPatch, Patchy, showNicely, description )+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(..) )+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 )+import URL ( pipeliningEnabledByDefault )+#include "impossible.h"+\end{code}++\begin{code}+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 HelpOnMatch = 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 (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 (WorkDir s) = StringContent s+getContent (RepoDir s) = StringContent s+getContent (RemoteRepo 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++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 DarcsMultipleChoicOption 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]+\end{code}++\begin{code}+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 /= ""+\end{code}++\begin{code}+-- | '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++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,+  help_on_match, allow_unrelated_repos,+  match_one, match_range, match_several, fancy_move_add, sendmail_cmd,+  logfile, rmlogfile, leave_test_dir, from_opt, set_default, pristine_tree++      :: 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"++help_on_match = DarcsNoArgOption [] ["match"] HelpOnMatch+       "shows a summary of how to use patch matching rules"+\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 curl and libwww.+\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 curl and libwww",+                 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"] WorkDir "DIRECTORY"+             "specify the repository directory in which to run"+possibly_remote_repo_dir = DarcsArgOption [] ["repo"] RepoDir "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 (RepoDir 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 s = if and (map isDigit s)+                    then LastN (read s)+                    else LastN (-1)++__index = DarcsArgOption ['n'] ["index"] indexrange "N-M" "select a range of patches"+    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 == '-'++-- | '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 ]+\end{code}++\begin{code}+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"]+\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]"]++pristine_tree =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["plain-pristine-tree"] PristinePlain+     "use a plain pristine tree [DEFAULT]",+     DarcsNoArgOption [] ["no-pristine-tree"] PristineNone+     "use no pristine tree"]++\end{code}++\begin{code}+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!.  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+          putStr "Darcs needs to know what name (conventionally an email "+          putStr "address) to use as the\npatch author, e.g. 'Fred Bloggs "+          putStr "<fred@bloggs.invalid>'.  If you provide one\nnow "+          putStr ("it will be stored in the file '"++darcsdir++"/prefs/author' and ")+          putStr "used as a default\nin the future.  To change your preferred "+          putStr "author address, simply delete or edit\nthis file.\n\n"+          add <- askUser "What is your email address? "+          writeFile (darcsdir++"/prefs/author") add+          return add+        else do askUser "What is your email address (e.g. John Doe <a@b.com>)? "++-- | '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"+\end{code}++\begin{code}+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"+\end{code}++\begin{code}+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 [] = ""+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+output = DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"+         "specify output filename"+\end{code}++\begin{code}+output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"+                   "output to automatically named file in DIRECTORY, default: current directory"+\end{code}++\begin{code}+edit_description =+    DarcsMultipleChoiceOption+    [DarcsNoArgOption [] ["edit-description"] EditDescription+                          "edit the patch bundle description",+     DarcsNoArgOption [] ["dont-edit-description"] NoEditDescription+                      "don't edit the patch bundle description"]+\end{code}++\begin{code}+distname_option = DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME"+                  "name of version"+\end{code}++\begin{code}+recursive h+    = DarcsMultipleChoiceOption+      [DarcsNoArgOption ['r'] ["recursive"] Recursive h,+       DarcsNoArgOption [] ["not-recursive"] NoRecursive ("don't "++h)]+\end{code}++\begin{code}+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"]+\end{code}++\begin{code}+xmloutput = DarcsNoArgOption [] ["xml-output"] XMLOutput+        "generate XML formatted output"+\end{code}++\begin{code}+creatorhash = DarcsArgOption [] ["creator-hash"] CreatorHash "HASH"+              "specify hash of creator patch (see docs)"+\end{code}++\begin{code}+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"]+\end{code}++\begin{code}+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"]+\end{code}++\begin{code}+reponame = DarcsArgOption [] ["repo-name"] WorkDir "DIRECTORY"+           "path of output directory"+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"+\end{code}++\begin{code}+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"]+\end{code}++\begin{code}+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 = if Verbose `elem` opts+                      then showNicely p+                      else if Summary `elem` opts+                           then Darcs.Patch.summary p+                           else 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 (to_xml . info) patches) $$+                            text "</patches>")+                      else (vsep $ mapFL (showFriendly opts) patches)+           putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn++\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"+\end{code}++\begin{code}+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)"]+\end{code}++\begin{code}+-- | '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)+\end{code}++\begin{code}+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"]++\end{code}++\begin{code}+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 [] = []+\end{code}++\begin{code}+nolinks :: DarcsOption+nolinks = DarcsNoArgOption [] ["nolinks"] NoLinks+          "do not link repository or pristine to sibling"+\end{code}++\begin{code}+reorder_patches :: DarcsOption+reorder_patches = DarcsNoArgOption [] ["reorder-patches"] Reorder+                  "reorder the patches in the repository"+\end{code}+\begin{options}+--sendmail-command+\end{options}++\label{env:SENDMAIL}++Several commands send email. The user can determine which mta to+use with the \verb!--sendmail-command! switch. For repetitive usage+of a specific sendmail command it is also possible to set the+environment variable \verb!SENDMAIL!. If there is no command line+switch given \verb!SENDMAIL! will be used if present.++\begin{code}+sendmail_cmd = DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"++-- |'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 @$SENDMAIL@ 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 ""+\end{code}++\begin{code}+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 libwww or curl (version 7.18.0 and above), darcs can+use HTTP pipelining. It is enabled by default for libwww and curl+(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],+     DarcsNoArgOption [] ["no-cache"] NoCache+                          "don't use patch caches"]+    where pipelining_description =+              "enable HTTP pipelining"+++              (if pipeliningEnabledByDefault then " [DEFAULT]" else "")+          no_pipelining_description =+              "disable HTTP pipelining"+++              (if pipeliningEnabledByDefault then "" else " [DEFAULT]")+\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}+--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}+-- | @'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+\end{code}
+ src/Darcs/Bug.hs view
@@ -0,0 +1,41 @@+-- Reporting bugs in darcs.  See also impossible.h.+module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust+                 ) where++import System.IO.Unsafe ( unsafePerformIO )+import Text.Regex ( matchRegex, mkRegex )++import Autoconf( darcs_version )+import Printer ( Doc, errorDoc, text, ($$), (<+>) )++type BugStuff = (String, Int, String, String)+type FetchUrl = String -> IO String++_bug :: FetchUrl -> BugStuff -> String -> a+_bug fetchUrl bs s = _bugDoc fetchUrl bs (text s)++_bugDoc :: FetchUrl -> BugStuff -> Doc -> a+_bugDoc fetchUrl bs s =+    errorDoc $ text "bug in darcs!" $$ s <+> text ("at "++_bugLoc bs) $$+    unsafePerformIO ((mkms . lines) `fmap` (fetchUrl "http://darcs.net/maintenance"+                                            `catch` \_ -> return ""))+    where mkms [] = text "I'm unable to check http://darcs.net/maintenance to see if this version is supported."+                    $$ text "If it is supported, please report this to bugs@darcs.net"+                    $$ text "If possible include the output of 'darcs --exact-version'."+          mkms (a:b:r) = case matchRegex (mkRegex a) darcs_version of+                         Nothing -> mkms r+                         Just _ -> case reads b of+                                   [(m,"")] -> text m+                                   _ -> mkms r+          mkms [_] = mkms []++_bugLoc :: BugStuff -> String+_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date++_impossible :: FetchUrl -> BugStuff -> a+_impossible fetchUrl bs = _bug fetchUrl bs $ "Impossible case at "++_bugLoc bs++_fromJust :: FetchUrl -> BugStuff -> Maybe a -> a+_fromJust fetchUrl bs mx =+  case mx of Nothing -> _bug fetchUrl 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,280 @@+{-# 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 = Printers { colorP     = colorPrinter (getPolicy h),+                             invisibleP = invisiblePrinter,+                             hiddenP = colorPrinter (getPolicy h) Green,+                             userchunkP  = userchunkPrinter (getPolicy h),+                             defP       = escapePrinter (getPolicy h),+                             lineColorT = lineColorTrans (getPolicy h),+                             lineColorS = lineColorSuffix (getPolicy h)+                           }++-- | @'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,296 @@+%  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_help = desc ++ "\n" ++ command_help c+    , command_description = desc+    }+ where desc = "Alias for " ++ command_name 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+    }+\end{code}++\begin{code}+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\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" ++ 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+            _ -> []+\end{code}++\begin{code}+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')+\end{code}++\begin{code}+-- | 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,284 @@+%  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.++\subsection{darcs 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 )+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+\end{code}++\begin{code}+add_description :: String+add_description =+ "Add one or more new files or directories."+\end{code}++\options{add}++\haskell{add_help}++\begin{code}+add_help :: String+add_help =+ "Add needs to be called whenever you add a new file or directory to your\n"+++ "project.  Of course, it also needs to be called when you first create the\n"+++ "project, to let darcs know which files should be kept track of.\n"+\end{code}++\begin{code}+add :: DarcsCommand+add = DarcsCommand {command_name = "add",+                    command_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]}+\end{code}++Darcs will refuse to add a file or directory that differs from an existing+one only in case.  This is because the HFS+ file system used on MacOS+treats such files as being one and the same.++You can not add symbolic links to darcs.+If you try to do that, darcs will refuse and print an error message.+Perhaps you want to make symbolic links \emph{to} the files in darcs instead?++\begin{options}+--boring+\end{options}++By default darcs will ignore all files that match any of the boring patterns.+If you want to add such a file anyway you must use the \verb!--boring! option.++\begin{code}+add_cmd :: [DarcsFlag] -> [String] -> IO ()+add_cmd opts args = withRepoLock opts $- \repository ->+ do cur <- slurp_pending repository+    origfiles <- map toFilePath `fmap` fixSubPaths opts args+    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+    sequence_ $ map (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $+              flist \\ nboring flist+    date <- getIsoDateTime+    ps <- addp msgs opts date cur $ nboring flist+    when (nullFL ps && not (null args)) $ do+        fail "No files were added"+    when (not 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:"+    when (not (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 do return (cur, Nothing, Just f)+    else do+    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"+    }+\end{code}++\begin{options}+--date-trick+\end{options}++The \verb!--date-trick! option allows you to enable an experimental trick+to make add conflicts, in which two users each add a file or directory with+the same name, less problematic.  While this trick is completely safe, it+is not clear to what extent it is beneficial.++\begin{code}+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.++\subsection{darcs 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 )+import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info )+import Darcs.Repository ( withRepoLock, ($-), withGutsOf,+                    get_unrecorded, get_unrecorded_unsorted, slurp_recorded,+                    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 ( Test, NoTest, 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, list_registered_files,+                        get_easy_author, set_scripts_executable+                      )+import Darcs.Utils ( askUser )+import Printer ( putDocLn )+\end{code}+\begin{code}+amendrecord_description :: String+amendrecord_description =+ "Replace a patch with a better version before it leaves your repository."+\end{code}++\options{amend-record}++\haskell{amend-record_help}+If you provide one or more files or directories as additional arguments to+amend-record, you will only be prompted to changes in those files or+directories.++The old version of the patch is lost and the new patch will include both the+old and the new changes.  This is mostly the same as unrecording the old patch,+fixing the changes and recording a new patch with the same name and+description.++\verb!amend-record! will modify the date of the recorded patch.  +\begin{code}+amendrecord_help :: String+amendrecord_help =+ "Amend-record is used to replace a patch with a newer version with additional\n"+++ "changes.\n\n"+++ "WARNINGS: You should ONLY use amend-record on patches which only exist in a\n"+++ "single repository! Also, running amend-record while another user is pulling\n"+++ "from the same repository may cause repository corruption.\n" +\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+amendrecord_cmd :: [DarcsFlag] -> [String] -> IO ()+amendrecord_cmd origopts args =+    let opts = if NoTest `elem` origopts then origopts else Test:origopts+        edit_metadata = has_edit_metadata opts in+    withRepoLock 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_unsorted repository+              else get_unrecorded repository+        case ch of+          NilFL | not edit_metadata -> putStrLn "No changes!"+          _ -> do+              date <- get_date opts+              s <- slurp_recorded repository+              with_selected_changes_to_files' "add" (filter (==All) opts)+                s (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+                       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+\end{code}++If you configure darcs to run a test suite, darcs will run this test on the+amended 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 amended change is valid. If the+\verb!--set-scripts-executable! flag is passed to amend-record, darcs will set+scripts executable in the temporary test directory before running the test. ++\begin{code}+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,440 @@+%  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.++\subsection{darcs annotate}+\label{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"+\end{code}++\options{annotate}++\haskell{annotate_description}+\begin{code}+annotate_description :: String+annotate_description = "Display which patch last modified something."+\end{code}+\haskell{annotate_help}++\begin{code}+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"+\end{code}++\begin{code}+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 = if MachineReadable `elem` opts+                   then showPatchInfo+                   else if XMLOutput `elem` opts+                        then to_xml+                        else 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 doesn't yet work right 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+\end{code}++\begin{code}+annotate_cmd _ _ = fail "annotate accepts at most one argument"+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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+  sequence_ $ map (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) =+    if wheni == pinfo+    then putLine '-' l+    else if wheni `elem` old_pis+         then return ()+         else putLine ' ' l+text_markedup pinfo old_pis (l,AddedLine wheni) =+    if wheni == pinfo+    then putLine '+' l+    else if wheni `elem` old_pis+         then do putAnn $ text "Following line added by "+                       <> showPatchInfo wheni+                 putLine ' ' l+         else 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) =+    if wheni == pinfo+    then putDocLn $ text "<removed_line>"+                 $$ escapeXML (BC.unpack l)+                 $$ text "</removed_line>"+    else if wheni `elem` old_pis+         then return ()+         else 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) =+    if wheni == pinfo+    then putDocLn $ text "<added_line>"+                 $$ escapeXML (BC.unpack l)+                 $$ text "</added_line>"+    else if wheni `elem` old_pis+         then putDocLn $ text "<normal_line>"+                      $$ text "<added_by>"+                      $$ to_xml wheni+                      $$ text "</added_by>"+                      $$ escapeXML (BC.unpack l)+                      $$ text "</normal_line>"+         else 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,440 @@+%  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.++\subsection{darcs 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+                      )+import qualified Darcs.Arguments as DarcsArguments ( cc )+import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )+import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository,+                          tentativelyMergePatches, slurp_recorded,+                    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 )+#include "impossible.h"+\end{code}+\begin{code}+apply_description :: String+apply_description =+ "Apply patches (from an email bundle) to the repository."+\end{code}++\options{apply}++\haskell{apply_help}+\begin{code}+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"+\end{code}+\begin{code}+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],+                      command_basic_options = [verify,+                                              all_interactive]++dry_run+++                                              [apply_conflict_options,+                                              use_external_merge,+                                              notest,+                                              leave_test_dir,+                                              working_repo_dir]}+\end{code}+\begin{code}+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+  s <- slurp_recorded repository+  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 s 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+    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+\end{code}++\begin{code}+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,277 @@+%  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.++\subsection{darcs changes}+\begin{code}+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, PatternGuards #-}++module Darcs.Commands.Changes ( changes ) where++import Data.List ( 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,+                         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_unsorted,+                          withRepositoryDirectory, ($-), findRepository,+                          read_repo, slurp_recorded )+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 ByteStringUtils ( linesPS )+import Printer ( Doc, putDocLnWith, simplePrinters, renderPS, (<+>),+                 renderString, prefix,+                 packedString, text, vcat, vsep, ($$), empty, errorDoc )+import Darcs.ColorPrinter ( fancyPrinters )+import Darcs.Progress ( setProgressMode, debugMessage )+import Darcs.SelectChanges ( view_changes )+import Darcs.Sealed ( unsafeUnseal )+#include "impossible.h"+\end{code}++\options{changes}+\begin{code}+changes_description :: String+changes_description = "Gives a changelog-style summary of the repository history."+\end{code}+\haskell{changes_help}+\begin{code}+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,+                                                 only_to_files,+                                                 changes_format,+                                                 summary,+                                                 changes_reverse,+                                                 possibly_remote_repo_dir,+                                                 working_repo_dir,+                                                 all_interactive]}+\end{code}+++\begin{code}+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 <- get_unrecorded_unsorted repository+           `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,_,_) = filtered_changes patches+            s <- slurp_recorded repository+            view_changes opts s filez (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+            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{code}+get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p+                 -> ([PatchInfoAnd p], [FilePath], Doc)+get_changes_info opts plain_fs ps =+  case get_common_and_uncommon (p2s,p1s) of+  (_,us:\/:_) -> filter_patches_by_names 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++filter_patches_by_names :: RepoPatch p => [FilePath]+                        -> [PatchInfoAnd p]+                        -> ([PatchInfoAnd p],[FilePath], Doc)+filter_patches_by_names _ [] = ([], [], empty)+filter_patches_by_names [] pps = (pps, [], empty)+filter_patches_by_names fs (hp:ps)+    | Just p <- hopefullyM hp =+    case look_touch fs (invert p) of+    (True, []) -> ([hp], fs, empty)+    (True, fs') -> hp -:- filter_patches_by_names fs' ps+    (False, fs') -> filter_patches_by_names fs' ps+filter_patches_by_names _ (hp:_) =+    ([], [], text "Can't find changes prior to:" $$ description hp)++(-:-) :: a -> ([a],b,c) -> ([a],b,c)+x -:- (xs,y,z) = (x:xs,y,z)++changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([PatchInfoAnd p], [FilePath], Doc)+          -> Doc+changelog opts patchset (pis, fs, errstring)+    | Count `elem` opts = text $ show $ length pis+    | 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)+        $$ errstring+    | otherwise = vsep (map (number_patch description) pis)+               $$ errstring+    where change_with_summary hp+              | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts+                                          then description hp $$+                                               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+                             [z] | z `elem` fs -> NotEq+                             _ -> IsEq+          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) 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 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++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+    [] -> impossible+\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,128 @@+%  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.++\subsection{darcs check}+\begin{code}+module Darcs.Commands.Check ( check ) where+import Control.Monad ( when, unless )+import System.Exit ( ExitCode(..), exitWith )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( Quiet, NoTest ),+                        partial_check, notest,+                        leave_test_dir, working_repo_dir,+                      )+import Darcs.Repository.Repair( replayRepository,+                              RepositoryConsistency(..) )+import Darcs.Repository ( Repository, amInRepository, withRepository, ($-), slurp_recorded,+                          testTentative )+import Darcs.Patch ( RepoPatch, showPatch )+import Darcs.Ordered ( FL(..) )+import Darcs.Diff ( unsafeDiff )+import Darcs.Repository.Prefs ( filetype_function )+import Printer ( putDocLn, text, ($$), (<+>) )+\end{code}++\options{check}++\haskell{check_description}+\begin{code}+check_description :: String+check_description = "Check the repository for consistency."+\end{code}+Check verifies that the patches stored in the repository, when successively+applied to an empty tree, properly recreate the stored pristine tree.++\begin{options}+--complete, --partial+\end{options}++If you have a checkpoint of the repository (as is the case if you got the+repository originally using \verb!darcs get --partial!), by default+\verb'darcs check'+will only verify the contents since the most recent checkpoint.  You can+change this behavior using the \verb!--complete! flag.++\begin{code}+check_help :: String+check_help =+ "Check verifies that the patches stored in the repository, when successively\n"+++ "applied to an empty tree, properly recreate the stored pristine tree.\n"+\end{code}++\begin{code}+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+                                             ]}+\end{code}++\begin{code}+check_cmd :: [DarcsFlag] -> [String] -> IO ()+check_cmd opts _ = withRepository opts $- \repo -> check' repo opts++check' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO ()+check' repository opts = do+    res <- replayRepository repository opts $ \ state -> do+      case state of+        RepositoryConsistent -> do+          putInfo $ text "The repository is consistent!"+          unless (NoTest `elem` opts) $ testTentative repository+          return ExitSuccess+        BrokenPristine newpris -> do+          brokenPristine newpris+          return $ ExitFailure 1+        BrokenPatches newpris _ -> do+          brokenPristine newpris+          putInfo $ text "Found broken patches."+          return $ ExitFailure 1+    exitWith res+   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}++\input{Darcs/Test.lhs}++\begin{options}+--no-test+\end{options}++If you just want to check the consistency of your repository without+running the test, you can call darcs check with the \verb!--no-test!+option.+
+ src/Darcs/Commands/Convert.lhs view
@@ -0,0 +1,252 @@+%  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.++\subsection{darcs 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.Commands.Init ( initialize )+import Darcs.Arguments ( DarcsFlag( AllowConflicts, WorkDir,+                                    SetScriptsExecutable, UseFormat2, NoUpdateWorking,+                                    Verbose, Quiet ),+                        reponame,+                        set_scripts_executable,+                        network_options )+import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, read_repo,+                          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.Depends ( is_tag )+import Darcs.Patch.Info ( pi_rename, pi_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.Progress ( 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)++convert_description :: String+convert_description =+ "Convert a repository to darcs-2 format."+\end{code}++\options{convert}++You may specify the name of the repository created by providing a second+argument to convert, which is a directory name.++\begin{code}+convert_help :: String+convert_help =+ "Convert is used to convert a repository to darcs-2 format.\n\n" +++ "The recommended way to convert an existing project from darcs 1 to\n" +++ "darcs 2 is to merge all branches, `darcs convert' the resulting\n" +++ "repository, re-create each branch by using `darcs get' on the\n" +++ "converted repository, then using `darcs obliterate' to delete patches\n" +++ "of branches.\n"+\end{code}+\begin{code}+convert :: DarcsCommand+convert = DarcsCommand {command_name = "convert",+                    command_help = convert_help,+                    command_description = convert_description,+                    command_extra_args = -1,+                    command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],+                    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]}+\end{code}+\begin{code}+convert_cmd :: [DarcsFlag] -> [String] -> IO ()+convert_cmd opts [inrepodir, outname] = convert_cmd (WorkDir outname:opts) [inrepodir]+convert_cmd orig_opts [inrepodir] = do+  putDocLn $ text "WARNING: the repository produced by this command is not understood by" $$+             text "the darcs 1 program, and patches cannot be exchanged between" $$+             text "repositories in darcs 1 and darcs 2 formats.\n" $$+             text "Furthermore, darcs 2 repositories created by different invocations of" $$+             text "this command SHOULD NOT exchange patches, unless those repositories" $$+             text "had no patches in common when they were converted.  (That is, within a" $$+             text "set of repos that exchange patches, no patch should be converted more" $$+             text "than once.)\n" $$+             text "This command DOES NOT modify the source repository.  It is safe to run" $$+             text "this command more than once on a single repository, but the resulting" $$+             text "repositories will not be able to exchange patches.\n" $$+             text "Please confirm that you have read and understood the above"+  let vow = "I understand the consequences of my action"+  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+  (command_command initialize) 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+      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."+\end{code}++\begin{code}+make_repo_name :: [DarcsFlag] -> FilePath -> IO String+make_repo_name (WorkDir 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,251 @@+%  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.++\subsection{darcs 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 Autoconf ( 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, putDocLn, vcat, empty, ($$) )+#include "impossible.h"+\end{code}++\options{diff}+\begin{code}+diff_description :: String+diff_description = "Create a diff between two versions of the repository."+\end{code}+\haskell{diff_help}+\begin{code}+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 :: [DarcsFlag] -> String -> String+                      -> Either String (String, [String])+get_diff_cmd_and_args 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 (diff_program, ("-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+    putDocLn $ changelog (get_diff_info opts morepatches)+            $$ thediff+    where rundiff :: String -> String -> IO Doc+          rundiff f1 f2 =+            case get_diff_cmd_and_args 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+\end{code}++\begin{code}+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,148 @@+%  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.++\subsection{darcs dist}+\begin{code}+module Darcs.Commands.Dist ( dist ) where+import System.Directory ( setCurrentDirectory )+import Workaround ( getCurrentDirectory )+import System.Exit ( ExitCode(..) )+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 ( toFilePath )+import Darcs.Utils ( withCurrentDirectory )+import Exec ( exec, Redirect(..) )++\end{code}++\options{dist}++\haskell{dist_description}++\begin{code}+dist_description :: String+dist_description =+ "Create a distribution tarball."+\end{code}++\haskell{dist_help} Basically, you will typically use it in a makefile+rule such as+\begin{verbatim}+dist:+    darcs dist --dist-name darcs-`./darcs --version`+\end{verbatim}+\verb!darcs dist! then simply creates a clean copy of the source tree,+which it then tars and gzips.  If you use programs such as autoconf or+automake, you really should run them on the clean tree before tarring it up+and distributing it.  You can do this using the pref value ``predist'',+which is a shell command that is run prior to tarring up the distribution:+\begin{verbatim}+% darcs setpref predist "autoconf && automake"+\end{verbatim}++\begin{code}+dist_help :: String+dist_help =+ "Dist creates a tarball from a clean copy of the recorded edition of\n"+++ "your tree, eventually augmented by running the shell command specified\n"+++ "with the \"predist\" preference.\n"+\end{code}++\begin{code}+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]}+\end{code}++\begin{code}+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)+        case predist of Nothing -> return ExitSuccess+                        Just pd -> system pd+        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/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.++\subsection{darcs get}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Get ( get ) where++import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,+                          createDirectory )+import Workaround ( getCurrentDirectory )+import Data.Maybe ( isJust )+import Control.Monad ( when )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag( WorkDir, Partial, Lazy,+                                    UseFormat2, UseOldFashionedInventory, UseHashedInventory,+                                    SetScriptsExecutable, Quiet, OnePattern ),+                        get_context, pristine_tree, get_inventory_choices, working_repo_dir,+                        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 )+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 )+import Darcs.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 )+#include "impossible.h"+\end{code}+\begin{code}+get_description :: String+get_description =+ "Create a local copy of another repository."+\end{code}++\options{get}++If the remote repository and the current directory are in the same filesystem and+that filesystem supports hard links, get will create hard links for the+patch files, which means that the additional storage space needed will be+minimal.  This is \emph{very} good for your disk usage (and for the speed+of running get), so if you want multiple copies of a repository, I strongly+recommend first running \verb!darcs get! to get yourself one copy, and then+running \verb!darcs get! on that copy to make any more you like.  The only+catch is that the first time you run \verb!darcs push! or \verb!darcs pull!+from any of these second copies, by default they will access your first+copy---which may not be what you want.++You may specify the name of the repository created by providing a second+argument to get, which is a directory name.++\begin{code}+get_help :: String+get_help =+ "Get is used to get a local copy of a repository.\n"+\end{code}+\begin{code}+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, pristine_tree,+                                             get_inventory_choices,+                                             working_repo_dir]}+\end{code}+\begin{code}+get_cmd :: [DarcsFlag] -> [String] -> IO ()+get_cmd opts [inrepodir, outname] = get_cmd (WorkDir 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 format_has HashedInventory rfsource &&+                      not (UseOldFashionedInventory `elem` opts)+                   then UseHashedInventory:filter (/= UseFormat2) opts+                   else UseOldFashionedInventory:filter (/= UseFormat2) opts+  (command_command initialize) 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++\end{code}++\begin{code}+make_repo_name :: [DarcsFlag] -> FilePath -> IO String+make_repo_name (WorkDir 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}++\begin{options}+--context, --tag, --to-patch, --to-match+\end{options}+If you want to get a specific version of a repository, you have a few+options.  You can either use the \verb!--tag!, \verb!--to-patch! or+\verb!--to-match! options, or you can use the \verb!--context=FILENAME!+option, which specifies a file containing a context generated with+\verb!darcs changes --context!.  This allows you (for example) to include in+your compiled program an option to output the precise version of the+repository from which it was generated, and then perhaps ask users to+include this information in bug reports.++Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may+get a version of your code that has never before been seen, if the patches+have gotten themselves reordered.  If you ever want to be able to precisely+reproduce a given version, you need either to tag it or create a context+file.++\begin{code}+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) ++ " " +++                   (patch_or_patches $ lengthFL ps)+       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++patch_or_patches :: Int -> String+patch_or_patches 1 = "patch."+patch_or_patches _ = "patches."++\end{code}++\begin{options}+--partial+\end{options}+Only get the patches since the last checkpoint. This will save time,+bandwidth and disk space, at the expense of losing the history before+the checkpoint.++\begin{options}+--no-pristine-tree+\end{options}+In order to save disk space, you can use {\tt get} with the+\verb|--no-pristine-tree| flag to create a repository with no pristine+tree.  Please see Section~\ref{disk-usage} for more information.+++\begin{code}++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" ++ show 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,126 @@+%  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.++\subsection{darcs help}+\label{help}++You could also call \verb|help| as a command.  This is equivalent to calling+darcs --help.  +the \verb|--help| to that command.  For example, \verb|darcs help query manifest|+is equivalent to \verb|darcs query manifest --help|.++\begin{code}+module Darcs.Commands.Help ( help_cmd, command_control_list, print_version,+                             list_available_commands+                           ) where+import System.Exit ( ExitCode(..), exitWith )++import Autoconf( darcs_version )+import Darcs.Commands ( CommandControl(Command_data), DarcsCommand(..),+                        disambiguate_commands, CommandArgs(..),+                        get_command_help, extract_commands,+                       nodefaults, +                       usage )+import Darcs.Arguments ( DarcsFlag(..), help_on_match )+import Darcs.External ( viewDoc )+import Darcs.Patch.Match ( helpOnMatchers )+import Darcs.Utils ( withCurrentDirectory )+import Printer ( text )+import Workaround ( getCurrentDirectory )+import qualified Darcs.TheCommands as TheCommands+\end{code}++\options{help}++\haskell{help_description}+\begin{code}+help_description :: String+help_description = "Display help for darcs or a single command."+\end{code}+\haskell{help_help} ++\begin{code}+help_help :: String+help_help =+ "help displays usage information for darcs in general or for a single\n" +++ "command (for example, darcs help query manifest).\n\n"+\end{code}++\begin{code}+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 = help_cmd,+                     command_prereq = \_ -> return $ Right (),+                     command_get_arg_possibilities = return [],+                     command_argdefaults = nodefaults,+                     command_advanced_options = [],+                     command_basic_options = [help_on_match]}+\end{code}++\begin{code}+help_cmd :: [DarcsFlag] -> [String] -> IO ()+help_cmd opts [] =+    do viewDoc $ text $+         case () of _ | HelpOnMatch `elem` opts -> helpOnMatchers+                      | otherwise -> usage command_control_list+       exitWith $ ExitSuccess++help_cmd _ (cmd:args) =+    do let disambiguated = disambiguate_commands command_control_list cmd args+       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+       exitWith $ ExitSuccess++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+\end{code}++\begin{code}+print_version :: IO () +print_version = putStrLn $ "darcs version " ++ darcs_version+\end{code}++\begin{code}+-- avoiding a module import cycle between Help and TheCommands+command_control_list :: [CommandControl] +command_control_list =+  Command_data help : TheCommands.command_control_list+\end{code}+
+ src/Darcs/Commands/Init.lhs view
@@ -0,0 +1,131 @@+%  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.++\subsection{darcs initialize}\label{initialize}+\begin{code}+module Darcs.Commands.Init ( initialize, initialize_cmd ) where+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Arguments ( DarcsFlag, pristine_tree, working_repo_dir,+                        inventory_choices )+import Darcs.Repository ( amNotInRepository, createRepository )+\end{code}++\options{initialize}++\haskell{initialize_description}++\begin{code}+initialize_description :: String+initialize_description = "Initialize a new source tree as a darcs repository."+\end{code}+Call \verb|initialize| once for each project you work on. Run it from the top+level directory of the project, with the project files already there. +\verb|initialize| will set up all the directories and files darcs needs in order to+start keeping track of revisions for your project.++\begin{code}+initialize_help :: String+initialize_help =+ "Call initialize once for each project you work on. Run it from the top\n"+++ "level directory of the project, with the project files already there.\n"+++ "Initialize will set up all the directories and files darcs needs in order to\n"+++ "start keeping track of revisions for your project.\n"+\end{code}++\begin{code}+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 = [pristine_tree, inventory_choices,+                                                  working_repo_dir]}+\end{code}++\verb|initialize| creates a single directory named \verb|_darcs|, with contents+for internal use. The one subdictory of interest to users is+\verb'_darcs/prefs', which will include an empty file \verb'_darcs/prefs/motd'+(see Section~\ref{motd}), as well as files named \verb'boring' and+\verb'binaries', which contain useful defaults as described in Sections+\ref{boring} \emph{et seq.}++\begin{options}+--old-fashioned-inventory+--hashed+--darcs-2+\end{options}++These options describe possible repository formats to use. ++\verb'old-fashioned-inventory' is now deprecated and should be avoided if at+all possible.++\verb'hashed' Offers several features while still being compatible with old-fashioned repositories. The specific features are:++\begin{itemize}  ++\item The hashed format allows for greater atomicity of operations. This makes for greater safety and simultaneously greater efficiency. These benefits, however, have not been fully realized in this release. For instance, with a hashed repository, there is no need for darcs push to require a repository lock, so you could record patches while waiting for a push to finish (for instance, if it's waiting on the test suite).++\item The \verb!_darcs/pristine! directory no longer holds the pristine+cache. This disallows certain hackish short-cuts, but also dramatically+reduces the danger of third-party programs (e.g. DreamWeaver) recursing+into the pristine cache and corrupting darcs repositories.++\item Darcs get can optionally operate in a much faster ``lazy''+fashion, meaning that patches are downloaded only when they are+needed. This gives us much of the benefits of --partial repositories,+without most of their disadvantages. This approach, however, does have+several new dangers. First, some operations may unexpectedly require the+download of large numbers of patches, which could be slow (but you could+always interrupt with \verb!^C!). Secondly, if the source repository disappears,+or you lose network connectivity, some operations may fail.++\item Darcs now supports caching of patches and file contents to reduce bandwidth and save disk space. It greatly speeds up a number of operations, and is essentially transparent. The only reason we don't enable it by default is because it creates a large directory in ~/.darcs/cache without the user's explicit consent.++\end{itemize}++\verb'darcs-2' Is the default.  It enables all available features, and+requiring that all repos for a project use the same format. In addition to the+features of the \verb'hashed' format described above, the \verb'darcs-2' format+also enables the following:++\begin{itemize}++\item It should no longer be possible to confuse darcs or freeze it indefinitely by merging conflicting changes. ++\item Identical primitive changes no longer conflict. This is a long-requested feature, and has far-reaching implications. ++\end{itemize}++\begin{options}+--no-pristine-tree+\end{options}+In order to save disk space, you can use \verb|initialize| with the+\verb|--no-pristine-tree| flag to create a repository with no pristine+tree.  Please see Section~\ref{disk-usage} for more information.++\begin{code}+initialize_cmd :: [DarcsFlag] -> [String] -> IO ()+initialize_cmd opts _ = createRepository opts+\end{code}+
+ src/Darcs/Commands/MarkConflicts.lhs view
@@ -0,0 +1,105 @@+%  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.++\subsection{darcs 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"+\end{code}+\begin{code}+markconflicts_description :: String+markconflicts_description =+ "Mark any conflicts to the working copy for manual resolution."+\end{code}++\options{mark-conflicts}++\haskell{mark-conflicts_help}++\begin{code}+markconflicts_help :: String+markconflicts_help =+ "Mark-conflicts is used to mark and resolve any conflicts that may exist in a\n"+++ "repository.  Note that this trashes any unrecorded changes in the working\n"+++ "copy.\n"+\end{code}+\begin{code}+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]}+\end{code}++\begin{code}+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+\end{code}++% resolve - not documented because hidden++\begin{code}+resolve :: DarcsCommand+resolve = command_alias "resolve" markconflicts+\end{code}
+ src/Darcs/Commands/Mv.lhs view
@@ -0,0 +1,213 @@+%  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.++\subsection{darcs mv}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Mv ( mv, move ) where+import Control.Monad ( when, unless )+import Data.Maybe ( catMaybes )+import Darcs.SignalHandler ( withSignalsBlocked )++import Darcs.Commands ( DarcsCommand(..), nodefaults )+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+#include "impossible.h"+\end{code}++\begin{code}+mv_description :: String+mv_description =+ "Move/rename one or more files or directories."+\end{code}++\options{mv}++\haskell{mv_help} This is why ``mv'' isn't called ``move'', since it is+really almost equivalent to the unix command ``mv''.++\begin{options}+--case-ok+\end{options}++Darcs mv will by default refuse to rename a file if there already exists a+file having the same name apart from case.  This is because doing so could+create a repository that could not be used on file systems that are case+insensitive (such as Apple's HFS+).  You can override this by with the flag+\verb!--case-ok!.++\begin{code}+mv_help :: String+mv_help =+ "Darcs mv needs to be called whenever you want to move files or\n"+++ "directories. Unlike remove, mv actually performs the move itself in your\n"+++ "working copy.\n"+\end{code}++\begin{code}+mv :: DarcsCommand+mv = DarcsCommand {command_name = "mv",+                   command_help = mv_help,+                   command_description = mv_description,+                   command_extra_args = -1,+                   command_extra_arg_help = ["[FILE or DIRECTORY]..."],+                   command_command = mv_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]}+mv_cmd :: [DarcsFlag] -> [String] -> IO ()+mv_cmd _ [] = fail "You must specify at least two arguments for mv"+mv_cmd _ [_] = fail "You must specify at least two arguments for mv"+\end{code}++\begin{code}+mv_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 mv_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)+    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+\end{code}++\begin{code}+mv_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+    withSignalsBlocked $ do+      add_to_pending repository $ unsafeFL $ catMaybes addpatches ++ movepatches+      sequence_ $ zipWith (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 ()+\end{code}+++% move - Note: not a subsection because not to be documented.++\begin{code}+move_description :: String+move_description =+ "Alias for 'mv'"++move_help :: String+move_help =+ "Alias for 'mv'\n" ++ mv_help++move :: DarcsCommand+move = mv {command_name = "move",+           command_help = move_help,+           command_description = move_description }+\end{code}++
+ src/Darcs/Commands/Optimize.lhs view
@@ -0,0 +1,323 @@+%  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.++\subsection{darcs 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 Darcs.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"+\end{code}+\begin{code}+optimize_description :: String+optimize_description =+ "Optimize the repository."+\end{code}++\options{optimize}++\haskell{optimize_help}++\begin{code}+optimize_help :: String+optimize_help =+ "Optimize can help to improve the performance of your repository in a number of cases.\n"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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 "+\end{code}++Optimize always 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.++\begin{code}+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."+\end{code}++\begin{options}+--checkpoint, --tag+\end{options}++If you use the \verb!--checkpoint! option, optimize creates a checkpoint patch+for a tag.  You can specify the tag with the \verb!--tag! option, or+just let darcs choose the most recent tag.  Note that optimize+\verb!--checkpoint! will fail when used on a ``partial'' repository.  Also,+the tag that is to be checkpointed must not be preceded by any patches+that are not included in that tag.  If that is the case, no checkpointing+is done.++The created checkpoint is used by the \verb!--partial! flag to +\verb!get! and \verb!check!. This allows for users to retrieve+a working repository with limited history with a savings of disk+space and bandwidth. ++++\begin{code}+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+\end{code}++\begin{code}+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+\end{code}++\begin{options}+--compress, --dont-compress, --uncompress+\end{options}++Some compression options are available, and are independent of the+\verb!--checkpoint! option.++By default the patches in the repository are compressed. These use less+disk space, which translates into less bandwidth if the repository is accessed+remotely.++Note that in the darcs-1.0 (also known as ``old fashioned inventory'')+repository format, patches will always have the ``.gz'' extension whether+they are compressed or not.++You may want to uncompress the patches when you've got enough disk space but+are running out of physical memory.++If you give the \verb!--compress! option, optimize will compress all the+patches in the repository.  Similarly, if you give the \verb!--uncompress!,+optimize will decompress all the patches in the repository.+\verb!--dont-compress!  means ``don't compress, but don't uncompress+either''. It would be useful if one of the compression options was provided+as a default and you wanted to override it.++\begin{code}+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++\end{code}++\begin{options}+--relink+\end{options}++The \verb|--relink| and \verb|--relink-pristine| options cause Darcs+to relink files from a sibling.  See Section \ref{disk-usage}.+++\begin{code}+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}+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,283 @@+%  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.++\subsection{darcs 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+                      )+import Darcs.Repository ( Repository, SealedPatchSet, identifyRepositoryFor, withGutsOf,+                          amInRepository, withRepoLock, ($-), tentativelyMergePatches,+                          sync_repo, finalizeRepositoryChanges, applyToWorking,+                          slurp_recorded, 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 )+#include "impossible.h"+\end{code}+\begin{code}+pull_description :: String+pull_description =+ "Copy and apply patches from another repository to this one."+\end{code}++\options{pull}++\haskell{pull_help}+\begin{code}+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"+\end{code}+\begin{code}+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] +++                                                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]}+\end{code}+\begin{code}+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+     s <- slurp_recorded repository+     with_selected_changes "pull" opts s 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+      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"+\end{code}++\begin{code}++{- 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,264 @@+%  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.++\subsection{darcs 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, slurp_recorded,+                          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"+\end{code}+\begin{code}+push_description :: String+push_description =+ "Copy and apply patches from this repository to another one."+\end{code}++\options{push}+\haskell{push_help}+\begin{code}+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"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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 "Can't push to current repository!"+       -- 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+     s <- slurp_recorded repository+     with_selected_changes "push" opts s (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+\end{code}+\begin{code}+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,179 @@+\subsection{darcs 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 Darcs.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"+\end{code}+\begin{code}+put_description :: String +put_description =+ "Makes a copy of the repository"+\end{code}+\options{put}+\haskell{put_help}+\begin{code}+put_help :: String+put_help = + "Put is the opposite of get. Put copies the content of the current \n" +++ "repository and puts it in a newly created repository.\n"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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 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}++\emph{WARNING:} Put is far less optimized than get, especially for local+repositories.  We recommend avoiding use of put except for small+repositories.++Put is used when you already have a repository and want to make a copy+of it.  A typical use-case is when you want to branch your project.++Put works by first initializing a repository. If the new repository is+not on the local file system then darcs will login to the remote host+and run \verb!darcs init! there. After the new repository is created+all selected patches will be pushed just as with the command+\verb!push!.++\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}+--context, --tag, --to-patch, --to-match+\end{options}+If you want to put a specific version of a repository, you have a few+options.  You can either use the \verb!--tag!, \verb!--to-patch! or+\verb!--to-match! options, or you can use the \verb!--context=FILENAME!+option, which specifies a file containing a context generated with+\verb!darcs changes --context!.  This allows you (for example) to include in+your compiled program an option to output the precise version of the+repository from which it was generated, and then perhaps ask users to+include this information in bug reports.++Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may+get a version of your code that has never before been seen, if the patches+have gotten themselves reordered.  If you ever want to be able to precisely+reproduce a given version, you need either to tag it or create a context+file.
+ src/Darcs/Commands/Record.lhs view
@@ -0,0 +1,516 @@+%  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.++\subsection{darcs record}+\label{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 ( 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, get_unrecorded_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, Test, NoTest, NoEditLongComment,+                                    EditLongComment, RmLogFile, LogFile, Pipe,+                                    PatchName, AskDeps, All ),+                         get_author, working_repo_dir, lookforadds,+                         fixSubPaths, defineChanges,+                         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 Darcs.Progress ( debugMessage, progressFL )+import IsoDate ( getIsoDateTime, cleanLocalDate )+import Printer ( hPutDocLn, text, wrap_text, ($$), renderString )+#include "impossible.h"+\end{code}+\begin{code}+record_description :: String+record_description =+ "Save changes in the working copy to the repository as a patch."+\end{code}++\options{record}++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."+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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+\end{code}+\begin{code}+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 origopts args = do+    check_name_is_not_option origopts++    let (logMessage,_, _) = loggers opts+        opts = if NoTest `elem` origopts then origopts else Test:origopts+        +    withRepoLock 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."+    changes <- if All `elem` opts then get_unrecorded_unsorted repository+                                  else get_unrecorded repository+    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` origopts = 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."+    s <- slurp_recorded repository+    debugMessage "About to select changes..."+    with_selected_changes_to_files' "record" opts+      s (map toFilePath files) ps $ \ (chs:>_) ->+      if is_empty_but_not_askdeps chs+        then putStrLn "Ok, if you don't want to record anything, that's fine!"+        else 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+                 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, [], 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, [], 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) empty_slurpy 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,143 @@+%  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.++\subsection{darcs remove}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Darcs.Commands.Remove ( remove, rm, unadd ) where++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, 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 )+#include "impossible.h"+\end{code}++\begin{code}+remove_description :: String+remove_description =+ "Remove one or more files or directories from the repository."+\end{code}++\options{remove}++\haskell{remove_help}++\begin{code}+remove_help :: String+remove_help =+ "Remove should be called when you want to remove a file from your project,\n"+++ "but don't actually want to delete the file.  Otherwise just delete the\n"+++ "file or directory, and darcs will notice that it has been removed.\n" +++ "Be aware that the file WILL be deleted from any other copy of the\n" +++ "repository to which you later apply the patch.\n"+\end{code}++\begin{code}+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]}+\end{code}++\begin{code}+remove_cmd :: [DarcsFlag] -> [String] -> IO ()+remove_cmd opts relargs =+    withRepoLock opts $- \repository -> do+    args <- fixSubPaths opts relargs+    p <- make_remove_patch repository args+    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 repository+                             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+\end{code}++% rm - Note: not a subsection because not to be documented.++\begin{code}+rm_description :: String+rm_description =+ "Does not actually do anything, but offers advice on removing files"++rm_help :: String+rm_help =+ "This command does not do anything.\n"+++ "If you want to remove a file AND delete it, just delete the file or directory,\n"+++ "and darcs will notice that it has been removed.\n" +++ "If you want to remove a file WITHOUT deleting it, use the 'remove' command\n"++rm :: DarcsCommand+rm = command_stub "rm" rm_help rm_description remove+\end{code}++% unadd - Note: not a subsection because not to be documented.++\begin{code}+unadd :: DarcsCommand+unadd = command_alias "unadd" remove+\end{code}++
+ src/Darcs/Commands/Repair.lhs view
@@ -0,0 +1,84 @@+%  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.++\subsection{darcs 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(..) )+\end{code}++\options{repair}+\begin{code}+repair_description :: String+repair_description = "Repair the corrupted repository."+\end{code}+\haskell{repair_help}++\begin{code}+repair_help :: String+repair_help =+ "Repair attempts to fix corruption that may have entered your\n"+++ "repository.\n"+\end{code}++\begin{code}+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]}+\end{code}++Repair currently will only repair damage to the pristine tree.+Fortunately this is just the sort of corruption that is most+likely to happen.++\begin{code}++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,210 @@+%  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.++\subsection{darcs 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"+\end{code}++\begin{code}+replace_description :: String+replace_description =+ "Replace a token with a new value for that token."+\end{code}++\options{replace}++\haskell{replace_help}++The default regexp is \verb![A-Za-z_0-9]!), and if one of your tokens+contains a `\verb|-|' or `\verb|.|', you will then (by default) get the ``filename''+regexp, which is \verb![A-Za-z_0-9\-\.]!.++\begin{options}+--token-chars+\end{options}++If you prefer to choose a different set of characters to define your token+(perhaps because you are programming in some other language), you may do so+with the \verb!--token-chars! option.  You may prefer to define tokens in terms+of delimiting characters instead of allowed characters using a flag such as+\verb!--token-chars '[^ \n\t]'!, which would define a token as being+white-space delimited.++If you do choose a non-default token definition, I recommend using+\verb!_darcs/prefs/defaults! to always specify the same+\verb!--token-chars!, since your replace patches will be better behaved (in+terms of commutation and merges) if they have tokens defined in the same+way.++When using darcs replace, the ``new'' token may not already appear in the+file---if that is the case, the replace change would not be invertible.+This limitation holds only on the already-recorded version of the file.++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_help :: String+replace_help =+ "Replace allows you to change a specified token wherever it\n"+++ "occurs in the specified files.  The replace is encoded in a\n"+++ "special patch and will merge as expected with other patches.\n"+++ "Tokens here are defined by a regexp specifying the characters\n"+++ "which are allowed.  By default a token corresponds to a C identifier.\n"+\end{code}++\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]}+\end{code}++\begin{code}+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]"+\end{code}++\begin{code}+default_toks :: String+default_toks = "A-Za-z_0-9"+filename_toks :: String+filename_toks = "A-Za-z_0-9\\-\\."+is_tok :: String -> String -> Bool+is_tok _ "" = False+is_tok toks s = and $ map (regChars toks) s++choose_toks :: [DarcsFlag] -> String -> String -> IO String+choose_toks (Toks t:_) a b+    | any isSpace t = fail $ bad_token_spec $ "Space is not allowed in the spec"+    | length t <= 2 = fail $ bad_token_spec $+                        "It must contain more than 2 characters, because " +++                        "it should be enclosed in square brackets"+    | head t /= '[' || last t /= ']' = fail $ bad_token_spec $+                        "It should be enclosed in square brackets"+    | not (is_tok tok a) = fail $ bad_token_spec $ not_a_token a+    | not (is_tok tok b) = fail $ bad_token_spec $ not_a_token b+    | otherwise          = return tok+    where tok = init $ tail t :: String+          bad_token_spec msg = "Bad token spec: '"++ t ++"' ("++ msg ++")"+          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,123 @@+%  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.++\subsection{darcs 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 )+import Darcs.Repository ( withRepoLock, ($-), withGutsOf,+                    get_unrecorded, get_unrecorded_unsorted,+                    add_to_pending, sync_repo,+                    applyToWorking,+                    amInRepository, slurp_recorded_and_unrecorded,+                  )+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 )+\end{code}+\begin{code}+revert_description :: String+revert_description =+ "Revert to the recorded version (not always reversible)."+\end{code}++\options{revert}++\haskell{revert_help} The actions of a revert may be reversed using the+unrevert command (see subsection~\ref{unrevert}).  However, if you've made+changes since the revert your mileage may vary, so please be careful.++\begin{code}+revert_help :: String+revert_help =+ "Revert is used to undo changes made to the working copy which have\n"+++ "not yet been recorded.  You will be prompted for which changes you\n"+++ "wish to undo. The last revert can be undone safely using the unrevert\n"+++ "command if the working copy was not modified in the meantime.\n"+\end{code}+\begin{code}+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]}+\end{code}+You can give revert optional arguments indicating files or directories.  If+you do so it will only prompt you to revert changes in those files or in+files in those directories.+\begin{code}+revert_cmd :: [DarcsFlag] -> [String] -> IO ()+revert_cmd opts args = withRepoLock opts $- \repository -> do+  files <- sort `fmap` fixSubPaths opts args+  when (areFileArgs files) $+       putStrLn $ "Reverting changes in "++unwords (map show files)++"..\n"+  changes <- if All `elem` opts+                   then get_unrecorded_unsorted repository+                   else get_unrecorded repository+  let pre_changed_files = apply_to_filepaths (invert changes) (map toFilePath files)+  (rec, working_dir) <- slurp_recorded_and_unrecorded 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 working_dir+               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+                 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,162 @@+%  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.++\subsection{darcs 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,+                          slurp_recorded_and_unrecorded, read_repo, slurp_recorded,+                          tentativelyMergePatches, withGutsOf,+                          finalizeRepositoryChanges, sync_repo )+import Darcs.Patch ( summary, invert, namepatch, effect, fromPrims, sort_coalesceFL )+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 Darcs.Progress ( debugMessage )+import Darcs.Sealed ( Sealed(..), FlippedSeal(..) )+import IsoDate ( getIsoDateTime )+#include "impossible.h"+\end{code}++\begin{code}+rollback_description :: String+rollback_description =+ "Record a new patch reversing some recorded changes."+\end{code}++\options{rollback}++\haskell{rollback_help} 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"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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!"+  (recorded, working_dir) <- slurp_recorded_and_unrecorded repository+  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 recorded 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 working_dir+               existing_files (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 (show $ 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..."+            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,453 @@+%  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.++\subsection{darcs 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 )+import Data.Maybe ( isJust, isNothing )++import Autoconf ( have_HTTP )+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 Darcs.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"+\end{code}+\begin{code}+send_description :: String+send_description =+ "Send by email a bundle of one or more patches."+\end{code}++\options{send}++\haskell{send_help}+\begin{code}+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]}+\end{code}+\begin{code}+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 s 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 when (isJust mailfile) $+                                       putStrLn $ msg++(fromJust mailfile)++"."+                                  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}++forM_ :: (Monad m) => [a] -> (a -> m b) -> m ()+forM_ = (flip mapM_)++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+          check_post | have_HTTP =+                         do p <- ((readPost . BC.unpack) `fmap`+                                  fetchFilePS (prefsUrl the_remote_repo++"/post")+                                  (MaxAge 600)) `catchall` return []+                            emails <- who_to_email+                            return (p++emails)+                     | otherwise = who_to_email+          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 []+          readPost p = map pp (lines p) where+            pp ('m':'a':'i':'l':'t':'o':':':s) = SendMail s+            pp s = Post s+          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)+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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,122 @@+%  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.++\subsection{darcs 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, )+#include "impossible.h"+\end{code}++\begin{code}+setpref_description :: String+setpref_description =+ "Set a value for a preference (test, predist, ...)."+\end{code}++\options{setpref}+Usage example:+\begin{verbatim}+% darcs setpref test "echo I am not really testing anything."+\end{verbatim}++\haskell{setpref_help} If you just want to set the pref value in your+repository only, you can just edit ``\verb!_darcs/prefs/prefs!''.  Changes+you make in that file will be preserved.++The ``\verb!_darcs/prefs/prefs!'' holds the only preferences information+that can propagate between repositories by pushes and pulls, and the only+way this happens is when the setprefs command is used.  Note that although+prefs settings are included in patches, they are \emph{not} fully version+controlled.  In particular, depending on the order in which a series of+merges is performed, you may end up with a different final prefs+configuration.  In practice I don't expect this to be a problem, as the+prefs usually won't be changed very often.++\begin{code}+valid_pref_data :: [String]+valid_pref_data = ["test", "predist", "boringfile", "binariesfile"]+\end{code}+The following values are valid preferences options which can be configured+using setpref:+\begin{itemize}+\item ``test'' --- the command to run as a test script.+\item ``predist'' --- a command to run prior to tarring up a distribution+  tarball.  Typically this would consist of autoconf and/or automake.+\item ``boringfile'' --- the name of a file to read instead of the+  ``boring'' prefs file.+\item ``binariesfile'' --- the name of a file to read instead of the+  ``binaries'' prefs file.+\end{itemize}++\begin{code}+setpref_help :: String+setpref_help =+ "Setpref allows you to set a preference value in a way that will\n"+++ "propagate to other repositories.\n\n"+++ "Valid preferences are: "++unwords valid_pref_data++".\n"+\end{code}++\begin{code}+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_pref_data,+                        command_argdefaults = nodefaults,+                        command_advanced_options = [umask_option],+                        command_basic_options =+                            [working_repo_dir]}+\end{code}++\begin{code}+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_pref_data) $ do+    putStrLn $ "'"++pref++"' is not a valid preference name!"+    putStrLn $ "Try one of:  "++unwords valid_pref_data++""+    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,71 @@+%  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.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"++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_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,77 @@+%  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.++\subsubsection{darcs show authors}+\begin{code}+module Darcs.Commands.ShowAuthors ( show_authors ) where++import Data.List ( sort, group )++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 )+\end{code}++\options{show authors}++\haskell{show_authors_help}++\begin{code}+show_authors_description :: String+show_authors_description = "Show all authors in the repository."+\end{code}++\begin{code}+show_authors_help :: String+show_authors_help =+ "The authors command writes a list of all patch authors in the repository to\n" +++ "standard output."+\end{code}++\begin{code}+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+  let authors = mapRL process $ concatRL patches+  viewDoc $ text $ unlines $+   if Verbose `elem` opts+      then authors+      else reverse $ map shownames $ sort $+           map (\s -> (length s,head s)) $ group $ sort authors+  where+    process =  pi_author . info+    shownames (n, a) = show n ++ "\t" ++ a+\end{code}
+ src/Darcs/Commands/ShowBug.lhs view
@@ -0,0 +1,60 @@+%  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.++\subsection{darcs 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"+\end{code}++\options{show bug}+\begin{code}+show_bug_description :: String+show_bug_description = "Pretends to be a bug in darcs."+\end{code}+\haskell{show_bug_help}+\begin{code}+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]}+\end{code}++\begin{code}+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,79 @@+%  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.++\subsubsection{darcs 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 )+\end{code}++\options{show contents}+\begin{code}+show_contents_description :: String+show_contents_description = "Outputs a specific version of a file."+\end{code}+\haskell{show_contents_help}+\begin{code}+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]}+\end{code}++\begin{code}+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,108 @@+%  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.++\subsubsection{darcs show files}+\label{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 )+\end{code}++\options{show files}++\haskell{show_files_help}++By default (and if the \verb!--pending! option is specified),+the effect of pending patches on the repository is taken into account.+In other words, if you add a file using {\tt darcs add}, it+immediately appears in the output of {\tt query manifest}, even if it+is not yet recorded.  If you specify the \verb!--no-pending! option,+{\tt query manifest} will only list recorded files (and directories).++The \verb!--files! and \verb!--directories! options control whether+files and directories are included in the output.  The+\verb!--no-files!  and \verb!--no-directories! options have the+reverse effect.  The default is to include files, but not directories.++If you specify the \verb!--null! option, the file names are written to+standard output in unescaped form, and separated by ASCII NUL bytes.+This format is suitable for further automatic processing (for example,+using \verb!xargs -0!).++\begin{code}+show_files_description :: String+show_files_description = "Show version-controlled files in the working copy."+\end{code}++\begin{code}+show_files_help :: String+show_files_help =+ "The files command lists the version-controlled files in the\n"+++ "working copy.  The similar manifest command, lists the same\n"+++ "files, excluding any directories.\n"+\end{code}++\begin{code}+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/ShowRepo.lhs view
@@ -0,0 +1,193 @@+%  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.++\subsubsection{darcs show repo}+%%\label{show-repo}++\options{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.Global ( darcsdir )+import Darcs.Patch ( RepoPatch )+import Darcs.Ordered ( lengthRL, concatRL )+import qualified Data.ByteString.Char8 as BC  (unpack)+\end{code}++\begin{code}+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 "++darcsdir++" 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"+\end{code}+++\begin{code}+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)+\end{code}+++\begin{code}+-- 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+\end{code}+++\begin{code}+-- 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,90 @@+%  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.++\subsubsection{darcs 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 )+\end{code}++\options{show tags}++\haskell{show_tags_help}++Tab characters (ASCII character 9) in tag names are changed to spaces+for better interoperability with shell tools.  A warning is printed if+this happens.++\begin{code}+show_tags_description :: String+show_tags_description = "Show all tags in the repository."+\end{code}++\begin{code}+show_tags_help :: String+show_tags_help =+ "The tags command writes a list of all tags in the repository to standard\n"+++ "output."+\end{code}++\begin{code}+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,161 @@+%  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.++\subsection{darcs 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 )+\end{code}+\begin{code}+tag_description :: String+tag_description =+ "Tag the contents of the repository with a version name."+\end{code}++\options{tag}++\haskell{tag_help} Tag differs from record in that it doesn't record any+new changes, and it always depends on all patches residing in the+repository when it is tagged.  This means that one can later reproduce this+version of the repository by calling, for example:+\begin{verbatim}+% darcs get --tag "darcs 3.14" REPOLOCATION+\end{verbatim}++\begin{code}+tag_help :: String+tag_help =+ "Tag is used to name a version of this repository (i.e. the whole tree).\n"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+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++\end{code}+Each tagged version has a version name.+The version is also flagged with the person who tagged it (taken by default+from the `DARCS\_EMAIL' or `EMAIL' environment variable).  The date is also+included in the version information.++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.++\begin{options}+--checkpoint+\end{options}+The \verb!--checkpoint! option allows the tag be used later with the+\verb!--partial! flag to \verb!get! or \verb!check!.++A partial repository only contains patches from after the checkpoint.  A+partial repository works just like a normal repository, but any command that+needs to look at the contents of a missing patch will complain and abort.++\begin{options}+--pipe+\end{options}++If you run tag with the \verb!--pipe! option, you will be prompted for the+tag date and author.  This interface is intended for scripting darcs, in+particular for writing repository conversion scripts.  The prompts are+intended mostly as 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 looks like:++\begin{verbatim}+ What is the date? Mon Nov 15 13:38:01 EST 2004+ Who is the author? David Roundy+ What is the version name? 3.0+ Finished tagging patch 'TAG 3.0'+\end{verbatim}++Using \verb!tag! creates an entry in the repository history just like \verb!record!.+It will show up with \verb!darcs changes! appearing in the format:++\begin{verbatim}+ tagged My Tag Name+\end{verbatim}++To display all tags in the repository, use the ``\verb!darcs query tags!''+command.
+ src/Darcs/Commands/TrackDown.lhs view
@@ -0,0 +1,163 @@+%  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.++\subsection{darcs 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 )+\end{code}++\options{trackdown}++\begin{code}+trackdown_description :: String+trackdown_description = "Locate the most recent version lacking an error."+\end{code}++\haskell{trackdown_help}++\begin{code}+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"+\end{code}++\begin{code}+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]}+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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.++\subsection{darcs changes}+\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 Darcs.Progress ( setProgressMode )+import Darcs.Global ( darcsdir )++import qualified Data.ByteString as B (hPut, readFile, length, ByteString)+\end{code}++\options{transfer_mode}+\begin{code}+transfer_mode_description :: String+transfer_mode_description = "Allow access to files in repository."+\end{code}+\haskell{transfer_mode_help}+\begin{code}+transfer_mode_help :: String+transfer_mode_help =+ "Transfer-mode is used internally to grab file contents.\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]}+\end{code}+++\begin{code}+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,343 @@+%  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.++\subsection{darcs unrecord}+\label{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,+                      )+import Darcs.Match ( first_match, match_first_patchset, match_a_patchread )+import Darcs.Repository ( PatchSet, PatchInfoAnd, withGutsOf,+                          withRepoLock, ($-), slurp_recorded,+                    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 Darcs.Progress ( debugMessage )+import Darcs.Sealed ( Sealed(..), FlippedSeal(..), mapFlipped )+#include "gadts.h"+\end{code}+\begin{code}+unrecord_description :: String+unrecord_description =+ "Remove recorded patches without changing the working copy."+\end{code}++\options{unrecord}++\haskell{unrecord_help}++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"+\end{code}+\begin{code}+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]}+\end{code}+\begin{code}+unrecord_cmd :: [DarcsFlag] -> [String] -> IO ()+unrecord_cmd opts _ = withRepoLock opts $- \repository -> do+  let (logMessage,_,_) = loggers opts+  recorded <- slurp_recorded 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 "unrecord" opts recorded+      (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+       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+\end{code}++\begin{code}+unpull_description :: String+unpull_description =+ "Opposite of pull; unsafe if patch is not in remote repository."+\end{code}++\begin{code}+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"+\end{code}++\begin{code}+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}++++\subsection{darcs obliterate}++\begin{code}+obliterate_description :: String+obliterate_description =+ "Delete selected patches from the repository. (UNSAFE!)"+\end{code}++\begin{code}+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}++\options{obliterate}++\haskell{obliterate_help}++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]}+obliterate_cmd :: [DarcsFlag] -> [String] -> IO ()+obliterate_cmd = generic_obliterate_cmd "obliterate"+\end{code}++\begin{code}+generic_obliterate_cmd :: String -> [DarcsFlag] -> [String] -> IO ()+generic_obliterate_cmd cmdname opts _ = withRepoLock opts $- \repository -> do+  let (logMessage,_,_) = loggers opts+  recorded <- slurp_recorded repository+  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 recorded+      (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+        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,147 @@+%  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.++\subsection{darcs unrevert}\label{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_and_unrecorded,+                          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 Darcs.Progress ( debugMessage )+import Darcs.Sealed ( Sealed(Sealed) )+#include "impossible.h"+\end{code}+\begin{code}+unrevert_description :: String+unrevert_description =+ "Undo the last revert (may fail if changes after the revert)."+\end{code}++\options{unrevert}++\haskell{unrevert_help}+\begin{code}+unrevert_help :: String+unrevert_help =+ "Unrevert is used to undo the results of a revert command. It is only\n"+++ "guaranteed to work properly if you haven't made any changes since the\n"+++ "revert was performed.\n"+\end{code}+The command makes a best effort to merge the unreversion with any changes+you have since made.  In fact, unrevert should even work if you've recorded+changes since reverting.+\begin{code}+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]}+\end{code}+\begin{code}+unrevert_cmd :: [DarcsFlag] -> [String] -> IO ()+unrevert_cmd opts [] = withRepoLock opts $- \repository -> do+  us <- read_repo repository+  Sealed them <- unrevert_patch_bundle repository+  (rec, working) <- slurp_recorded_and_unrecorded 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 working [] 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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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,169 @@+%  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.++\subsection{darcs whatsnew}+\label{whatsnew}+\begin{code}+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Commands.WhatsNew ( whatsnew ) where+import System.Exit ( ExitCode(..), exitWith )+import System.Directory ( doesFileExist )+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,+                         areFileArgs, fixSubPaths,+                        list_registered_files,+                      )+import Darcs.Patch.FileName ( encode_white )+import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )++import Darcs.Repository ( Repository, withRepository, ($-), slurp_recorded,+                          get_unrecorded_no_look_for_adds,+                          get_unrecorded_in_files, amInRepository )+import Darcs.Repository.Internal ( slurp_recorded_and_unrecorded )+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.PrintPatch ( printPatch, contextualPrintPatch )+import Darcs.Ordered ( FL(..), mapFL_FL, reverseRL, reverseFL, (:>)(..), nullFL )++import Darcs.SlurpDirectory( Slurpy, slurp_has )++import Printer ( putDocLn, renderString, vcat, text )+#include "impossible.h"+\end{code}++\options{whatsnew}++\haskell{whatsnew_description}+\begin{code}+whatsnew_description :: String+whatsnew_description = "Display unrecorded changes in the working copy."+\end{code}+\haskell{whatsnew_help} \verb!darcs whatsnew! will return a non-zero value if+there are no changes, which can be useful if you just want to see in a+script if anything has been modified.  If you want to see some context+around your changes, you can use the \verb!-u! option, to get output+similar to the unidiff format.++\begin{code}+whatsnew_help :: String+whatsnew_help =+ "whatsnew gives you a view of what changes you've made in your working\n"+++ "copy that haven't yet been recorded.  The changes are displayed in\n"+++ "darcs patch format. Note that --look-for-adds implies --summary usage.\n"+\end{code}++\begin{code}+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],+                         command_basic_options = [summary, unified,+                                                 lookforadds,+                                                 working_repo_dir]}+\end{code}++\begin{code}+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+    when (areFileArgs files)+            (do slurps <- slurp_recorded_and_unrecorded repository+                warn_if_bogus slurps files+                putStrLn $ "What's new in "++unwords (map show files)++":\n")+    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+    when (areFileArgs files)+      (do slurps <- slurp_recorded_and_unrecorded repository+          warn_if_bogus slurps files+          putStrLn $ "What's new in "++unwords (map show files)++":\n")+    changes <- get_unrecorded_in_files repository (map sp2fn 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 = if Summary `elem` opts+                                 then putDocLn $ summarize ch+                                 else if Unified `elem` opts+                                      then do s <- slurp_recorded r+                                              contextualPrintPatch s ch+                                      else printPatch ch++warn_if_bogus :: (Slurpy,Slurpy) -> [SubPath] -> IO()+warn_if_bogus _ [] = return ()+warn_if_bogus (rec, pend) (f:fs) =+    do exist <- doesFileExist file+       if exist then when (not (slurp_has fp rec) || (slurp_has fp pend))$+                       putStrLn $ "WARNING: File '"+                         ++file++"' not in repository!"+                else putStrLn $ "WARNING: File '"++file++"' does not exist!"+       warn_if_bogus (rec, pend) fs+    where fp =  toFilePath f+          file = encode_white fp+\end{code}++If you give one or more file or directory names as an argument to+\verb!whatsnew!, darcs will output only changes to those files or to files in+those directories.
+ src/Darcs/CommandsAux.hs view
@@ -0,0 +1,104 @@+-- 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 "Malicious path"+           -- TODO: print patch(es) and path(s)+           -- 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 =+  let paths = list_touched_files patch in+    any 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,124 @@+{-# OPTIONS_GHC -cpp -fffi #-}+{-# 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+--   returns all changes to those files. It does *not* explore the given paths+--   recursively.+--+--   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,136 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+module Darcs.Email ( make_email, read_email ) where++import Data.Char ( digitToInt, isHexDigit )+import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)++import ByteStringUtils (dropSpace, linesPS, betweenLinesPS )+import qualified Data.ByteString          as B  (ByteString, length, null, tail, drop, head)+import qualified Data.ByteString.Char8    as BC (index, head, pack)+#if __GLASGOW_HASKELL__ > 606+import Data.ByteString.Internal as B (c2w, createAndTrim)+#else+import Data.ByteString.Base as B (c2w, createAndTrim)+#endif+import System.IO.Unsafe ( unsafePerformIO )+import Foreign.Ptr ( Ptr, plusPtr )+import Foreign.Storable ( poke )+import Data.Word ( Word8 )++line_max :: Int+line_max = 75++-- 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 line_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' line_max buf (bufi+1)+    | n == 0 && B.length ps > 1 ->+        do poke (buf `plusPtr` bufi) equals+           poke (buf `plusPtr` (bufi+1)) newline+           encode ps line_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' line_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,723 @@+{-# OPTIONS_GHC -cpp -fffi #-}+{-# 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,+  ) where++import Data.List ( intersperse )+import Control.Monad ( when, zipWithM_ )+import System.Exit ( ExitCode(..) )+import System.Environment ( getEnv )+import System.Cmd ( system )+import System.IO ( hPutStr, hPutStrLn, hGetContents, hClose,+                   openBinaryFile, IOMode( ReadMode ),+                   openBinaryTempFile,+                   hIsTerminalDevice, stdout, stderr, Handle )+import System.IO.Error ( isDoesNotExistError )+import System.IO.Unsafe ( unsafePerformIO )+import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )+import System.Directory ( createDirectory, getDirectoryContents,+                          doesFileExist, doesDirectoryExist,+                          renameFile, renameDirectory, copyFile )+import System.Process ( runProcess, runInteractiveProcess, waitForProcess )+import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )+import Control.Exception ( bracket, try, finally )+import Data.Char ( toUpper )+import Foreign.C ( CString, withCString )+import Foreign.Ptr ( nullPtr )+#ifdef HAVE_TERMINFO+import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )+#elif HAVE_CURSES+import Foreign.C ( CChar, CInt )+import Foreign.Ptr ( Ptr )+import Foreign.Marshal.Alloc (allocaBytes)+import Autoconf ( use_color )+#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 Darcs.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)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, canonFilename, writeDocBinFile,+                    removeFileMayNotExist, )+import CommandLine ( parseCmd, addUrlencoded )+import Autoconf ( have_libcurl, have_libwww, have_HTTP, have_sendmail, have_mapi, sendmail_path, darcs_version )+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 )+#include "impossible.h"++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++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+speculateRemote u v =+    do maybeget <- maybeURLCmd "GET" u+       case maybeget of+         Just _ -> return () -- can't pipeline these+         Nothing -> if have_libwww || have_libcurl || have_HTTP+                    then copyUrl u v Cachable+                    else return ()++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 = if have_libwww || have_libcurl || have_HTTP+                             then copyUrlFirst u v cache >> waitUrl u+                             else copyRemoteCmd u v++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 =+    if have_libwww || have_libcurl || have_HTTP+    then do mapM_ (\n -> copyUrl (u++"/"++n) (d++"/"++n) cache) ns+            doWithPatches (\n -> waitUrl (u++"/"++n)) ns+    else wgetRemotes u ns d++-- Argh, this means darcs get will fail if we don't have libcurl and don't+-- have wget.  :(+wgetRemotes :: String -> [String] -> FilePath -> IO ()+wgetRemotes u ns d = do wget_command <- getEnv "DARCS_WGET" `catch`+                                               \_ -> return "wget"+                        let (wget, wget_args) = breakCommand wget_command+                            input = unlines $ map (\n -> u++"/"++n) ns+                        withCurrentDirectory d $ withOpenTemp $ \(th,tn) ->+                            do hPutStr th input+                               hClose th+                               r <- exec wget (wget_args++["-i",tn])+                                         (Null,Null,AsIs)+                               when (r /= ExitSuccess) $+                                    fail $ unlines $+                                             ["(wget) failed to fetch files.",+                                              "source directory: " ++ d,+                                              "source files:"] ++ ns++copyRemoteCmd :: String -> FilePath -> IO ()+copyRemoteCmd s tmp = do+    let cmd = get_ext_cmd+    r <- stupidexec (cmd tmp s) (Null,Null,AsIs)+    when (r /= ExitSuccess) $+         fail $ "failed to fetch: " ++ s ++" " ++ show r+    where stupidexec [] = bug "stupidexec without a command"+          stupidexec xs = exec (head xs) (tail xs)++doWithPatches :: (String -> IO ()) -> [String] -> IO ()+doWithPatches f patches = mapM_ (\p -> seq p $ f p) $ progressList "Copying patch" patches++{-# NOINLINE get_ext_cmd #-}+get_ext_cmd :: String -> String -> [String]+-- Only need to find the command once..+get_ext_cmd = unsafePerformIO get_ext_cmd'++-- Would be better to read possible command lines from config-file..+get_ext_cmd' :: IO (String -> String -> [String])+get_ext_cmd' = try_cmd cmds+    where cmds = [("wget", (("--version",0),+                          -- use libcurl for proper cache control+                          \t s -> ["wget", "-q",+                                   "--header=Pragma: no-cache",+                                   "--header=Cache-Control: no-cache",+                                   "-O",t,s])),+                  ("curl", (("--version",2),+                            \t s -> ["curl", "-s", "-f", "-L",+                                     "-H", "Pragma: no-cache",+                                     "-H", "Cache-Control: no-cache",+                                     "-o",t,s]))]+          try_cmd [] = fail $ "I need one of: " ++ cs+              where cs = concat $ intersperse ", " (map fst cmds)+          try_cmd ((c,(ok_check,f)):cs) = do+            True <- can_execute ok_check c+            return f+           `catch` (\_ -> try_cmd cs)++-- | 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+     hPutDocLn h $+           text "To:"      <+> text t+        $$ text "From:"    <+> text f+        $$ text "Subject:" <+> text s+        $$ formated_cc+        $$ text "X-Mail-Originator: Darcs Version Control System"+        $$ text ("X-Darcs-Version: " ++ darcs_version)+        $$ body+  where formated_cc = if cc == ""+                      then empty+                      else text "Cc:" <+> text cc++-- | 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 =+  if have_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.")+  else if have_mapi then 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 fail $ "no mail facility (sendmail or mapi) located at configure time!"+  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 =+  case (have_sendmail || scmd /= "", have_mapi) of+   (True, _) -> 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)+   (_, True) -> fail "Don't know how to resend email with MAPI"+   _ -> fail $ "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"+  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+     exec sendmail_path ["-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+#else+c_send_email+#endif+             :: CString -> {- sender -}+                CString -> {- recipient -}+                CString -> {- cc -}+                CString -> {- subject -}+                CString -> {- body -}+                CString -> {- path -}+                IO Int+#ifndef HAVE_MAPI+c_send_email = impossible+#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"++can_execute :: (String,Int) -> String -> IO Bool+can_execute (arg,expected_return_value) exe = do+ withTemp $ \junk -> do+  ec <- system (unwords [exe,arg,">",junk])+  case ec of+    ExitSuccess | expected_return_value == 0 -> return True+    ExitFailure r | r == expected_return_value -> return True+    _ -> return False+++{-+  - 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++#elif HAVE_CURSES++foreign import ccall "tgetnum" c_tgetnum :: CString -> IO CInt+foreign import ccall "tgetent" c_tgetent :: Ptr CChar -> CString -> IO CInt++termioBufSize :: Int+termioBufSize = 4096++getTermNColors = if not use_color+                 then return (-1)+                 else do term <- getEnv "TERM"+                         allocaBytes termioBufSize (getTermNColorsImpl term)+                      `catch` \_ -> return (-1)++getTermNColorsImpl :: String -> Ptr CChar -> IO Int+getTermNColorsImpl term buf = do rc <- withCString term $+                                       \termp -> c_tgetent buf termp+                                 x <- if (rc /= 1) then return (-1)  else withCString "Co" $ \capap -> c_tgetnum capap+                                 return $ fromIntegral 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,108 @@+-- 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) 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+               | HelpOnMatch | 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 | 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+               | WorkDir String | RepoDir String | RemoteRepo 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+               | 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+
+ src/Darcs/Global.hs view
@@ -0,0 +1,134 @@+-- 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,+                      darcsdir+    ) where++import Control.Monad ( when )+import Control.Concurrent.MVar+import Control.Exception (bracket_, catch, block, unblock)+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )+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 []))++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++darcsdir :: String+darcsdir = "_darcs"
+ 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,313 @@+-- 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 -fffi #-}+{-# 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,+            ) 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+                                                         +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 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"++-- |'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 $+                               (sequence_ $ map 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 = do ok <- takeFile $ f++"-"++show n+                     if ok then return $ f++"-"++show n+                           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,579 @@+%  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+++-- | @first_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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+-- | @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)+\end{code}++\begin{code}+-- | @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)+\end{code}++\begin{code}+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++\end{code}++\begin{code}+-- | 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,150 @@+%  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/Commute.lhs}+\input{Darcs/Patch/Show.lhs}+
+ src/Darcs/Patch/Apply.lhs view
@@ -0,0 +1,530 @@+%  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,+                           -- to cut later:+                           applyBinary )+    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(..),+                          applyBinary, 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'+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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."+\end{code}++\begin{code}+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,212 @@+-- 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 )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.Depends ( is_tag )+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,280 @@+-- 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, Possibly(..)+                  ) where++import Text.Regex ( mkRegex, matchRegex )+import System.IO.Unsafe ( unsafePerformIO )+import qualified Data.ByteString as B (ByteString)+import Data.List (isPrefixOf)++newtype PatchCheck a = PC( KnownState -> (KnownState, a) )++data Possibly a = PJust a | PNothing | PSomething+                  deriving (Eq, Show)+data Prop = FileEx String | DirEx String | NotEx String+          | FileLines String [Possibly B.ByteString]+            deriving (Eq)+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 (take 10 l)++instance Monad PatchCheck where+    (PC p) >>= k  =  PC( \s0 -> let (s1, a) = p s0+                                    (PC q) = k a+                                in q s1 )+    return a = PC( \s -> (s, a) )++do_check :: PatchCheck a -> a+do_check (PC p) = snd $ p (P [] [])++do_verbose_check :: PatchCheck a -> a+do_verbose_check (PC p) =+    case p (P [] []) of+    (pc, b) -> unsafePerformIO $ do putStrLn $ show pc+                                    return b++is_valid :: PatchCheck Bool+is_valid = PC iv+    where iv Inconsistent = (Inconsistent, False)+          iv m = (m, True)++has :: Prop -> [Prop] -> Bool+has _ [] = False+has k (k':ks) = k == k' || has k ks++modify_file :: String+            -> ([Possibly B.ByteString]-> Maybe [Possibly B.ByteString])+            -> 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 il n c of+       [] -> assert_not $ FileEx f+       c' -> do+             set_contents f c'+             return True+  where il 1 mls = (PJust l:mls)+        il i (ml:mls) = ml : il (i-1) mls+        il _ [] = []++-- 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 dl [] n c of+        Nothing -> assert_not $ FileEx f+        Just c' -> do+            set_contents f c'+            is_valid+  where dl _ _ [] = Nothing+        dl o 1 (ml':ls) =+            case ml' of+            PSomething -> Just $ reverse o ++ ls+            PNothing -> Just $ reverse o ++ ls+            PJust l' -> if l' == l then Just $ reverse o ++ ls+                                   else Nothing+        dl o i (ml:mls) =+            case ml of+            PNothing -> dl (PSomething:o) (i-1) mls+            _ -> dl (ml:o) (i-1) mls++set_contents :: String -> [Possibly B.ByteString] -> PatchCheck ()+set_contents f mss = PC (sc f mss)+sc :: String -> [Possibly B.ByteString] -> KnownState -> (KnownState,())+sc f mss (P ks nots) = (P (scl [] f mss ks) nots, ())+sc _ _ Inconsistent = (Inconsistent, ())+scl :: [Prop] -> String -> [Possibly B.ByteString] -> [Prop] -> [Prop]+scl olds f mss [] = FileLines f mss : olds+scl olds f mss (FileLines f' mss':ks)+    | f == f' = FileLines f mss : (olds++ks)+    | f /= f' = scl (FileLines f' mss':olds) f mss ks+scl olds f mss (k:ks) = scl (k:olds) f mss ks++file_contents :: String -> PatchCheck [Possibly B.ByteString]+file_contents f = PC fc+    where fc Inconsistent = (Inconsistent, [])+          fc (P ks nots) = (P ks nots, fic ks)+          fic (FileLines f' mss:_) | f == f' = mss+          fic (_:ks) = fic ks+          fic [] = repeat PNothing++file_empty :: String -> PatchCheck Bool+file_empty f = do+  c <- file_contents f+  let empty = all (PNothing ==) $ take 101 c+  if empty+     then do set_contents f []+             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++do_swap :: String -> String -> PatchCheck Bool+do_swap f f' = PC swfn+  where swfn Inconsistent = (Inconsistent, False)+        swfn (P ks nots) = (P (map sw ks) (map sw nots), True)+        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 ls) | f  `is_soe` a = FileLines (movedirfilename f f' a) ls+                            | f' `is_soe` a = FileLines (movedirfilename f' f a) ls+        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 :: Prop -> PatchCheck Bool+assert p = PC assertfn+    where assertfn Inconsistent = (Inconsistent, False)+          assertfn (P ks nots) =+              if has p nots then (Inconsistent, False)+              else if has p ks then (P ks nots, True)+              else (P (p:ks) nots, True)++assert_not :: Prop -> PatchCheck Bool+assert_not p = PC assertnfn+    where assertnfn Inconsistent = (Inconsistent, False)+          assertnfn (P ks nots) =+              if has p ks then (Inconsistent, False)+              else if has p nots then (P ks nots, True)+              else (P ks (p:nots), True)++change_to_true :: Prop -> PatchCheck Bool+change_to_true p = PC chtfn+    where chtfn Inconsistent = (Inconsistent, False)+          chtfn (P ks nots) = (P (p:ks) (filter (p /=) nots), True)++change_to_false :: Prop -> PatchCheck Bool+change_to_false p = PC chffn+    where chffn Inconsistent = (Inconsistent, False)+          chffn (P ks nots) = (P (filter (p /=) ks) (p:nots), 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 = PC ssde+    where ssde Inconsistent = (Inconsistent, False)+          ssde (P ks nots) = if all noss ks+                             then (P ks nots, True)+                             else (Inconsistent, 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++superdirs_exist :: String -> PatchCheck Bool+superdirs_exist fn =+  case matchRegex (mkRegex "\\./(.+)/[^/]+") fn of+  Just ["."] -> return True+  Just [d] -> do+                a <- assert_dir_exists ("./"++d)+                b <- superdirs_exist ("./"++d)+                return $! a && b+  _ -> is_valid++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,890 @@+%  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+\end{code}++\begin{code}+#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+\end{code}++\begin{code}+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 ""+\end{code}++\begin{code}+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+\end{code}++\begin{code}+#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+\end{code}++\begin{code}++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,182 @@+%  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.FileName ( fn2fp, fp2fn, norm_path )+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) )+#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++\end{code}++\begin{code}+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}++\begin{code}+n_fn :: FilePath -> FilePath+n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f)+\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,494 @@+-- 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,+                 is_tag,+                 patchset_union, patchset_intersection,+                 commute_to_end,+               ) where+import Data.List ( delete, intersect )+import Control.Monad ( liftM2 )+import Control.Monad.Error (Error(..), MonadError(..))++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, just_name, human_friendly )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.Patchy ( sloppyIdentity )+import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia,+                         hopefully, conscientiously, hopefullyM )+import Darcs.Progress ( 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 -> throwError (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++is_tag :: PatchInfo -> Bool+is_tag pinfo = take 4 (just_name pinfo) == "TAG "++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 :: 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' $+      \common a b ->+        case gcau_simple a b of+        Left e -> missingPatchError e+        Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL)) -> +          case (merge_sets (a' :\/: b')) of+          Sealed a'b' -> seal $ (a'b' +<+ b) :<: common+        _ -> 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,146 @@+-- 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 :: 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 :: 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,327 @@+-- 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,+                        ) 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++-- | 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,310 @@+%  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}++Notes: 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++helpOnMatchers :: String+helpOnMatchers =+  let blurb :: (String, String, [String], String -> MatchFun Patch) -> String+      blurb (key, help, examples, _) =+        "'" ++ key ++ "' " ++ help +++        ", e.g.:\n" ++ (unlines $ map (mkExample key) examples)+      mkExample key x =+        "  darcs annotate --summary --match '" ++ key ++ " " ++ x ++ "'"+  in "Matching patches:\n"+     ++ (unlines $ map blurb primitiveMatchers) ++ "\n"+     ++ "You can also use logical operators 'and', '&&', 'or', '||', 'not', '!'"+     ++ " to combine match expressions, as well as parentheses for grouping. "+     ++ " For more details on matching, see the manual."++primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]+primitiveMatchers =+ [ ("exact", "checks a literal string against the patch name"+           , ["\"my most excellent patch\""]+           , exactmatch )+ , ("name", "checks a regular expression against the patch name"+          , ["[eE]xcellent"]+          , mymatch )+ , ("author", "checks a regular expression against the author name"+            , ["foo@bar"]+            , authormatch )+ , ("hash",  "matches the darcs hash for a patch"+          ,  ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"]+          ,  hashmatch )+ , ("date", "matches the patch date"+          , ["\"tea time yesterday\"", "\"2006-04-02 22:41\""]+          , datematch )+ , ("touch", "matches file paths for a patch"+          , ["\"foo|bar|splotz.*(c|h)\"", "\"some/thing/\""]+          , 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"+\end{code}++\begin{code}+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,183 @@+-- 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" patches.+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++data Non p C(x) where+    Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a)++type NonPatch C(x) = Non Prim C(x)++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,202 @@+-- 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 :: (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 :: (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 :: (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 :: (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++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 :: 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 :: 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,1273 @@+%  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.+++\section{Patch relationships}++\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,+         applyBinary, try_tok_internal,+         try_shrinking_inverse,+         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.SlurpDirectory ( FileContents )+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+\end{code}++%FIXME: The following code needs to be moved.  It is a function+%``is\_similar'' which tells you if two patches are in the same category+%human-wise.  Currently it just returns true if they are filepatches on the+%same file.++\begin{code}+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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+n_fn :: FilePath -> FilePath+n_fn f = "./"++(fn2fp $ norm_path $ fp2fn f)+\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}+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++\end{code}++\begin{code}+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 ")"+\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.+\begin{code}+commute_split :: CommuteFunction+commute_split (Split patches :< patch) =+    toPerhaps $ do (p1 :< ps) <- cs (patches :< patch)+                   case sort_coalesceFL ps of+                            p :>: NilFL -> return (p1 :< p)+                            ps' -> return (p1 :< Split ps')+    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')+commute_split _ = Unknown+\end{code}++\begin{code}+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)+\end{code}++\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}+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+\end{code}++\begin{code}+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+\end{code}++\begin{code}+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)+    ]+\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.++\begin{code}++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 (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile+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+\end{code}++\begin{code}+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+        +applyBinary :: B.ByteString -> B.ByteString+            -> FileContents -> Maybe FileContents+applyBinary o n c | c == o = Just n+applyBinary _ _ _ = Nothing+\end{code}++\begin{code}+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+\end{code}++\begin{code}+modernizePrim :: Prim C(x y) -> FL Prim C(x y)+modernizePrim (Split ps) = concatFL $ mapFL_FL modernizePrim ps+modernizePrim p = p :>: NilFL+\end{code}++\begin{code}+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+                                   +\end{code}++\begin{code}++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 _ = []+    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)++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,366 @@+%  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++\end{code}++\begin{code}+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_++\end{code}++\begin{code}+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+\end{code}+++\begin{code}+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/QuickCheck.hs view
@@ -0,0 +1,781 @@+{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts -fallow-undecidable-instances #-}+{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables #-}++#include "gadts.h"+module Darcs.Patch.QuickCheck ( WithStartState, RepoModel, Tree,+#ifndef GADT_WITNESSES+                                merge_examples, commute_examples, triple_examples,+#endif+                                prop_consistent_tree_flattenings, prop_fail,+                                prop_is_mergeable,+                                flattenOne, simpleCheck, simpleConditionalCheck, thoroughCheck,+                                commutePairFromTree, mergePairFromTree,+                                commuteTripleFromTree,+                                commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples,+                                patchFromTree,+                                quickCheck, real_patch_loop_examples, shrink+                              ) where++import Control.Arrow ( (***) )+import Control.Monad ( liftM, replicateM, mplus, mzero )+import qualified Data.ByteString.Char8 as BC (pack)+import qualified Data.ByteString       as B  (ByteString)+import Test.QuickCheck+import Test.QuickCheck.Test(isSuccess)+import Darcs.Sealed+import Darcs.Patch ( Patch )+import Darcs.Ordered+import Darcs.Patch.Patchy (--showPatch,+                           Invert(..), Commute(..))+import Darcs.Patch.Prim (Prim(..), Effect(..), FilePatchType(..), FromPrim(..), is_identity )+import Darcs.Patch.Real ( RealPatch, prim2real )+--import Darcs.ColorPrinter ( errorDoc )+--import Darcs.ColorPrinter ( traceDoc )+import Darcs.Show+--import Printer ( greenText, ($$) )+import Darcs.Patch.FileName ( FileName, fp2fn )++#include "impossible.h"+++#ifndef GADT_WITNESSES+instance Eq (a C(x y)) => Eq (Sealed2 a) where+    (Sealed2 x) == (Sealed2 y) = x == y+#endif++instance Show2 Patch where+    show2 = show++#ifndef GADT_WITNESSES+triple_examples :: (FromPrim p, Commute p, Invert p) => [p :> p :> p]+triple_examples = [commuteTripleFromTree id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "g"]))+                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"]))+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"])) NilTree)))+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "e"])) NilTree))+                  ,commuteTripleFromTree id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file",+                                               rmFileContents = [BC.pack "j"] })+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "s"]))+                     (ParTree+                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)+                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)))+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))+                  ]+++merge_examples :: (FromPrim p, Commute p, Invert p) => [p :\/: p]+merge_examples = map (mergePairFromCommutePair id) commute_examples++commute_examples :: (FromPrim p, Commute p) => [p :> p]+commute_examples = [+                   commutePairFromTWFP id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                   (TWFP 3+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree)+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "b"]))+                       (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"]))+                         (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"]))+                           (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)))))),+                   commutePairFromTWFP id $+                   WithStartState+                   (RepoModel { rmFileName = fp2fn "./file",+                                rmFileContents = [BC.pack "f",BC.pack "s",BC.pack "d"] })+                   (TWFP 3+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "d"] [])) NilTree)+                     (ParTree+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] [])) NilTree)+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] []))+                        (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "s",BC.pack "d"] []))+                          (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)))))),+{-                   commutePairFromTWFP id $+                   WithStartState+                   (RepoModel { rmFileName = fp2fn "./file",+                                rmFileContents = [BC.pack "f",BC.pack "u",+                                                  BC.pack "s",BC.pack "d"] })+                   (TWFP 5+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 4 [] [BC.pack "x"]))+                      (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree))+                     (ParTree+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "u"] [])) NilTree)+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f"] []))+                       (SeqTree (FP(fp2fn "./file") (Hunk 0 [BC.pack "u",BC.pack "s",BC.pack "d"] []))+                        (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "a"]))+                         (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "a"] [])) NilTree))))))),-}+                   commutePairFromTree id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file",+                                          rmFileContents = [BC.pack "n",BC.pack "t",BC.pack "h"] })+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n",BC.pack "t",BC.pack "h"] []))+                     NilTree)+                    (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] []))+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "n"] []))+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] [])) NilTree)))),+                  commutePairFromTree id $+                  WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                  (ParTree+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "n"])) NilTree)+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"]))+                                (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "i"])) NilTree))),+                  commutePairFromTree id $+                  WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                  (ParTree+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"]))+                     (ParTree+                       (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "c"] [BC.pack "r"])) NilTree)+                       (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"]))+                        (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree))))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)),+                  commutePairFromTWFP id $+                  WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                  (TWFP 1+                  (ParTree+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree)+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "t"])) NilTree))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree))),+                   commutePairFromTWFP id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file",+                                               rmFileContents = [BC.pack "f",BC.pack " r",+                                                                 BC.pack "c",BC.pack "v"] })+                   (TWFP 4+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c",BC.pack "v"] []))+                        (ParTree+                         (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "r"] []))+                          (SeqTree (FP (fp2fn "fi le") (Hunk 0 [BC.pack "f"] [])) NilTree))+                         (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "f",BC.pack "r"] []))+                          (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"])) NilTree))))+                     (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "v"] [])) NilTree))),+                   commutePairFromTree id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree)+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "f"])) NilTree)+                     (ParTree+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "r"])) NilTree)+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "d"])) NilTree))))+                 , commutePairFromTree id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file",+                                               rmFileContents = [BC.pack "t",BC.pack "r",+                                                                 BC.pack "h"] })+                   (ParTree+                    (ParTree+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t",BC.pack "r",BC.pack "h"] []))+                              NilTree)+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "o"])) NilTree))+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "t"] []))+                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "h"] [])) NilTree)))+                 , commutePairFromTWFP id $+                   WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }) $+                   TWFP 2+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"])) NilTree)+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "y"]))+                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "m"]))+                      (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree))))+                 , commutePairFromTree id $+                 WithStartState (RepoModel {rmFileName = fp2fn "./file",rmFileContents = [] })+                 (ParTree+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "p"]))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "p"] []))+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "c"])) NilTree)))+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "z"])) NilTree))+                 , commutePairFromTree id $+                 WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                 (ParTree+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ]))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree))+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree))+                 , commutePairFromTree id $+                 WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                 (ParTree+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "v"])) NilTree)+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j" ]))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 [BC.pack "j"] [])) NilTree)))+                 , commutePairFromTree id $+                 WithStartState (RepoModel { rmFileName = fp2fn "./file",+                                             rmFileContents = [BC.pack "x",BC.pack "c"] })+                 (ParTree+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "h"]))+                   (ParTree+                    (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "c"] [])) NilTree)+                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "x"] []))+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "j"])) NilTree))))+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] [BC.pack "l"])) NilTree))+                 , commutePairFromTree id $+                 WithStartState (RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] })+                 (ParTree+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "s"))) NilTree)+                  (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "k")))+                   (SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "k") []))+                    (SeqTree (FP (fp2fn "./file") (Hunk 0 [] (packStringLetters "m")))+                     (SeqTree (FP (fp2fn "./file") (Hunk 0 (packStringLetters "m") [])) NilTree)))))+                 ]+#endif++simpleConditionalCheck :: (Arbitrary p, Show p, Show q) => (p -> Bool) -> (p -> Maybe q) -> IO Int+simpleConditionalCheck nottrivial t = do +  okay <- quickCheckWithResult args t'+  return $ if isSuccess okay then 0 else 1+    where t' p = nottrivial p ==> case t p of+                                  Nothing -> True+                                  Just q -> error $ show q+          args = Args {replay = Nothing,+                       maxSuccess = 100,+                       maxDiscard = 5000,+                       maxSize = 100+                      }++simpleCheck :: (Arbitrary p, Show p, Show q) => (p -> Maybe q) -> IO Int+simpleCheck t = do okay <- quickCheckResult t'+                   return $ if isSuccess okay then 0 else 1+    where t' p = case t p of+                 Nothing -> True+                 Just q -> error $ show q++thoroughCheck :: (Arbitrary p, Show p, Show q) => Int -> (p -> Maybe q) -> IO Int+thoroughCheck num t = do let args = Args {replay = Nothing,+                                          maxSuccess = num,+                                          maxDiscard = 20*num,+                                          maxSize = max 100 (num `div` 10)+                                         }+                         okay <- quickCheckWithResult args t'+                         return $ if isSuccess okay then 0 else 1+    where t' p = case t p of+                 Nothing -> True+                 Just q -> error $ show q++data RepoModel C(x)+ = RepoModel {+     rmFileName :: !FileName,+     rmFileContents :: [B.ByteString]+   } deriving (Eq)++instance Show (RepoModel C(x)) where+  showsPrec d rm = showParen (d > app_prec) $+                   showString "RepoModel { rmFileName = " . showsPrec 0 (rmFileName rm) .+                   showString ", rmFileContents = " . showsPrec 0 (rmFileContents rm) .+                   showString " }"++instance Show1 RepoModel where+    showsPrec1 = showsPrec++#ifdef GADT_WITNESSES+data InitRepoModel -- this ought to be defined somewhere central as the unique starting state+#endif++initRepoModel :: RepoModel C(InitRepoModel)+initRepoModel = RepoModel { rmFileName = fp2fn "./file", rmFileContents = [] }+rebuildRepoModel :: RepoModel C(x) -> RepoModel C(y)+rebuildRepoModel rm = RepoModel { rmFileName = rmFileName rm, rmFileContents = rmFileContents rm }++data WithEndState px s C(y) = WithEndState { wesPatch :: px C(y), _wesState :: s C(y) }++class ArbitraryState s p where+  arbitraryState :: s C(x) -> Gen (Sealed (WithEndState (p C(x)) s))+  -- does a coarbitrary make sense?++class ArbitraryStateIn s p where+  arbitraryStateIn :: s C(x) -> Gen (p C(x))++instance ArbitraryState RepoModel Prim where+  arbitraryState rm = oneof [arbitraryFP rm]++instance Arbitrary (Sealed2 (FL Prim)) where+  arbitrary = do Sealed2 ps1 <- liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel+                 return $ Sealed2 $ mapFL_FL make_identity_identity ps1+                     where make_identity_identity :: Prim C(x y) -> Prim C(x y)+                           make_identity_identity p | IsEq <- is_identity p = identity+                                                    | otherwise = p++instance Arbitrary (Sealed2 (FL (WithState RepoModel Prim))) where+  arbitrary = liftM (unseal (seal2 . wesPatch)) $ arbitraryState initRepoModel++prop_consistent_tree_flattenings :: Sealed (WithStartState RepoModel (Tree Prim)) -> Bool+prop_consistent_tree_flattenings (Sealed (WithStartState start t))+  = fromJust $+    do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t+       rms <- return $ map (applyPatch start) flat+       return $ and $ zipWith assert_equal_fst (zip rms flat) (tail $ zip rms flat)++assert_equal_fst :: (Eq a, Show a, Show b, Show c) => (a, b) -> (a, c) -> Bool+assert_equal_fst (x,bx) (y,by)+    | x == y = True+    | otherwise = error ("Not really equal:\n" ++ show x ++ "\nand\n" ++ show y+                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)++-- WithState and prop_fail are handy for debugging arbitrary code+data WithState s p C(x y) = WithState (s C(x)) (p C(x y)) (s C(y))+  deriving Show++data WithStartState s p C(x) = WithStartState (s C(x)) (p C(x))++instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where+   showsPrec d (WithStartState s p) = showParen (d > app_prec) $ showString "WithStartState " .+                                      showsPrec1 (app_prec + 1) s . showString " " .+                                      showsPrec1 (app_prec + 1) p++instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where+   showsPrec1 = showsPrec++prop_fail :: Int -> Tree Prim C(x) -> Bool+prop_fail n xs = sizeTree xs < n++instance ArbitraryState s p => ArbitraryState s (WithState s p) where+  arbitraryState rm = do xandrm' <- arbitraryState rm+                         flip unseal xandrm' $ \(WithEndState x rm') ->+                           return $ seal $ WithEndState (WithState rm x rm') rm'++instance ArbitraryState s p => ArbitraryState s (FL p) where+  arbitraryState rm1 = sized $ \n -> do k <- choose (0, n)+                                        arbitraryList k rm1+      where arbitraryList :: FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState (FL p C(x)) s))+            arbitraryList 0 rm = return $ seal $ WithEndState NilFL rm+            arbitraryList (n+1) rm = do Sealed (WithEndState x rm') <- arbitraryState rm+                                        Sealed (WithEndState xs rm'') <- arbitraryList n rm'+                                        return $ seal $ WithEndState (x :>: xs) rm''+            arbitraryList _ _ = impossible++data Tree p C(x) where+   NilTree :: Tree p C(x)+   SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x)+   ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x)++mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x)+mapTree _ NilTree = NilTree+mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)+mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)++instance Show2 p => Show (Tree p C(x)) where+   showsPrec _ NilTree = showString "NilTree"+   showsPrec d (SeqTree a t) = showParen (d > app_prec) $ showString "SeqTree " .+                               showsPrec2 (app_prec + 1) a . showString " " .+                               showsPrec (app_prec + 1) t+   showsPrec d (ParTree t1 t2) = showParen (d > app_prec) $ showString "ParTree " .+                                 showsPrec (app_prec + 1) t1 . showString " " .+                                 showsPrec (app_prec + 1) t2++instance Show2 p => Show1 (Tree p) where+    showsPrec1 = showsPrec++sizeTree :: Tree p C(x) -> Int+sizeTree NilTree = 0+sizeTree (SeqTree _ t) = 1 + sizeTree t+sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2++-- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) }+newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) }++flattenTree :: (Commute p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z))+flattenTree NilTree = seal $ G2 $ return NilFL+flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t+flattenTree (ParTree t1 t2) = flip unseal (flattenTree t1) $ \gpss1 ->+                              flip unseal (flattenTree t2) $ \gpss2 ->+                              seal $ G2 $+                              do ps1 <- unG2 gpss1+                                 ps2 <- unG2 gpss2+                                 ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)+                                 -- We can't prove that the existential type in the result+                                 -- of merge will be the same for each pair of+                                 -- ps1 and ps2.+                                 map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']++instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where+  arbitraryStateIn rm = frequency [(2, return NilTree)+                                  ,(2, do Sealed (WithEndState p rm') <- arbitraryState rm+                                          t <- arbitraryStateIn rm'+                                          return (SeqTree p t))+                                  ,(1, do t1 <- arbitraryStateIn rm+                                          t2 <- arbitraryStateIn rm+                                          return (ParTree t1 t2))]+++shrinkWSSTree :: Sealed (WithStartState RepoModel (Tree Prim))+              -> [Sealed (WithStartState RepoModel (Tree Prim))]+shrinkWSSTree = unseal doShrinkWSSTree+ where+ doShrinkWSSTree wss@(WithStartState rm t)+  = shrinkWSSTree' wss -- shrink the tree+     `mplus`+    do -- shrink the starting context+      pos <- [0 .. length (rmFileContents rm) - 1]+      let rmFileContents' = take pos (rmFileContents rm) ++ drop (pos+1) (rmFileContents rm)+          t' = shrinkPosStart pos (canonizeTree t)+      return $ seal $ WithStartState (rm { rmFileContents = rmFileContents' }) (canonizeTree t')+++-- If we had a more general repo model, then Int would need to be more general too++class ShrinkablePos p where+  shrinkPos :: Int -> p C(x y) -> (p C(x y), Maybe Int)+  shrinkPatch :: p C(x y) -> [(p C(x y), Maybe Int)]+  nullPatch :: p C(x y) -> EqCheck C(x y)++class ShrinkablePosStart p where+  shrinkPosStart :: Int -> p C(x) -> p C(x)++instance ShrinkablePos p => ShrinkablePosStart (Tree p) where+  shrinkPosStart _ NilTree = NilTree+  shrinkPosStart pos (SeqTree p t)+    = let (p', mpos') = shrinkPos pos p+      in case mpos' of+           Nothing -> SeqTree p' t+           Just pos' -> SeqTree p' (shrinkPosStart pos' t)+  shrinkPosStart pos (ParTree t1 t2) = ParTree (shrinkPosStart pos t1) (shrinkPosStart pos t2)++smartFP :: FileName -> FilePatchType C(x y) -> Prim C(x y)+smartFP _ (Hunk _ [] []) | avoidEmptyHunks = unsafeCoerceP Identity+smartFP fn filepatch = FP fn filepatch++instance ShrinkablePos Prim where+  shrinkPos pos (FP fn fp) = (smartFP fn *** id) (shrinkPos pos fp)+  shrinkPos pos Identity = (Identity, Just pos)+  shrinkPos _ _ = impossible+  shrinkPatch (FP fn fp) = map (smartFP fn *** id) (shrinkPatch fp)+  shrinkPatch Identity = []+  shrinkPatch _ = impossible+  nullPatch (FP _ fp) = nullPatch fp+  nullPatch Identity = IsEq+  nullPatch _ = impossible++avoidEmptyHunks :: Bool+avoidEmptyHunks = True++instance ShrinkablePos FilePatchType where+  shrinkPos pos (Hunk n old new)+    | pos < n = (Hunk (n-1) old new, Just pos)+    | pos >= n + length old = (Hunk n old new, Just (pos + length new - length old))+    | otherwise = (Hunk n (take pos' old ++ drop (pos'+1) old) new, Nothing)+        where pos' = pos - n+  shrinkPos _ _ = bug "foo1 in ShrinkablePos"+  shrinkPatch (Hunk (n+1) [] []) = [(Hunk n [] [], Nothing)]+  shrinkPatch (Hunk n old new)+   = do i <- [0 .. length new - 1]+        return (Hunk n old (take i new ++ drop (i+1) new), Just (n + i))+  shrinkPatch _ = bug "foo in ShrinkablePos"+  nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?+  nullPatch _ = NotEq++shrinkWSSTree'+ -- start a new line here because apparently ' confuses CPP..+   :: WithStartState RepoModel (Tree Prim) C(x)+   -> [Sealed (WithStartState RepoModel (Tree Prim))]+shrinkWSSTree' (WithStartState _ NilTree) = []+shrinkWSSTree' (WithStartState rm t@(SeqTree p t'))+  = return (seal (WithStartState (applyPatch rm p) (canonizeTree t')))+     `mplus`+    liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t)+shrinkWSSTree' (WithStartState rm t@(ParTree _ _))+  = liftM (seal . WithStartState rm) (map canonizeTree $ shrinkTree t)++-- canonize a tree, removing any dead branches+canonizeTree :: ShrinkablePos p => Tree p C(x) -> Tree p C(x)+canonizeTree NilTree = NilTree+canonizeTree (ParTree t1 t2)+    | NilTree <- canonizeTree t1 = canonizeTree t2+    | NilTree <- canonizeTree t2 = canonizeTree t1+    | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)+canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t+                           | otherwise = SeqTree p (canonizeTree t)++-- shrink the tree without changing the starting context+shrinkTree :: ShrinkablePos p => Tree p C(x) -> [Tree p C(x)]+shrinkTree NilTree = []+shrinkTree (SeqTree p t) = do case nullPatch p of+                                 IsEq -> return t+                                 NotEq -> mzero+                             `mplus`+                           do (p', pos) <- shrinkPatch p+                              return (SeqTree p' (maybe id shrinkPosStart pos t))+                             `mplus`+                           do t' <- shrinkTree t+                              return (SeqTree p t')+shrinkTree (ParTree t1 t2) = [t1, t2]+                              `mplus`+                             do t1' <- shrinkTree t1+                                return (ParTree t1' t2)+                              `mplus`+                             do t2' <- shrinkTree t2+                                return (ParTree t1 t2')++instance Arbitrary (Sealed (WithStartState RepoModel (Tree Prim))) where+  arbitrary = do Sealed (WithStartState rm tree) <-+                     liftM (seal . WithStartState initRepoModel) (arbitraryStateIn initRepoModel)+                 return $ Sealed $ WithStartState rm (canonizeTree tree)+  shrink = shrinkWSSTree++prop_is_mergeable :: forall p C(x) . (FromPrim p, Commute p)+                  => Sealed (WithStartState RepoModel (Tree Prim))+                  -> Maybe (Tree p C(x))+prop_is_mergeable (Sealed (WithStartState _ t))+   = case flattenOne t of+        Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)+                     in case lengthFL ps of+                       _ -> Nothing++flattenOne :: (FromPrim p, Commute p) => Tree Prim C(x) -> Sealed (FL p C(x))+flattenOne NilTree = seal NilFL+flattenOne (SeqTree p t) = flip unseal (flattenOne t) $ \ps -> seal (fromPrim p :>: ps)+flattenOne (ParTree t1 t2) =+    flip unseal (flattenOne t1) $ \ps1 ->+    flip unseal (flattenOne t2) $ \ps2 ->+    --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$+    --          greenText "ps2" $$ showPatch ps2) $+    case merge (ps1 :\/: ps2) of+      ps2' :/\: _ -> seal (ps1 +>+ ps2')++instance Arbitrary (Sealed2 (FL RealPatch)) where+    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim)))+                   return $ unseal seal2 (flattenOne tree)++instance Arbitrary (Sealed2 RealPatch) where+    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState RepoModel (Tree Prim)))+                   case mapFL seal2 `unseal` flattenOne tree of+                     [] -> return $ seal2 $ fromPrim Identity+                     ps -> elements ps++instance (Arbitrary (Sealed2 (FL p)), Commute p) => Arbitrary (Sealed2 (p :\/: p)) where+    arbitrary = do Sealed2 (a :> b) <- arbitrary+                   case commute (a :> b) of+                     Just (b' :> _) -> return (seal2 (a :\/: b'))+                     Nothing -> arbitrary++instance Arbitrary (Sealed2 (FL p)) => Arbitrary (Sealed2 (p :> p)) where+    arbitrary = do Sealed2 ps <- arbitrary+                   let pairs = getPairs ps+                   case pairs of+                      [] -> arbitrary+                      _ -> elements pairs++instance (Invert p, Arbitrary (Sealed2 (FL p))) => Arbitrary (Sealed2 (p :> p :> p)) where+    arbitrary = do Sealed2 ps <- arbitrary+                   return $ last_triple ps+        where last_triple :: FL p C(x y) -> Sealed2 (p :> p :> p)+              last_triple NilFL = seal2 $ identity :> identity :> identity+              last_triple (a :>: NilFL) = seal2 $ a :> invert a :> identity+              last_triple (a :>: b :>: NilFL) = seal2 $ invert a :> a :> b+              last_triple (a :>: b :>: c :>: NilFL) = seal2 $ a :> b :> c+              last_triple (_ :>: xs) = last_triple xs++data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x))++commutePairFromTWFP :: (FromPrim p, Commute p)+                    => (FORALL (y z) (p :> p) C(y z) -> t)+                    -> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t)+commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))+    = unseal2 handlePair $+      let xs = unseal getPairs (flattenOne t)+      in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim Identity :> fromPrim Identity)++commutePairFromTree :: (FromPrim p, Commute p)+                    => (FORALL (y z) (p :> p) C(y z) -> t)+                    -> (WithStartState RepoModel (Tree Prim) C(x) -> t)+commutePairFromTree handlePair (WithStartState _ t)+   = unseal2 handlePair $+     let Sealed ps = flattenOne t+         xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $+              getPairs ps+     in if null xs then seal2 (fromPrim Identity :> fromPrim Identity) else last xs++commuteTripleFromTree :: (FromPrim p, Commute p)+                      => (FORALL (y z) (p :> p :> p) C(y z) -> t)+                      -> (WithStartState RepoModel (Tree Prim) C(x) -> t)+commuteTripleFromTree handle (WithStartState _ t)+   = unseal2 handle $+     let Sealed ps = flattenOne t+         xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $+              getTriples ps+     in if null xs+        then seal2 (fromPrim Identity :> fromPrim Identity :> fromPrim Identity)+        else last xs++mergePairFromCommutePair :: (Commute p, Invert p)+                         => (FORALL (y z) (p :\/: p) C(y z) -> t)+                         -> (FORALL (y z) (p :>   p) C(y z) -> t)+mergePairFromCommutePair handlePair (a :> b)+ = case commute (a :> b) of+     Just (b' :> _) -> handlePair (a :\/: b')+     Nothing -> handlePair (b :\/: b)++-- impredicativity problems mean we can't use (.) in the definitions below++mergePairFromTWFP :: (FromPrim p, Commute p, Invert p)+                  => (FORALL (y z) (p :\/: p) C(y z) -> t)+                  -> (WithStartState RepoModel (TreeWithFlattenPos Prim) C(x) -> t)+mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)++mergePairFromTree :: (FromPrim p, Commute p, Invert p)+                  => (FORALL (y z) (p :\/: p) C(y z) -> t)+                  -> (WithStartState RepoModel (Tree Prim) C(x) -> t)+mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)++patchFromCommutePair :: (Commute p, Invert p)+                     => (FORALL (y z) p C(y z) -> t)+                     -> (FORALL (y z) (p :> p) C(y z) -> t)+patchFromCommutePair handle (_ :> b) = handle b++patchFromTree :: (FromPrim p, Commute p, Invert p)+              => (FORALL (y z) p C(y z) -> t)+              -> (WithStartState RepoModel (Tree Prim) C(x) -> t)+patchFromTree x = commutePairFromTree (patchFromCommutePair x)+++instance Show2 p => Show (TreeWithFlattenPos p C(x)) where+   showsPrec d (TWFP n t) = showParen (d > app_prec) $ showString "TWFP " .+                            showsPrec (app_prec + 1) n . showString " " .+                            showsPrec1 (app_prec + 1) t++instance Show1 (TreeWithFlattenPos Prim) where+   show1 = show++instance Arbitrary (Sealed (WithStartState RepoModel (TreeWithFlattenPos Prim))) where+   arbitrary = do Sealed (WithStartState rm t) <- arbitrary+                  let num = unseal (length . getPairs) (flattenOneRP t)+                  if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree+                    else do n <- choose (0, num - 1)+                            return $ Sealed $ WithStartState rm $ TWFP n t+                    where -- just used to get the length. In principle this should be independent of the patch type.+                          flattenOneRP :: Tree Prim C(x) -> Sealed (FL RealPatch C(x))+                          flattenOneRP = flattenOne+   shrink (Sealed (WithStartState rm (TWFP n t))) =+      [Sealed (WithStartState rm' (TWFP n' t')) | Sealed (WithStartState rm' t') <- shrink (Sealed (WithStartState rm t)),+                                                  n' <- [0..n]]+++getPairs :: FL p C(x y) -> [Sealed2 (p :> p)]+getPairs NilFL = []+getPairs (_:>:NilFL) = []+getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)++getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)]+getTriples NilFL = []+getTriples (_:>:NilFL) = []+getTriples (_:>:_:>:NilFL) = []+getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)++arbitraryFP :: RepoModel C(x) -> Gen (Sealed (WithEndState (Prim C(x)) RepoModel))+arbitraryFP rm+ = do (fp, newcontents) <- arbitraryFilePatchType (rmFileContents rm)+      return $ seal $ WithEndState (FP (rmFileName rm) fp) (rebuildRepoModel (rm { rmFileContents = newcontents }))++-- Really [B.ByteString] should be parametrised by x y, and the result tuple sealed on y+arbitraryFilePatchType :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString])+arbitraryFilePatchType contents = oneof [arbitraryHunk contents]++arbitraryHunk :: [B.ByteString] -> Gen (FilePatchType C(x y), [B.ByteString])+arbitraryHunk contents+ = sized $ \n ->+   do start <- choose (0, min n (length contents))+      (removelen, _)+        <- frequency $ zip (if start == length contents then [1, 13, 0, 0] else [1, 3, 5, 3])+                [return (0, 0)+                ,do xa <- choose (0, n)+                    return (0, xa)+                ,do xr <- choose (1, min n (length contents - start))+                    return (xr, 0)+                ,do xr <- choose (1, min n (length contents - start))+                    xa <- choose (0, n)+                    return (xr, xa)+                ]+      addlen <- choose (0, n)+      additems <- replicateM addlen (do c <- choose ('a', 'z')+                                        return $ BC.pack [c])+      let newcontents = take start contents ++ additems ++ drop (start + removelen) contents+      return (Hunk start (take removelen $ drop start $ contents) additems, newcontents)++class Applyable p where+  applyPatch :: RepoModel C(x) -> p C(x y) -> RepoModel C(y)++instance Applyable p => Applyable (FL p) where+  applyPatch rm NilFL = rm+  applyPatch rm (p :>: ps) = applyPatch (applyPatch rm p) ps++instance Applyable RealPatch where+  applyPatch rm p = applyPatch rm (effect p)++instance Applyable Prim where+  applyPatch (rm@RepoModel { rmFileName = filename, rmFileContents = oldcontents }) (FP filename' fp)+     | filename == filename' = rebuildRepoModel (rm { rmFileContents = applyFilePatchType oldcontents fp })+  applyPatch rm Identity = rm+  applyPatch _ _ = bug "We haven't defined applyPatch on Prim for all patch types."++applyFilePatchType :: [B.ByteString] -> FilePatchType C(x y) -> [B.ByteString]+applyFilePatchType oldcontents (Hunk n old new)+ = if take (length old) (drop n oldcontents) == old+   then take n oldcontents ++ new ++ drop (n + length old) oldcontents+   else error "Bad patch context"+applyFilePatchType _ _ = bug "We haven't defined applyFilePatchType for all patch types."++packStringLetters :: String -> [B.ByteString]+packStringLetters = map (BC.pack . (:[]))++real_patch_loop_examples :: [Sealed (WithStartState RepoModel (Tree Prim))]+real_patch_loop_examples =+    [Sealed (WithStartState (RepoModel { rmFileName = fx, rmFileContents = [] })+     $ canonizeTree+     (ParTree+      (SeqTree (FP fx (Hunk 0 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))+       (ParTree+        (SeqTree (FP fx (Hunk 46 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))+         (ParTree+          (ParTree+           NilTree+           (ParTree+            (ParTree+             (ParTree+              (SeqTree (FP fx (Hunk 14 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))+               (ParTree+                NilTree+                (ParTree+                 (SeqTree (FP fx (Hunk 39 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))+                  (ParTree+                   (ParTree+                    (SeqTree (FP fx (Hunk 11 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)+                    NilTree)+                   NilTree))+                 (SeqTree (FP fx (Hunk 24 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree))))+              (SeqTree (FP fx (Hunk 55 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree))+             (SeqTree (FP fx (Hunk 19 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")))+              (SeqTree (FP fx (Hunk 25 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")))+               (SeqTree (FP fx (Hunk 38 [] (packStringLetters "ji")))+                (ParTree+                 NilTree+                 (ParTree+                  NilTree+                  (ParTree+                   (ParTree+                    NilTree+                    (SeqTree (FP fx (Hunk 25 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))+                     (SeqTree (FP fx (Hunk 38 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))+                   (ParTree+                    NilTree+                    (SeqTree (FP fx (Hunk 43 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))+                     (ParTree+                      NilTree+                      (SeqTree (FP fx (Hunk 63 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))+            (ParTree+             NilTree+             NilTree)))+          NilTree))+        NilTree))+      (ParTree+       NilTree+       (SeqTree (FP fx (Hunk 0 [] (packStringLetters "ti")))+        (SeqTree (FP fx (Hunk 0 (packStringLetters "t") (packStringLetters "ybcop")))+         (SeqTree (FP fx (Hunk 1 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")))+          (SeqTree (FP fx (Hunk 14 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")))+           (SeqTree (FP fx (Hunk 50 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")))+            (ParTree+             NilTree+             NilTree)))))))))]++fx :: FileName+fx = fp2fn "./F"
+ 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,752 @@+-- 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 :: RealPatch C(s y) -> Bool+is_duplicate (Duplicate _) = True+is_duplicate (Etacilpud _) = True+is_duplicate _ = False++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 ((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+                                                     --traceDoc (greenText "foo1" $$+                                                     --          showPatch (join_effects $ p':<:a)) $ Just ()+                                                     NilFL <- return $ join_effects $ p':<:a+                                                     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+                                                     --traceDoc (greenText "foo2" $$+                                                     --          showPatch (join_effects $ p':<:a)) $ Just ()+                                                     NilFL <- return $ join_effects $ p':<:a+                                                     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++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++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 = case nonxx_aux ix xx of+                          NilRL -> []+                          Normal q:<:qs -> [Non (reverseRL qs) q]+                          _ -> []+                  nonxx_aux :: [Non RealPatch C(x)] -> FL Prim C(x y) -> RL RealPatch C(x y)+                  nonxx_aux a b = reverseFL $ xx2patches a b+                  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 :: 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'++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 :: 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++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 #-}+{-# 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/Test.hs view
@@ -0,0 +1,681 @@+-- 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.++{-# OPTIONS_GHC -cpp -fno-warn-deprecations -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Test+             ( prop_read_show,+               prop_inverse_composition, prop_commute_twice,+               prop_inverse_valid, prop_other_inverse_valid,+               prop_commute_equivalency, prop_commute_either_order,+               prop_commute_either_way, prop_merge_is_commutable_and_correct,+               prop_merge_is_swapable, prop_merge_valid,+               prop_unravel_three_merge, prop_unravel_seq_merge,+               prop_unravel_order_independent,+               prop_simple_smart_merge_good_enough,+               prop_elegant_merge_good_enough,+               prop_patch_and_inverse_is_identity,+               quickmerge, check_patch, check_a_patch, verbose_check_a_patch,+               prop_resolve_conflicts_valid,+               test_patch, prop_commute_inverse,+               subcommutes_inverse, subcommutes_nontrivial_inverse,+               subcommutes_failure,+               join_patches+             ) where++import Prelude hiding ( pi )+import System.IO.Unsafe ( unsafePerformIO )+import Test.QuickCheck+import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )++import Darcs.Patch.Info ( PatchInfo, patchinfo )+import Darcs.Patch.Check ( PatchCheck, Possibly(..),+                    check_move, remove_dir, create_dir,+                    is_valid, insert_line, file_empty, file_exists,+                    delete_line, modify_file, create_file, remove_file,+                    do_check, do_verbose_check,+                  )+import RegChars ( regChars )+import ByteStringUtils ( linesPS )+import qualified Data.ByteString as B ( ByteString, null, concat )+import qualified Data.ByteString.Char8 as BC ( break, pack )+import Darcs.Patch.FileName ( fn2fp )++import Darcs.Patch.Patchy ( Commute )+import Darcs.Patch ( addfile, adddir, move, showPatch,+                     hunk, tokreplace, joinPatches, binary,+                     changepref, is_merger, invert, commute, commutex, merge,+                     readPatch, resolve_conflicts,+                     effect, fromPrims,+                     unravel, merger, elegant_merge )+import Darcs.Patch.Core ( Patch(..) )+import Darcs.Patch.Prim ( Prim(..), DirPatchType(..), FilePatchType(..),+                          CommuteFunction, Perhaps(..),+                          subcommutes )+import Printer ( renderPS )+import Darcs.Ordered+import Darcs.Sealed ( Sealed(Sealed), unsafeUnseal, unseal )++#include "impossible.h"++instance Eq Patch where+   x == y = IsEq == (x =\/= y)++instance Eq Prim where+   x == y = IsEq == (x =\/= y)++instance (Commute a, MyEq a) => Eq (FL a) where+   x == y = IsEq == (x =\/= y)++instance Arbitrary Patch where+    arbitrary = sized arbpatch+--    coarbitrary p = coarbitrary (show p)++instance Arbitrary Prim where+    arbitrary = onepatchgen+--    coarbitrary = impossible++hunkgen :: Gen Prim+hunkgen = do+  i <- frequency [(1,choose (0,5)),(1,choose (0,35)),+                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]+  j <- frequency [(1,choose (0,5)),(1,choose (0,35)),+                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]+  if i == 0 && j == 0 then hunkgen+    else liftM4 hunk filepathgen linenumgen+                (replicateM i filelinegen)+                (replicateM j filelinegen)++tokreplacegen :: Gen Prim+tokreplacegen = do+  f <- filepathgen+  o <- tokengen+  n <- tokengen+  if o == n+     then return $ tokreplace f "A-Za-z" "old" "new"+     else return $ tokreplace f "A-Za-z_" o n++twofilegen :: (FilePath -> FilePath -> Prim) -> Gen Prim+twofilegen p = do+  n1 <- filepathgen+  n2 <- filepathgen+  if n1 /= n2 && (check_a_patch $ fromPrims $ (p n1 n2 :>: NilFL))+     then return $ p n1 n2+     else twofilegen p++chprefgen :: Gen Prim+chprefgen = do+  f <- oneof [return "color", return "movie"]+  o <- tokengen+  n <- tokengen+  if o == n then return $ changepref f "old" "new"+            else return $ changepref f o n++simplepatchgen :: Gen Prim+simplepatchgen = frequency [(1,liftM addfile filepathgen),+                            (1,liftM adddir filepathgen),+                            (1,liftM3 binary filepathgen arbitrary arbitrary),+                            (1,twofilegen move),+                            (1,tokreplacegen),+                            (1,chprefgen),+                            (7,hunkgen)+                           ]++onepatchgen :: Gen Prim+onepatchgen = oneof [simplepatchgen, (invert) `fmap` simplepatchgen]++norecursgen :: Int -> Gen Patch+norecursgen 0 = PP `fmap` onepatchgen+norecursgen n = oneof [PP `fmap` onepatchgen,flatcompgen n]++arbpatch :: Int -> Gen Patch+arbpatch 0 = PP `fmap` onepatchgen+arbpatch n = frequency [(3,PP `fmap` onepatchgen),+                       -- (1,compgen n),+                        (2,flatcompgen n),+                        (0,raw_merge_gen n),+                        (0,mergegen n),+                        (1,PP `fmap` onepatchgen)+                       ]++unempty :: Arbitrary a => Gen [a]+unempty = do+  as <- arbitrary+  case as of+    [] -> unempty+    _ -> return as++join_patches :: [Patch] -> Patch+join_patches = joinPatches . unsafeFL++raw_merge_gen :: Int -> Gen Patch+raw_merge_gen n = do p1 <- arbpatch len+                     p2 <- arbpatch len+                     if (check_a_patch $ join_patches [invert p1,p2]) &&+                        (check_a_patch $ join_patches [invert p2,p1])+                        then case merge (p2 :\/: p1) of+                             _ :/\: p2' -> return p2'+                        else raw_merge_gen n+    where len = if n < 15 then n`div`3 else 3++mergegen :: Int -> Gen Patch+mergegen n = do+  p1 <- norecursgen len+  p2 <- norecursgen len+  if (check_a_patch $ join_patches [invert p1,p2]) &&+         (check_a_patch $ join_patches [invert p2,p1])+     then case merge (p2:\/:p1) of+          p1' :/\: p2' ->+              if check_a_patch $ join_patches [p1,p2']+              then return $ join_patches [p1,p2']+              else return $ join_patches [PP $ addfile "Error_in_mergegen",+                                          PP $ addfile "Error_in_mergegen",+                                          p1,p2,p1',p2']+     else mergegen n+  where len = if n < 15 then n`div`3 else 3++arbpi :: Gen PatchInfo+arbpi = do n <- unempty+           a <- unempty+           l <- unempty+           d <- unempty+           return $ unsafePerformIO $ patchinfo n d a l++instance Arbitrary PatchInfo where+    arbitrary = arbpi+--    coarbitrary pi = coarbitrary (show pi)++instance Arbitrary B.ByteString where+    arbitrary = liftM BC.pack arbitrary+--    coarbitrary ps = coarbitrary (unpackPS ps)++{-+plistgen :: Int -> Int -> Gen [Patch]+plistgen s n+    | n <= 0 = return []+    | otherwise = do+                  next <- arbpatch s+                  rest <- plistgen s (n-1)+                  return $ next : rest++compgen :: Int -> Gen Patch+compgen n = do+    size <- choose (0,n)+    myp <- liftM join_patches $ plistgen size ((n+1) `div` (size+1))+-- here I assume we only want to consider valid patches...+    if check_a_patch myp+       then return myp+       else compgen n+-}++flatlistgen :: Int -> Gen [Patch]+flatlistgen n = replicateM n (PP `fmap` onepatchgen)++flatcompgen :: Int -> Gen Patch+flatcompgen n = do+  myp <- liftM (join_patches . regularize_patches) $ flatlistgen n+  if check_a_patch myp+     then return myp+     else flatcompgen n++-- resize to size 25, that means we'll get line numbers no greater+-- than 1025 using QuickCheck 2.1+linenumgen :: Gen Int+linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),+                    (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]++tokengen :: Gen String+tokengen = oneof [return "hello", return "world", return "this",+                  return "is", return "a", return "silly",+                  return "token", return "test"]++toklinegen :: Gen String+toklinegen = liftM unwords $ replicateM 3 tokengen++filelinegen :: Gen B.ByteString+filelinegen = liftM BC.pack $+              frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),+                         (1,return ""), (1,return "{"), (1,return "}") ]++filepathgen :: Gen String+filepathgen = liftM fixpath badfpgen++fixpath :: String -> String+fixpath "" = "test"+fixpath p = fpth p++fpth :: String -> String+fpth ('/':'/':cs) = fpth ('/':cs)+fpth (c:cs) = c : fpth cs+fpth [] = []++newtype SafeChar = SS Char+instance Arbitrary SafeChar where+    arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")++fromSafeChar :: SafeChar -> Char+fromSafeChar (SS s) = s++badfpgen :: Gen String+badfpgen =  frequency [(1,return "test"), (1,return "hello"), (1,return "world"),+                       (1,map fromSafeChar `fmap` arbitrary),+                       (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]++{-+instance Arbitrary Char where+    arbitrary = oneof $ map return+                (['a'..'z']++['A'..'Z']++['1'..'9']++['0','~','.',',','-','/'])+-}+--    coarbitrary c = coarbitrary (ord c)++check_patch :: Patch -> PatchCheck Bool+check_a_patch :: Patch -> Bool+check_a_patch p = do_check $ do check_patch p+                                check_patch $ invert p+verbose_check_a_patch :: Patch -> Bool+verbose_check_a_patch p = do_verbose_check $ do check_patch p+                                                check_patch $ invert p++check_patch p | is_merger p = do+  check_patch $ fromPrims $ effect p+check_patch (Merger _ _ _ _) = impossible+check_patch (Regrem _ _ _ _) = impossible+check_patch (ComP NilFL) = is_valid+check_patch (ComP (p:>:ps)) =+  check_patch p >> check_patch (ComP ps)+check_patch (PP Identity) = is_valid+check_patch (PP (Split NilFL)) = is_valid+check_patch (PP (Split (p:>:ps))) =+  check_patch (PP p) >> check_patch (PP (Split ps))++check_patch (PP (FP f RmFile)) = remove_file $ fn2fp f+check_patch (PP (FP f AddFile)) =  create_file $ fn2fp f+check_patch (PP (FP f (Hunk line old new))) = do+    file_exists $ fn2fp f+    mapM (delete_line (fn2fp f) line) old+    mapM (insert_line (fn2fp f) line) (reverse new)+    is_valid+check_patch (PP (FP f (TokReplace t old new))) =+    modify_file (fn2fp f) (try_tok_possibly t old new)+-- note that the above isn't really a sure check, as it leaves PSomethings+-- and PNothings which may have contained new...+check_patch (PP (FP f (Binary o n))) = do+    file_exists $ fn2fp f+    mapM (delete_line (fn2fp f) 1) (linesPS o)+    file_empty $ fn2fp f+    mapM (insert_line (fn2fp f) 1) (reverse $ linesPS n)+    is_valid++check_patch (PP (DP d AddDir)) = create_dir $ fn2fp d+check_patch (PP (DP d RmDir)) = remove_dir $ fn2fp d++check_patch (PP (Move f f')) = check_move (fn2fp f) (fn2fp f')+check_patch (PP (ChangePref _ _ _)) = return True++regularize_patches :: [Patch] -> [Patch]+regularize_patches patches = rpint [] patches+    where rpint ok_ps [] = ok_ps+          rpint ok_ps (p:ps) =+            if check_a_patch (join_patches $ p:ok_ps)+            then rpint (p:ok_ps) ps+            else rpint ok_ps ps++prop_inverse_composition :: Patch -> Patch -> Bool+prop_inverse_composition p1 p2 =+    invert (join_patches [p1,p2]) == join_patches [invert p2, invert p1]+prop_inverse_valid :: Patch -> Bool+prop_inverse_valid p1 = check_a_patch $ join_patches [invert p1,p1]+prop_other_inverse_valid :: Patch -> Bool+prop_other_inverse_valid p1 = check_a_patch $ join_patches [p1,invert p1]++prop_commute_twice :: Patch -> Patch -> Property+prop_commute_twice p1 p2 =+    (does_commute p1 p2) ==> (Just (p2:<p1) == (commutex (p2:<p1) >>= commutex))+does_commute :: Patch -> Patch -> Bool+does_commute p1 p2 =+    commutex (p2:<p1) /= Nothing && (check_a_patch $ join_patches [p1,p2])+prop_commute_equivalency :: Patch -> Patch -> Property+prop_commute_equivalency p1 p2 =+    (does_commute p1 p2) ==>+    case commutex (p2:<p1) of+    Just (p1':<p2') -> check_a_patch $ join_patches [p1,p2,invert p1',invert p2']+    _ -> impossible++prop_commute_either_way :: Patch -> Patch -> Property+prop_commute_either_way p1 p2 =+    does_commute p1 p2 ==> does_commute (invert p2) (invert p1)++prop_commute_either_order :: Patch -> Patch -> Patch -> Property+prop_commute_either_order p1 p2 p3 =+    check_a_patch (join_patches [p1,p2,p3]) &&+    does_commute p1 (join_patches [p2,p3]) &&+    does_commute p2 p3 ==>+    case commutex (p2:<p1) of+    Nothing -> False+    Just (p1':<p2') ->+        case commutex (p3:<p1') of+        Nothing -> False+        Just (_:<p3') ->+            case commutex (p3':<p2') of+            Nothing -> False+            Just (_:< p3'') ->+                case commutex (p3:<p2) of+                Nothing -> False+                Just (_:<p3'a) ->+                    case commutex (p3'a:<p1) of+                    Just (_:<p3''a) -> p3''a == p3''+                    Nothing -> False++prop_patch_and_inverse_is_identity :: Patch -> Patch -> Property+prop_patch_and_inverse_is_identity p1 p2 =+    (check_a_patch $ join_patches [p1,p2]) && (commutex (p2:<p1) /= Nothing) ==>+    case commutex (p2:<p1) of+    Just (_:<p2') -> case commutex (p2':<invert p1) of+                    Nothing -> True -- This is a subtle distinction.+                    Just (_:<p2'') -> p2'' == p2+    Nothing -> impossible++quickmerge :: (Patch :\/: Patch) -> Patch+quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of+                        _ :/\: p1' -> p1'++prop_merge_is_commutable_and_correct :: Patch -> Patch -> Property+prop_merge_is_commutable_and_correct p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    case merge (p2:\/:p1) of+    p1' :/\: p2' ->+        case commutex (p2':<p1) of+        Nothing -> False+        Just (p1'':<p2'') -> p2'' == p2 && p1' == p1''+prop_merge_is_swapable :: Patch -> Patch -> Property+prop_merge_is_swapable p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    case merge (p2:\/:p1) of+    p1' :/\: p2' ->+           case merge (p1:\/:p2) of+           p2''' :/\: p1''' -> p1' == p1''' && p2' == p2'''++prop_merge_valid :: Patch -> Patch -> Property+prop_merge_valid p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    case merge (p2:\/:p1) of+    _ :/\: p2' ->+        check_a_patch $ join_patches [invert p1,p2,invert p2,p1,p2']++prop_simple_smart_merge_good_enough :: Patch -> Patch -> Property+prop_simple_smart_merge_good_enough p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    smart_merge (p2:\/:p1) == simple_smart_merge (p2:\/:p1)++smart_merge :: (Patch :\/: Patch) -> Maybe (Patch :< Patch)+smart_merge (p1 :\/: p2) =+  case simple_smart_merge (p1:\/:p2) of+  Nothing -> Nothing+  Just (p1'a:<p2a) ->+      case simple_smart_merge (p2 :\/: p1) >>= commutex of+      Nothing -> Nothing+      Just (p1'b :< p2b) ->+          if p1'a == p1'b && p2a == p2b && p2a == p2+          then Just (p1'a :< p2)+          else Nothing+simple_smart_merge :: (Patch :\/:  Patch) -> Maybe (Patch :< Patch)+simple_smart_merge (p1 :\/: p2) =+  case commutex (p1 :< invert p2) of+  Just (_:<p1') ->+      case commutex (p1':< p2) of+      Just (_:< p1o) ->+          if p1o == p1 then Just (p1' :< p2)+          else Nothing+      Nothing -> Nothing+  Nothing -> Nothing++prop_elegant_merge_good_enough :: Patch -> Patch -> Property+prop_elegant_merge_good_enough p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    (fst' `fmap` smart_merge (p2:\/:p1)) ==+       (snd'' `fmap` elegant_merge (p2:\/:p1))++fst' :: p :< p -> p+fst' (x:<_) = x++snd'' :: q :/\: p -> p+snd'' (_:/\:x) = x++instance Eq p => Eq (p :< p) where+   (x:<y) == (x':<y') = x == x' && y == y'++instance Show p => Show (p :< p) where+  show (x :< y) = show x ++ " :< " ++ show y++test_patch :: String+test_patch = test_str ++ test_note+tp1, tp2 :: Patch+tp1 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test/test ./hello\n"+tp2 = unsafeUnseal . fst . fromJust . readPatch $ BC.pack "\nmove ./test ./hello\n"+tp1', tp2' :: Patch+tp2' = quickmerge (tp2:\/:tp1)+tp1' = quickmerge (tp1:\/:tp2)+test_note :: String+test_note = (if commutex (tp2':<tp1) == Just (tp1':<tp2)+              then "At least they commutex right.\n"+              else "Argh! they don't even commutex right.\n")+         ++(if check_a_patch $ tp2+              then "tp2 itself is valid!\n"+              else "Oh my! tp2 isn't even valid!\n")+         ++(if check_a_patch $ tp2'+              then "tp2' itself is valid!\n"+              else "Aaack! tp2' itself is invalid!\n")+         ++(if check_a_patch $ join_patches [tp1, tp2']+              then "Valid merge tp2'!\n"+              else "Bad merge tp2'!\n")+         ++ (if check_a_patch $ join_patches [tp2, tp1']+              then "Valid merge tp1'!\n"+              else "Bad merge tp1'!\n")+         ++ (if check_a_patch $ join_patches [tp2,tp1',invert tp2',invert tp1]+              then "Both agree!\n"+              else "The two merges don't agree!\n")+         ++ (if check_a_patch $ join_patches [invert tp2, tp1]+              then "They should be mergable!\n"+              else "Wait a minute, these guys can't be merged!\n")+tp :: Patch+tp = tp1'++test_str :: String+test_str = "Patches are:\n"++(show tp)+           ++(if check_a_patch tp+              then "At least the patch itself is valid.\n"+              else "The patch itself is bad!\n")+           ++"commutex of tp1' and tp2 is "++show (commutex (tp1':<tp2))++"\n"+           ++"commutex of tp2' and tp1 is "++show (commutex (tp2':<tp1))++"\n"+           {-++ "\nSimply flattened, it is:\n"+                  ++ (show $ mapFL (joinPatches.flattenFL.merger_equivalent) $ flattenFL tp)+           ++ "\n\nUnravelled, it gives:\n" ++ (show $ map unravel $ flatten tp)+           ++ "\n\nUnwound, it gives:\n" ++ (show $ mapFL unwind $ flattenFL tp)+           ++(if check_a_patch (join_patches$ reverse $ unwind tp)+              then "Unwinding is valid.\n"+              else "Bad unwinding!\n")+           ++(if check_a_patch $ join_patches [tp,invert tp]+              then "Inverse is valid.\n"+              else "Bad inverse!\n")+           ++(if check_a_patch $ join_patches [invert tp, tp]+              then "Other inverse is valid.\n"+              else "Bad other inverse!\n")-}++-- | 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.+prop_unravel_three_merge :: Patch -> Patch -> Patch -> Property+prop_unravel_three_merge p1 p2 p3 =+    (check_a_patch $ join_patches [invert p1,p2,invert p2,p3]) ==>+    (unravel $ merger "0.0" (merger "0.0" p2 p3) (merger "0.0" p2 p1)) ==+    (unravel $ merger "0.0" (merger "0.0" p1 p3) (merger "0.0" p1 p2))++prop_unravel_seq_merge :: Patch -> Patch -> Patch -> Property+prop_unravel_seq_merge p1 p2 p3 =+    (check_a_patch $ join_patches [invert p1,p2,p3]) ==>+    (unravel $ merger "0.0" p3 $ merger "0.0" p2 p1) ==+    (unravel $ merger "0.0" (merger "0.0" p2 p1) p3)++prop_unravel_order_independent :: Patch -> Patch -> Property+prop_unravel_order_independent p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    (unravel $ merger "0.0" p2 p1) == (unravel $ merger "0.0" p1 p2)++prop_resolve_conflicts_valid :: Patch -> Patch -> Property+prop_resolve_conflicts_valid p1 p2 =+    (check_a_patch $ join_patches [invert p1,p2]) ==>+    and $ map (check_a_patch.(\l-> join_patches [p,merge_list l]))+            $ resolve_conflicts p+        where p = case merge (p1:\/:p2) of+                  _ :/\: p1' -> join_patches [p2,p1']++merge_list :: [Sealed (FL Prim C(x))] -> Patch+merge_list patches = fromPrims `unseal` doml NilFL patches+    where 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++try_tok_possibly :: String -> String -> String+                -> [Possibly B.ByteString] -> Maybe [Possibly B.ByteString]+try_tok_possibly t o n mss =+    mapM (silly_maybe_possibly $ liftM B.concat .+                    try_tok_internal t (BC.pack o) (BC.pack n))+                 $ take 1000 mss++silly_maybe_possibly :: (B.ByteString -> Maybe B.ByteString) ->+                        (Possibly B.ByteString -> Maybe (Possibly B.ByteString))+silly_maybe_possibly f =+    \px -> case px of+           PNothing -> Just PNothing+           PSomething -> Just PSomething+           PJust x -> case f x of+                      Nothing -> Nothing+                      Just x' -> Just $ PJust x'++try_tok_internal :: String -> B.ByteString -> B.ByteString+                 -> B.ByteString -> Maybe [B.ByteString]+try_tok_internal _ _ _ s | B.null s = Just []+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++prop_read_show :: Patch -> Bool+prop_read_show p = case readPatch $ renderPS $ showPatch p of+                   Just (Sealed p',_) -> p' == p+                   Nothing -> False++-- |In order for merges to work right with commuted patches, inverting a patch+-- past a patch and its inverse had golly well better give you the same patch+-- back again.+prop_commute_inverse :: Patch -> Patch -> Property+prop_commute_inverse p1 p2 =+    does_commute p1 p2 ==> case commutex (p2:< p1) of+                           Nothing -> impossible+                           Just (p1':<_) ->+                               case commutex (invert p2:< p1') of+                               Nothing -> False+                               Just (p1'':<_) -> p1'' == p1++subcommutes_inverse :: [(String, Prim -> Prim -> Property)]+subcommutes_inverse = zip names (map prop_subcommute cs)+    where (names, cs) = unzip subcommutes+          prop_subcommute c p1 p2 =+              does c p1 p2 ==>+              case c (p2:< p1) of+              Succeeded (p1':<p2') ->+                  case c (invert p2:< p1') of+                  Succeeded (p1'':<ip2x') -> p1'' == p1 &&+                      case c (invert p1:< invert p2) of+                      Succeeded (ip2':< ip1') ->+                          case c (p2':< invert p1) of+                          Succeeded (ip1o':< p2o) ->+                              invert ip1' == p1' && invert ip2' == p2' &&+                              ip1o' == ip1' && p2o == p2 &&+                              p1'' == p1 && ip2x' == ip2'+                          _ -> False+                      _ -> False+                  _ -> False+              _ -> False++subcommutes_nontrivial_inverse :: [(String, Prim -> Prim -> Property)]+subcommutes_nontrivial_inverse = zip names (map prop_subcommute cs)+    where (names, cs) = unzip subcommutes+          prop_subcommute c p1 p2 =+              nontrivial c p1 p2 ==>+              case c (p2:< p1) of+              Succeeded (p1':<p2') ->+                  case c (invert p2:< p1') of+                  Succeeded (p1'':<ip2x') -> p1'' == p1 &&+                      case c (invert p1:< invert p2) of+                      Succeeded (ip2':< ip1') ->+                          case c (p2':< invert p1) of+                          Succeeded (ip1o':< p2o) ->+                              invert ip1' == p1' && invert ip2' == p2' &&+                              ip1o' == ip1' && p2o == p2 &&+                              p1'' == p1 && ip2x' == ip2'+                          _ -> False+                      _ -> False+                  _ -> False+              _ -> False++subcommutes_failure :: [(String, Prim -> Prim -> Property)]+subcommutes_failure = zip names (map prop cs)+    where (names, cs) = unzip subcommutes+          prop c p1 p2 =+              does_fail c p1 p2 ==> case c (invert p1 :< invert p2) of+                                    Failed -> True+                                    _ -> False++does_fail :: CommuteFunction -> Prim -> Prim -> Bool+does_fail c p1 p2 =+    fails (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])+        where fails Failed = True+              fails _ = False++does :: CommuteFunction -> Prim -> Prim -> Bool+does c p1 p2 =+    succeeds (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])+        where succeeds (Succeeded _) = True+              succeeds _ = False++nontrivial :: CommuteFunction -> Prim -> Prim -> Bool+nontrivial c p1 p2 =+    succeeds (c (p2:<p1)) && (check_a_patch $ fromPrims $ unsafeFL [p1,p2])+        where succeeds (Succeeded (p1' :< p2')) = p1' /= p1 || p2' /= p2+              succeeds _ = False
+ 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/Unit.hs view
@@ -0,0 +1,433 @@+-- 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 -fno-warn-deprecations -fno-warn-orphans -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Patch.Unit ( run_patch_unit_tests ) where++import Control.Monad ( unless )+import Data.Maybe ( catMaybes )+import qualified Data.ByteString.Char8 as BC ( pack )+import Darcs.Sealed+import Darcs.Patch+import Darcs.Patch.Patchy ( mergeFL, Invert )+import Darcs.Patch.Real ( RealPatch, prim2real, is_consistent, is_forward, is_duplicate )+import Darcs.Patch.Test () -- for instance Eq Patch+import Darcs.Ordered+import Darcs.Patch.Properties ( recommute, commute_inverses, permutivity, partial_permutivity,+                                inverse_doesnt_commute, patch_and_inverse_commute,+                                merge_commute, merge_consistent, merge_arguments_consistent,+                                merge_either_way, show_read,+                                join_inverses, join_commute )+import Darcs.Patch.Prim ( join )+import Darcs.Patch.QuickCheck+import Printer ( Doc, redText, ($$) )+--import Printer ( greenText )+--import Darcs.ColorPrinter ( traceDoc )+--import Darcs.ColorPrinter ( errorDoc )+import Darcs.ColorPrinter () -- for instance Show Doc++-- import Debug.Trace+-- #include "impossible.h"++run_patch_unit_tests :: IO Int+run_patch_unit_tests =+    run_some_tests ""+    [--do putStr "Checking with quickcheck that real patches have consistent flattenings... "+     --   quickCheck (not . isBottomTimeOut (Just 10) . prop_consistent_tree_flattenings) >> return 0+     run_primitive_tests "prim join inverses"+                         (\(a:\/:_) -> join_inverses join a) mergeables+    ,do putStr "Checking prim join inverses using QuickCheck... "+        simpleCheck (join_inverses join)+    ,run_primitive_tests "prim inverse doesn't commute"+                         (\(a:\/:_) -> inverse_doesnt_commute a) mergeables+    -- The following fails because of setpref patches...+    --,do putStr "Checking prim inverse doesn't commute using QuickCheck... "+    --    simpleCheck (inverse_doesnt_commute :: Prim -> Maybe Doc)+    ,run_primitive_tests "join commute" (join_commute join) prim_permutables+    ,do putStr "Checking prim join commute using QuickCheck... "+        simpleCheck (unseal2 (join_commute join))++    ,run_primitive_tests "prim recommute"+                         (recommute commute) $ map mergeable2commutable mergeables+    ,run_primitive_tests "prim patch and inverse commute"+                         (patch_and_inverse_commute commute) $ map mergeable2commutable mergeables+    ,run_primitive_tests "prim inverses commute"+                         (commute_inverses commute) $ map mergeable2commutable mergeables++--    ,do putStr "Checking prim recommute using QuickCheck... "+--        simpleCheck (recommute+--                     (commute :: Prim :> Prim+--                              -> Maybe (Prim :> Prim)))++    ,run_primitive_tests "FL prim recommute"+                         (recommute commute) $ map mergeable2commutable mergeablesFL+    ,run_primitive_tests "FL prim patch and inverse commute"+                         (patch_and_inverse_commute commute) $ map mergeable2commutable mergeablesFL+    ,run_primitive_tests "FL prim inverses commute"+                         (commute_inverses commute) $ map mergeable2commutable mergeablesFL++    ,run_primitive_tests "fails" (commute_fails commute) ([] :: [Prim :> Prim])++    ,run_primitive_tests "read and show work on Prim" show_read prim_patches+    ,run_primitive_tests "read and show work on RealPatch" show_read real_patches+    ,do putStr "Checking that readPatch and showPatch work on RealPatch... "+        simpleCheck (unseal $ patchFromTree $ (show_read :: RealPatch -> Maybe Doc))+    ,do putStr "Checking that readPatch and showPatch work on FL RealPatch... "+        simpleCheck (unseal2 $ (show_read :: FL RealPatch -> Maybe Doc))++    ,run_primitive_tests "example flattenings work"+                             (\x -> if prop_consistent_tree_flattenings x+                                    then Nothing+                                    else Just $ redText "oops")+                             real_patch_loop_examples+    ,do putStr "Checking that tree flattenings are consistent... "+        simpleCheck ((\b -> if b then Nothing else Just False) . prop_consistent_tree_flattenings)++    ,do putStr "Checking with quickcheck that real patches are consistent... "+        simpleCheck (unseal $ patchFromTree $ is_consistent)+    ,run_primitive_tests "real merge input consistent"+                             (merge_arguments_consistent is_consistent) real_mergeables+    ,run_primitive_tests "real merge input is forward"+                             (merge_arguments_consistent is_forward) real_mergeables+    ,run_primitive_tests "real merge output is forward"+                             (merge_consistent is_forward) real_mergeables+    ,run_primitive_tests "real merge output consistent"+                             (merge_consistent is_consistent) real_mergeables+    ,run_primitive_tests "real merge either way" merge_either_way real_mergeables+    ,run_primitive_tests "real merge and commute" merge_commute real_mergeables++    ,run_primitive_tests "real recommute" (recommute commute) real_commutables+    ,run_primitive_tests "real inverses commute" (commute_inverses commute) real_commutables++    ,run_primitive_tests "real permutivity" (permutivity commute) $+                         filter (not_duplicatestriple) real_triples+    ,run_primitive_tests "real partial permutivity" (partial_permutivity commute) $+                         filter (not_duplicatestriple) real_triples++    ,do putStr "Checking we can do merges using QuickCheck... "+        simpleCheck (prop_is_mergeable ::+                         Sealed (WithStartState RepoModel (Tree Prim))+                             -> Maybe (Tree RealPatch C(x)))+    ,do putStr "Checking again we can do merges using QuickCheck... "+        thoroughCheck 1000 (prop_is_mergeable ::+                                Sealed (WithStartState RepoModel (Tree Prim))+                                    -> Maybe (Tree RealPatch C(x)))++    ,do putStr "Checking recommute using QuickCheck Tree generator... "+        simpleCheck (unseal $ commutePairFromTree $+                    (recommute+                     (commute :: RealPatch :> RealPatch+                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking recommute using QuickCheck TWFP generator... "+        simpleCheck (unseal $ commutePairFromTWFP $+                    (recommute+                     (commute :: RealPatch :> RealPatch+                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking nontrivial recommute... "+        simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)+                                   (unseal $ commutePairFromTree $+                                    (recommute+                                     (commute :: RealPatch :> RealPatch+                                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking nontrivial recommute using TWFP... "+        simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)+                                   (unseal $ commutePairFromTWFP $+                                    (recommute+                                     (commute :: RealPatch :> RealPatch+                                              -> Maybe (RealPatch :> RealPatch))))++    ,do putStr "Checking inverses commute using QuickCheck Tree generator... "+        simpleCheck (unseal $ commutePairFromTree $+                    (commute_inverses+                     (commute :: RealPatch :> RealPatch+                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking inverses commute using QuickCheck TWFP generator... "+        simpleCheck (unseal $ commutePairFromTWFP $+                    (commute_inverses+                     (commute :: RealPatch :> RealPatch+                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking nontrivial inverses commute... "+        simpleConditionalCheck (unseal $ commutePairFromTree $ nontrivial_reals)+                                   (unseal $ commutePairFromTree $+                                    (commute_inverses+                                     (commute :: RealPatch :> RealPatch+                                              -> Maybe (RealPatch :> RealPatch))))+    ,do putStr "Checking nontrivial inverses commute using TWFP... "+        simpleConditionalCheck (unseal $ commutePairFromTWFP $ nontrivial_reals)+                                   (unseal $ commutePairFromTWFP $+                                    (commute_inverses+                                     (commute :: RealPatch :> RealPatch+                                              -> Maybe (RealPatch :> RealPatch))))++    ,do putStr "Checking merge either way using QuickCheck TWFP generator... "+        simpleCheck (unseal $ mergePairFromTWFP $+                     (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))+    ,do putStr "Checking merge either way using QuickCheck Tree generator... "+        simpleCheck (unseal $ mergePairFromTree $+                     (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))+    ,do putStr "Checking nontrivial merge either way... "+        simpleConditionalCheck (unseal $ mergePairFromTree $ nontrivial_merge_reals)+                                   (unseal $ mergePairFromTree $+                                    (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))+    ,do putStr "Checking nontrivial merge either way using TWFP... "+        simpleConditionalCheck (unseal $ mergePairFromTWFP $ nontrivial_merge_reals)+                                   (unseal $ mergePairFromTWFP $+                                    (merge_either_way :: RealPatch :\/: RealPatch -> Maybe Doc))++    ,do putStr "Checking permutivity... "+        simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)+            (unseal $ commuteTripleFromTree $ permutivity+                    (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))+    ,do putStr "Checking partial permutivity... "+        simpleConditionalCheck (unseal $ commuteTripleFromTree not_duplicatestriple)+            (unseal $ commuteTripleFromTree $ partial_permutivity+                    (commute :: RealPatch :> RealPatch -> Maybe (RealPatch :> RealPatch)))+    ,do putStr "Checking nontrivial permutivity... "+        simpleConditionalCheck (unseal $ commuteTripleFromTree+                                           (\t -> nontrivial_triple t && not_duplicatestriple t))+                  (unseal $ commuteTripleFromTree $+                    (permutivity+                     (commute :: RealPatch :> RealPatch+                              -> Maybe (RealPatch :> RealPatch))))+    ]++not_duplicatestriple :: RealPatch :> RealPatch :> RealPatch -> Bool+not_duplicatestriple (a :> b :> c) = not $ any is_duplicate [a,b,c]++--not_duplicates_pair :: RealPatch :> RealPatch -> Bool+--not_duplicates_pair (a :> b) = not $ any is_duplicate [a,b]++nontrivial_triple :: RealPatch :> RealPatch :> RealPatch -> Bool+nontrivial_triple (a :> b :> c) =+    case commute (a :> b) of+    Nothing -> False+    Just (b' :> a') ->+      case commute (a' :> c) of+      Nothing -> False+      Just (c'' :> a'') ->+        case commute (b :> c) of+        Nothing -> False+        Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&+                            (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&+                            (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))++nontrivial_reals :: RealPatch :> RealPatch -> Bool+nontrivial_reals = nontrivial_commute++nontrivial_commute :: Patchy p => p :> p -> Bool+nontrivial_commute (x :> y) = case commute (x :> y) of+                              Just (y' :> x') -> not (y' `unsafeCompare` y) ||+                                                 not (x' `unsafeCompare` x)+                              Nothing -> False++nontrivial_merge_reals :: RealPatch :\/: RealPatch -> Bool+nontrivial_merge_reals = nontrivial_merge++nontrivial_merge :: Patchy p => p :\/: p -> Bool+nontrivial_merge (x :\/: y) = case merge (x :\/: y) of+                              y' :/\: x' -> not (y' `unsafeCompare` y) ||+                                            not (x' `unsafeCompare` x)++run_some_tests :: String -> [IO Int] -> IO Int+run_some_tests name ts = do unless (null name) $ putStr $ "Testing " ++ name ++ "... "+                            errs <- sum `fmap` sequence ts+                            unless (null name) $+                                   if errs < 1+                                   then putStrLn "passed."+                                   else putStrLn $ "failed " ++ name ++" in "++ show errs ++ " tests."+                            return errs++run_primitive_tests :: (Show a, Show b) => String -> (a -> Maybe b) -> [a] -> IO Int+run_primitive_tests name test datas = run_some_tests name $ map test' datas+    where test' d = case test d of+                    Just e -> do putStrLn $ name ++ " failed!"+                                 putStrLn $ "Input: " ++ show d+                                 putStrLn $ "Output: " ++ show e+                                 return 1+                    Nothing -> return 0++quickhunk :: Int -> String -> String -> Prim+quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)+                                (map (\c -> BC.pack [c]) n)++prim_permutables :: [Prim :> Prim :> Prim]+prim_permutables =+    [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]++mergeables :: [Prim :\/: Prim]+mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",+              quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",+              quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",+              quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",+              quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",+              quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""+             ]++mergeablesFL :: [FL Prim :\/: FL Prim]+mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables +++           [] --    [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)+              --  :\/: (quickhunk 1 "a" "z" :>: NilFL),+              --  (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)+              --  :\/: (quickhunk 1 "a" "z" :>: NilFL)]++mergeable2commutable :: Invert p => p :\/: p -> p :> p+mergeable2commutable (x :\/: y) = invert x :> y++prim_patches :: [Prim]+prim_patches = concatMap mergeable2patches mergeables+    where mergeable2patches (x:\/:y) = [x,y]++real_patches :: [RealPatch]+real_patches = concatMap commutable2patches real_commutables+    where commutable2patches (x:>y) = [x,y]++real_triples :: [RealPatch :> RealPatch :> RealPatch]+real_triples = [ob' :> oa2 :> a2'',+                oa' :> oa2 :> a2''] ++ triple_examples+               ++ map unsafeUnseal2 (concatMap getTriples realFLs)+    where oa = prim2real $ quickhunk 1 "o" "aa"+          oa2 = oa+          a2 = prim2real $ quickhunk 2 "a34" "2xx"+          ob = prim2real $ quickhunk 1 "o" "bb"+          ob' :/\: oa' = merge (oa :\/: ob)+          a2' :/\: _ = merge (ob' :\/: a2)+          a2'' :/\: _ = merge (oa2 :\/: a2')++realFLs :: [FL RealPatch]+realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]+    where oa = prim2real $ quickhunk 1 "o" "a"+          ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)++real_commutables :: [RealPatch :> RealPatch]+real_commutables = commute_examples ++ map mergeable2commutable real_mergeables+++                   [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)+    where oa = prim2real $ quickhunk 1 "o" "a"+          ob = prim2real $ quickhunk 1 "o" "b"+          _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)++real_mergeables :: [RealPatch :\/: RealPatch]+real_mergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables+                        ++ real_igloo_mergeables+                        ++ real_quickcheck_mergeables+                        ++ merge_examples+                        ++ catMaybes (map pair2m (concatMap getPairs realFLs))+                        ++ [(oa :\/: od),+                            (oa :\/: a2'),+                            (ob' :\/: od''),+                            (oe :\/: od),+                            (of' :\/: oe'),+                            (ob' :\/: oe'),+                            (oa :\/: oe'),+                            (ob' :\/: oc'),+                            (b2' :\/: oc'''),+                            (ob' :\/: a2),+                            (b2' :\/: og'''),+                            (oc''' :\/: og'''),+                            (oc'' :\/: og''),+                            (ob'' :\/: og''),+                            (ob'' :\/: oc''),+                            (oc' :\/: od'')]+    where oa = prim2real $ quickhunk 1 "o" "aa"+          a2 = prim2real $ quickhunk 2 "a34" "2xx"+          og = prim2real $ quickhunk 3 "4" "g"+          ob = prim2real $ quickhunk 1 "o" "bb"+          b2 = prim2real $ quickhunk 2 "b" "2"+          oc = prim2real $ quickhunk 1 "o" "cc"+          od = prim2real $ quickhunk 7 "x" "d"+          oe = prim2real $ quickhunk 7 "x" "e"+          pf = prim2real $ quickhunk 7 "x" "f"+          od'' = prim2real $ quickhunk 8 "x" "d"+          ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)+          a2' :/\: _ = merge (ob' :\/: a2)+          ob'' :/\: _ = merge (a2 :\/: ob')+          og' :/\: _ = merge (oa :\/: og)+          og'' :/\: _ = merge (a2 :\/: og')+          og''' :/\: _ = merge (ob' :\/: og')+          oc' :/\: _ = merge (oa :\/: oc)+          oc'' :/\: _ = merge (a2 :\/: oc)+          oc''' :/\: _ = merge (ob' :\/: oc')+          oe' :/\: _ = merge (od :\/: oe)+          of' :/\: _ = merge (od :\/: pf)+          pair2m :: Sealed2 (RealPatch :> RealPatch)+                 -> Maybe (RealPatch :\/: RealPatch)+          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+                                          return (xx :\/: y')++real_igloo_mergeables :: [RealPatch :\/: RealPatch]+real_igloo_mergeables = [(a :\/: b),+                    (b :\/: c),+                    (a :\/: c),+                    (x :\/: a),+                    (y :\/: b),+                    (z :\/: c),+                    (x' :\/: y'),+                    (z' :\/: y'),+                    (x' :\/: z'),+                    (a :\/: a)]+    where a = prim2real $ quickhunk 1 "1" "A"+          b = prim2real $ quickhunk 2 "2" "B"+          c = prim2real $ quickhunk 3 "3" "C"+          x = prim2real $ quickhunk 1 "1BC" "xbc"+          y = prim2real $ quickhunk 1 "A2C" "ayc"+          z = prim2real $ quickhunk 1 "AB3" "abz"+          x' :/\: _ = merge (a :\/: x)+          y' :/\: _ = merge (b :\/: y)+          z' :/\: _ = merge (c :\/: z)++real_quickcheck_mergeables :: [RealPatch :\/: RealPatch]+real_quickcheck_mergeables = [-- invert k1 :\/: n1+                             --, invert k2 :\/: n2+                               hb :\/: k+                             , b' :\/: b'+                             , n' :\/: n'+                             , b :\/: d+                             , k' :\/: k'+                             , k3 :\/: k3+                             ] ++ catMaybes (map pair2m pairs)+    where hb = prim2real $ quickhunk 0 "" "hb"+          k = prim2real $ quickhunk 0 "" "k"+          n = prim2real $ quickhunk 0 "" "n"+          b = prim2real $ quickhunk 1 "b" ""+          d = prim2real $ quickhunk 2 "" "d"+          d':/\:_ = merge (b :\/: d)+          --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)+          --k2 :>: n2 :>: NilFL :/\: _ =+          --    merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)+          k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)+          pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)+          pair2m :: Sealed2 (RealPatch :> RealPatch)+                 -> Maybe (RealPatch :\/: RealPatch)+          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+                                          return (xx :\/: y')++          i = prim2real $ quickhunk 0 "" "i"+          x = prim2real $ quickhunk 0 "" "x"+          xi = prim2real $ quickhunk 0 "xi" ""+          d3 :/\: _ = merge (xi :\/: d)+          _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)++commute_fails :: (MyEq p, Patchy p) => (p :> p -> Maybe (p :> p)) -> p :> p+              -> Maybe Doc+commute_fails c (x :> y) = do y' :> x' <- c (x :> y)+                              return $ redText "x" $$ showPatch x $$+                                       redText ":> y" $$ showPatch y $$+                                       redText "y'" $$ showPatch y' $$+                                       redText ":> x'" $$ showPatch x'
+ 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/Progress.hs view
@@ -0,0 +1,218 @@+-- Various utility functions that do not belong anywhere else.++{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++#include "gadts.h"++module Darcs.Progress ( beginTedious, endTedious, tediousSize,+                        debugMessage, debugFail, withoutProgress,+                        progress, finishedOne, finishedOneIO,+                        progressList, progressFL, progressRL,+                        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.Ordered ( FL(..), RL(..), lengthRL, lengthFL )+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 :: String -> IO ()+beginTedious k = do debugMessage $ "Beginning " ++ lower k+                    setProgressData k $ ProgressData { sofar = 0,+                                                       latest = Nothing,+                                                       total = Nothing }++endTedious :: String -> IO ()+endTedious k = whenProgressMode $ do p <- getProgressData k+                                     modifyIORef _progressData (\(a,m) -> (a,delete k m))+                                     when (isJust p) $ debugMessage $ "Done "++lower k++lower :: String -> String+lower (x:xs) = toLower x:xs+lower "" = ""++beginOrEndTedious :: String -> Int -> IO ()+beginOrEndTedious k l = do mp <- getProgressData k+                           case mp of+                             Nothing -> do beginTedious k+                                           tediousSize k l+                             Just p -> if total p == Just l+                                       then endTedious k+                                       else return ()++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 beginOrEndTedious k l+                                           return y+          pl [y] = [startit y]+          pl [] = []+          pl (y:ys) = progress k y : pl ys++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 beginOrEndTedious k l+                                           return y+          pl :: FL a C(x y) -> FL a C(x y)+          pl (y:>:NilFL) = (startit y) :>: NilFL+          pl NilFL = NilFL+          pl (y:>:ys) = progress k y :>: pl ys++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 beginOrEndTedious k l+                                           return y+          pl :: RL a C(x y) -> RL a C(x y)+          pl (y:<:NilRL) = (startit y) :<: NilRL+          pl NilRL = NilRL+          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 ""++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':take (length s) (repeat ' ')++"\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/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,214 @@+{-# 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.++module Darcs.RepoPath ( AbsolutePath, makeAbsolute, ioAbsolute, rootDirectory,+                        SubPath, makeSubPathOf, simpleSubPath,+                        AbsolutePathOrStd,+                        makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd,+                        AbsoluteOrRemotePath, ioAbsoluteOrRemote, isRemote,+                        makeRelative, 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 Autoconf ( path_separator )+import qualified Workaround ( getCurrentDirectory )+import qualified System.Directory ( setCurrentDirectory )+import System.Directory ( doesDirectoryExist )+import qualified System.FilePath.Posix as FilePath+import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )++class FilePathOrURL a where+ {-# INLINE toPath #-}+ toPath :: a -> String++class FilePathOrURL a => FilePathLike a where+ {-# INLINE toFilePath #-}+ toFilePath :: a -> FilePath++-- | 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)+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 | is_relative x = Just $ SubPath $ FilePath.normalise $ map cleanup x+                | otherwise = Nothing++makeRelative :: AbsolutePath -> AbsolutePath -> FilePath+makeRelative (AbsolutePath p1) (AbsolutePath p2) = mr p1 p2+    where mr x y | x == y = "."+          mr x y | takedir x == takedir y = mr (dropdir x) (dropdir y)+          mr x y = add_dotdots x y+          add_dotdots "" y = dropWhile  (=='/') y+          add_dotdots x y = '.':'.':'/': add_dotdots (dropdir x) y+          takedir = takeWhile (/='/')  . dropWhile (=='/')+          dropdir = dropWhile (/='/') . dropWhile (=='/')++-- | 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 FilePath.takeDirectory dir of+                                "" ->  "."+                                d  -> d+                  file = FilePath.takeFileName dir+              in do abs_dir <- ioAbsolute super_dir+                    return $ makeAbsolute abs_dir file++makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath+makeAbsolute a dir = if is_absolute dir+                     then AbsolutePath $+                          slashes ++ FilePath.normalise cleandir+                     else ma a $ FilePath.normalise cleandir+  where+    cleandir  = map cleanup dir+    slashes = norm_slashes $ takeWhile (== '/') cleandir+    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)++simpleClean :: String -> String+simpleClean x = norm_slashes $ reverse $ dropWhile (=='/') $ reverse $+                map cleanup x++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++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++cleanup :: Char -> Char+cleanup '\\' | path_separator == '\\' = '/'+cleanup c = c++norm_slashes :: String -> String+#ifndef WIN32+-- multiple slashes in front are ignored under Unix+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, replacePristine, replacePristineFromSlurpy,+                    slurp_recorded, slurp_recorded_and_unrecorded,+                    withRecorded,+                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+                    get_unrecorded_in_files,+                    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, checkPristineAgainstCwd,+                    checkPristineAgainstSlurpy, getMarkedupFile,+                    PatchSet, SealedPatchSet, PatchInfoAnd,+                    setScriptsExecutable,+                    checkUnrelatedRepos,+                    testTentative+                  ) where++import System.Exit ( ExitCode(..), exitWith )++import Darcs.Repository.Internal+    (Repository(..), RepoType(..), ($-), pristineFromWorking,+     maybeIdentifyRepository, identifyRepositoryFor,+     findRepository, amInRepository, amNotInRepository,+     makePatchLazy,+     slurp_pending, replacePristine, replacePristineFromSlurpy,+     slurp_recorded, slurp_recorded_and_unrecorded,+     withRecorded,+     get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+     get_unrecorded_in_files,+     read_repo, sync_repo,+     prefsUrl, checkPristineAgainstCwd, 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+    )+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.RepoPath ( toFilePath )+import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )+import Darcs.External ( copyFileOrUrl, Cachable(..) )+import Darcs.Progress ( debugMessage, progressFL, progressRL, tediousSize,+                        beginTedious, endTedious, progress )+import Darcs.Lock ( withTempDir, 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" ++ show 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+                   withTempDir "newpristine" $ \newpris ->+                       replacePristine torepository (toFilePath newpris)+                   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 $ progressRL "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 Darcs.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,260 @@+{-# 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+                 ) 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 Darcs.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"++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]++-- This function 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 :: 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 -> 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++-- |Note that the file 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 -> String -> B.ByteString -> IO ()+write NoCompression = writeAtomicFilePS+write GzipCompression = gzWriteAtomicFilePS++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 = unsafeCoerceP IsEq+               | otherwise = NotEq++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,353 @@+%  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}+\label{repository_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 Darcs.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,+                 )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.Depends ( is_tag )+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.Progress ( 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++\end{code}++\begin{code}+--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") ""+\end{code}++\begin{code}+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 <- fetchFilePS (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 -> []+\end{code}++\begin{code}+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,132 @@+-- 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 Darcs.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+newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )++df :: FilePath+df = darcsdir++"/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 :: 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++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]]++-- Nothing means we can write+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)++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 :: 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++is_known :: B.ByteString -> Bool+is_known p = p `elem` map rp2ps known_properties++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,413 @@+-- 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 Darcs.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 :: 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 -> 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,400 @@+-- 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, replacePristine,+                                     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 Darcs.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+                                    Sealed x <- createHashed h (parse i)+                                    return $ patchInfoAndPatch i $ unsafeCoerceP x+    where parse i h = do debugMessage ("Reading 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]++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 =+    case extractHash hp of+    Right h -> return (info hp, h)+    Left p -> fmap (\h -> (info hp, h)) $ writeHashFile c compr HashedPatchesDir $ showPatch p++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 = replacePristine c compr "."++replacePristine :: Cache -> Compression -> FilePath -> IO ()+replacePristine c compr d = do s <- slurp_all_but_darcs d+                               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,1042 @@+-- 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,+                    withRecorded, checkPristineAgainstCwd,+                    checkPristineAgainstSlurpy,+                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,+                    get_unrecorded_in_files,+                    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,+                    replacePristine, replacePristineFromSlurpy,+                    optimizeInventory, cleanRepository,+                    getMarkedupFile,+                    PatchSet, SealedPatchSet,+                    setScriptsExecutable,+                    getRepository, rIO,+                    testTentative+                  ) 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, checkPristine,+                                   easyCreatePristineDirectoryTree, slurpPristine, syncPristine,+                                   easyCreatePartialsPristineDirectoryTree,+                                   createPristineFromWorking )+import qualified Darcs.Repository.Pristine as Pristine ( replacePristine,+                                                         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,+                              replacePristine, replacePristineFromSlurpy,+                              slurp_all_but_darcs )+import qualified Darcs.Repository.DarcsRepo as DarcsRepo+import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,+                               MarkConflicts, AllowConflicts, NoUpdateWorking,+                               RepoDir, WorkDir, 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 Darcs.Progress ( progressFL, debugMessage )+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 (WorkDir 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 (WorkDir 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 (RepoDir d:_) | is_file d =+    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)+       findRepository []+findRepository (WorkDir 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_private (AnyOrder:) 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.+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 case usi of+              NilFL -> applyps r themi+              _     -> applyps r (mapFL_FL n2pia pc)+             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 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 ->+             withTentative 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++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 () }++replacePristine :: Repository p C(r u t) -> FilePath -> IO ()+replacePristine (Repo r opts rf (DarcsRepository pris c)) d+    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristine c (compression opts) d+    | otherwise = withCurrentDirectory r $ Pristine.replacePristine d pris++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++checkPristineAgainstCwd :: RepoPatch p => Repository p C(r u t) -> IO Bool+checkPristineAgainstCwd (Repo dir _ rf (DarcsRepository p _))+    | not $ format_has HashedInventory rf = do here <- toPath `fmap` ioAbsoluteOrRemote "."+                                               withCurrentDirectory dir $ checkPristine here p+checkPristineAgainstCwd r =+    do s <- mmap_slurp "."+       checkPristineAgainstSlurpy r s++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+       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 ) )+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 the 'Quiet' flag is passed in+show_motd :: [DarcsFlag] -> String -> IO ()+show_motd opts repo = unless (Quiet `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,520 @@+%  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,+                   defaultrepo, set_defaultrepo,+                   get_prefval, set_prefval, change_prefval,+                   def_prefval,+                   write_default_prefs,+                   boring_file_filter, darcsdir_filter,+                   FileType(..), filetype_function,+                   getCaches,+                 ) 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 ( isNothing, isJust, catMaybes )+import Data.List ( nub, isPrefixOf )+import System.Directory ( getAppUserDataDirectory, doesDirectoryExist )+import System.Environment( getEnv )+import System.FilePath ( (</>) )++import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, Ephemeral, RemoteRepo ) )+import Darcs.RepoPath ( AbsolutePath, ioAbsolute, makeRelative, 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!, 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++global_prefs_dir :: IO (Maybe FilePath)+global_prefs_dir = do+  dir <- (</> ".darcs") `fmap` getEnv "DARCS_TESTING_HOME"+  exists <- doesDirectoryExist dir+  if exists then return $ Just dir+            else userDir+ `catch` \_ -> userDir -- no such environment variable+ where userDir = (getAppUserDataDirectory "darcs" >>= return.Just)+                   `catchall` (return Nothing)++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_file_filter :: IO ([FilePath] -> [FilePath])+boring_file_filter = do+    borefile <- def_prefval "boringfile" (darcsdir ++ "/prefs/boring")+    bores <- get_lines borefile `catchall` return []+    gbs <- get_global "boring"+    return $ actual_boring_file_filter $ map mkRegex (bores++gbs)++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++actual_boring_file_filter :: [Regex] -> [FilePath] -> [FilePath]+actual_boring_file_filter regexps fs =+    filter (abf (not.is_darcsdir) regexps . normalize) fs+    where+    abf fi (r:rs) = abf (\f -> fi f && isNothing (matchRegex r f)) rs+    abf fi [] = fi+\end{code}++\begin{code}+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.++\begin{code}+data FileType = BinaryFile | TextFile+                deriving (Eq)++{-# NOINLINE default_binaries #-}+default_binaries :: [String]+default_binaries =+    "# Binary file regexps:" :+    ext_regexes ["png","gz","pdf","jpg","jpeg","gif","tif",+                 "tiff","pnm","pbm","pgm","ppm","bmp","mng",+                 "tar","bz2","z","zip","jar","so","a",+                 "tgz","mpg","mpeg","iso","exe","doc",+                 "elc", "pyc"]+    where ext_regexes exts = concat $ map ext_regex exts+          ext_regex e = ["\\."++e++"$", "\\."++map toUpper e++"$"]++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+\end{code}++\begin{code}+-- 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 $ add_to_list 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 ()++add_to_list :: Eq a => a -> [a] -> [a]+add_to_list s [] = [s]+add_to_list s (s':ss) = if s == s' then (s:ss) else s': add_to_list s ss+\end{code}++\begin{code}+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]+\end{code}++\begin{code}+defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+defaultrepo opts orig [] =+  do let fixR r | not (is_file r) = return r+                | otherwise = do absr <- ioAbsolute r+                                 return $ toFilePath $ makeRelative orig 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.++\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,217 @@+-- 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,+                 checkPristine, slurpPristine,+                 applyPristine, createPristineFromWorking,+                 syncPristine, replacePristine, 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 ( cmp, 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++checkPristine :: FilePath -> Pristine -> IO Bool+checkPristine _ (NoPristine _) = return True+checkPristine path (PlainPristine n) = do cwd <- getCurrentDirectory+                                          cmp (cwd ++ "/" ++ n) path+checkPristine _ HashedPristine = +    bug "HashedPristine is not implemented yet."++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!++replacePristine :: FilePath -> Pristine -> IO ()+replacePristine _ (NoPristine _) = return ()+replacePristine newcur (PlainPristine n) =+    do rm_recursive nold+           `catchall` return ()+       renameDirectory n nold+       renameDirectory newcur n+       return ()+           where nold = darcsdir ++ "/" ++ pristineName ++ "-old"+replacePristine _ HashedPristine =+    bug "HashedPristine is not implemented yet."++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,151 @@+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 ( 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 Darcs.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 ) )++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'++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+       ps <- aaf s_ psin+       endTedious k+       return ps+    where k = "Replaying patch"+          aaf s NilFL = return (NilFL, s, True)+          aaf s (p:>:ps) = do+            (s', mp') <- run_slurpy s $ applyAndTryToFix p+            finishedOneIO k $ show $ human_friendly $ info p+            (p', ourok) <- case mp' of+                    Nothing -> return (p, True)+                    Just (e,pp) -> do putStrLn e+                                      return (pp, False)+            p'' <- makePatchLazy r p'+            s'' <- syncSlurpy (update_slurpy r c opts) s'+            (ps', s''', restok) <- aaf s'' ps+            return ((p'':>:ps'), s''', restok && ourok)++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 agains 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,246 @@+%  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.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 Darcs.Flags ( DarcsFlag(LookForAdds) )+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 )+\end{code}++\begin{code}+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})+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 [LookForAdds] 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..."+    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++(///) :: FilePath -> FilePath -> FilePath+d /// f = d ++ "/" ++ f+\end{code}++\begin{code}+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,178 @@+-- 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 )+import Darcs.Commands.Help ( command_control_list )+import Darcs.External ( viewDoc )+import Darcs.Global ( setDebugMode, setSshControlMasterDisabled,+                      setTimingsMode, setVerboseMode )+import Darcs.Match ( checkMatchSyntax )+import Darcs.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+               -- 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,632 @@+-- 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 -fffi -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 )+import Data.Char ( toUpper )+import Control.Monad ( when )+import System.Exit ( exitWith, ExitCode(ExitSuccess) )++import English ( Noun(..), englishNum  )+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, 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.SlurpDirectory ( Slurpy )+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, without_buffering )+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+     -> Slurpy              -- directory+     -> 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+     -> Slurpy              -- directory+     -> [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 s = wasc_ mwch crit j o s []+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 s fs =+    with_any_selected_changes_last+        (patches_to_consider_last' fs opts crit)+        crit jn opts s fs+with_any_selected_changes First crit jn opts s fs =+    with_any_selected_changes_first+       (patches_to_consider_first' fs opts crit)+       crit jn opts s fs+with_any_selected_changes FirstReversed crit jn opts s fs =+    with_any_selected_changes_first_reversed+       (patches_to_consider_first_reversed' fs opts crit)+       crit jn opts s fs+with_any_selected_changes LastReversed crit jn opts s fs =+    with_any_selected_changes_last_reversed+        (patches_to_consider_last_reversed' fs opts crit)+        crit jn opts s fs+++view_changes :: RepoPatch p => [DarcsFlag] -> Slurpy -> [FilePath] -> FL (PatchInfoAnd p) C(x y) -> IO ()+view_changes opts _ fp ps =+  case patches_to_consider_nothing' fp opts iswanted ps of+  ps_to_consider :> _ -> vc ps_to_consider+ where+       vc :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> IO ()+       vc p = without_buffering $ do text_view opts ps_len 0 NilRL init_tps init_pc+                                     return ()+        where (init_pc, init_tps) = patch_choices_tps p+              ps_len = lengthFL init_tps++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 <- without_buffering $ 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 <- without_buffering $+                       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 <- without_buffering $+                       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 <- without_buffering $+                       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 <- without_buffering $+                       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++patches_to_consider_nothing' :: RepoPatch p+                     => [FilePath]  -- ^ files+                     -> [DarcsFlag] -- ^ opts+                     -> MatchCriterion (PatchInfoAnd p)+                     -> FL (PatchInfoAnd p) C(x y) -- ^ patches+                     -> (FL (PatchInfoAnd p) :> FL (PatchInfoAnd p)) C(x y)+patches_to_consider_nothing' 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++-- | 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") ]+        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+            '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] -> 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 = 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 = 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" ]+        options = [ options_yn ]+                  ++ [ options_view +++                       if Summary `elem` opts then [] else options_summary ]+                  ++ [ options_nav ]+        prompt = "Shall I view this patch? "+               ++ "(" ++ show (n+1) ++ "/" ++ 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+                       n_max n tps_done tps_todo pc+            _   -> do putStrLn $ helpFor "view changes" options+                      repeat_this+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 #-}+{-# 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,680 @@+-- 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 do+                          s' <- put s+                          return s'+                       else do+                          return s
+ src/Darcs/Test.lhs view
@@ -0,0 +1,125 @@+%  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 ( run_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}+run_test :: [DarcsFlag] -> AbsolutePath -> IO ExitCode+run_test opts testdir = do test <- get_test opts+                           withCurrentDirectory testdir test++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+\end{code}++\begin{code}+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,96 @@+-- 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 )+import Darcs.Commands.Init ( initialize )+import Darcs.Commands.Show ( show_command, list, query )+import Darcs.Commands.MarkConflicts ( markconflicts, resolve )+import Darcs.Commands.Mv ( mv, move )+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 mv, Hidden_command move,+                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,+                Command_data put,+                Group_name "Administrating repositories:",+                Command_data initialize,+                Command_data optimize,+                Command_data check,+                Command_data repair,+                Command_data convert]
+ src/Darcs/URL.hs view
@@ -0,0 +1,80 @@+{-# 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 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,316 @@+-- Various utility functions that do not belong anywhere else.++{-# OPTIONS_GHC -cpp -fffi #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Utils ( catchall, ortryrunning, nubsort, breakCommand,+                     clarify_errors, prettyException,+                    putStrLnError, putDocLnError,+                    withCurrentDirectory,+                    withUMask, askUser, stripCr,+                    showHexLen, add_to_error_loc,+                    maybeGetEnv, firstNotBlank, firstJustM, firstJustIO,+                    isUnsupportedOperationError, isHardwareFaultError,+                    get_viewer, edit_file, promptYorn, promptCharFancy, without_buffering,+                    formatPath ) where++import Prelude hiding ( catch )+import Control.Exception ( bracket, bracket_, catch, Exception(IOException), throwIO, try, throw, ioErrors )+import Control.Concurrent ( newEmptyMVar, takeMVar, putMVar, forkIO )+#if !defined(WIN32) ||  __GLASGOW_HASKELL__>=609+import Control.Concurrent ( threadWaitRead )+#endif+import GHC.IOBase ( IOException(ioe_location),+                    IOErrorType(UnsupportedOperation, HardwareFault) )+import System.IO.Error ( isUserError, ioeGetErrorType, ioeGetErrorString,+                         isEOFError )++import Darcs.SignalHandler ( catchNonSignal )+import Numeric ( showHex )+import System.Exit ( ExitCode(..) )+import System.Environment ( getEnv )+import System.IO ( hFlush, hPutStrLn, stderr, stdout, stdin,+                   BufferMode ( NoBuffering ),+                   hLookAhead, hReady, hSetBuffering, hGetBuffering, hIsTerminalDevice )+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 Darcs.Progress ( withoutProgress )++#ifdef HAVE_HASKELINE+import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine )+#endif++#ifdef WIN32+import System.Posix.Internals ( getEcho, setCooked, setEcho )+#endif++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++ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode+a `ortryrunning` b = do ret <- try a+                        case ret of+                          (Right ExitSuccess) -> return ExitSuccess+                          _ -> b++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++-- withThread is used to allow ctrl-C to work even while we're waiting for+-- user input.  The job is run in a separate thread, and any exceptions it+-- produces are re-thrown in the parent thread.+withThread :: IO a -> IO a+withThread j = do m <- newEmptyMVar+                  forkIO (runJob m)+                  takeMVar m >>= either throwIO return+    where runJob m = (j >>= putMVar m . Right) `catch` (putMVar m . Left)++askUser :: String -> IO String+#ifdef HAVE_HASKELINE+askUser prompt = withoutProgress $ runInputT defaultSettings (getInputLine prompt)+                        >>= maybe (error "askUser: unexpected end of input") return+                                      +#else+askUser prompt = withThread $ withoutProgress $ do putStr prompt+                                                   hFlush stdout+                                                   waitForStdin+#ifndef WIN32+                                                   getLine+#else+                                                   stripCr `fmap` getLine+#endif+#endif++waitForStdin :: IO ()+#ifdef WIN32+#if __GLASGOW_HASKELL__ >= 609+waitForStdin = threadWaitRead 0+#else+waitForStdin = return ()  -- threadWaitRead didn't work prior to 6.9+#endif+#else+waitForStdin = threadWaitRead 0+#endif++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+  let f = toFilePath ff+  ed <- get_editor+  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+get_editor :: IO String+get_editor = getEnv "DARCS_EDITOR" `catchall`+             getEnv "DARCSEDITOR" `catchall`+             getEnv "VISUAL" `catchall`+             getEnv "EDITOR" `catchall` return "vi"++get_viewer :: IO String+get_viewer = getEnv "DARCS_PAGER" `catchall`+             getEnv "PAGER" `catchall` return "less"++promptYorn :: [Char] -> IO Char+promptYorn p = promptCharFancy p "yn" Nothing []++promptCharFancy :: String -> [Char] -> Maybe Char -> [Char] -> IO Char+promptCharFancy p chs md help_chs =+ do a <- withThread $ without_buffering $+           do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr+              hFlush stdout+              waitForStdin+              c <- getChar+#ifdef WIN32+              -- We need to simulate echo+              e <- get_raw_mode+              when e $ putChar c+#endif+              return c+    when (a /= '\n') $ putStr "\n" +    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+ where + helpStr = case help_chs of+           []    -> ""+           (h:_) -> ", or " ++ (h:" for help: ")+ tryAgain = do putStrLn "Invalid response, try again!"+               promptCharFancy p chs md help_chs+ setDefault s = case md of Nothing -> s+                           Just d  -> map (setUpper d) s+ setUpper d c = if d == c then toUpper c else c++without_buffering :: IO a -> IO a+without_buffering job = withoutProgress $ do+    bracket nobuf rebuf $ \_ -> job+    where nobuf = do is_term <- hIsTerminalDevice stdin+                     bi <- hGetBuffering stdin+                     raw <- get_raw_mode+                     when is_term $ do hSetBuffering stdin NoBuffering `catch` \_ -> return ()+                                       set_raw_mode True+                     return (bi,raw)+          rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin+#if SYS == windows+                              buffers <- hGetBuffering stdin+                              hSetBuffering stdin NoBuffering `catch` \_ -> return ()+                              drop_returns+                              hSetBuffering stdin buffers `catch` \_ -> return ()+#else+                              drop_returns+#endif+                              when is_term $ do hSetBuffering stdin bi `catch` \_ -> return ()+                                                set_raw_mode raw+          drop_returns = do is_ready <- hReady stdin `catch` \ e ->+                                        case ioErrors e of+                                          Just x -> if isEOFError x+                                                      then return True+                                                      else throw e+                                          _ -> throw e+                            when is_ready $+                              do waitForStdin+                                 c <- hLookAhead stdin `catch` \_ -> return ' '+                                 when (c == '\n') $+                                   do getChar+                                      drop_returns++-- Code which was in the module RawMode before. Moved here to break cyclic imports+#ifdef WIN32++get_raw_mode :: IO Bool+get_raw_mode = not `fmap` getEcho 0+  `catchall` return False -- getEcho sometimes fails when called from scripts++set_raw_mode :: Bool -> IO ()+set_raw_mode raw = (setCooked 0 normal >> setEcho 0 normal)+   `catchall` return () -- setCooked sometimes fails when called from scripts+ where normal = not raw++#else++get_raw_mode :: IO Bool+get_raw_mode = return False++set_raw_mode :: Bool -> IO ()+set_raw_mode _ = return ()++#endif
+ 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,54 @@+-- 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.++module English where++import Data.List (isSuffixOf)++-- | > englishNum 0 (Noun "watch") "" == "watches"+--   > englishNum 1 (Noun "watch") "" == "watch"+--   > englishNum 2 (Noun "watch") "" == "watches"+englishNum :: Numbered n => Int -> n -> ShowS+englishNum x = if x == 1 then singular else plural++-- | Things that have a plural and singular spelling+class Numbered 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 Numbered 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 Numbered This where+  plural (This s)   = showString "these "  . plural s+  singular (This s) = showString "this "   . singular s
+ src/Exec.hs view
@@ -0,0 +1,181 @@+-- 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 -fffi -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) )+-- WARNING: isInfixOf is not present in ghc 6.4.2!+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 Darcs.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 or libwww)!"+                   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 or libwww)!"+                   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,808 @@+-- 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 )++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 && and (map isDigit $ take 14 d)+              then Right $ toMCalendarTime $+                   CalendarTime (read $ take 4 d)+                                (toEnum $ (+ (-1)) $ read $ take 2 $ drop 4 d)+                                (read $ take 2 $ drop 6 d) -- Day+                                (read $ take 2 $ drop 8 d) -- Hour+                                (read $ take 2 $ drop 10 d) -- Minute+                                (read $ take 2 $ drop 12 d) -- 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++-- | 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+--+--   * Some American timezones: EST, EDT, CST, CDT, MST, MDT, PST, PDT+--+--   * Some European timezones: UT, GMT, CEST, EEST+--+--   * 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 "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'] }++----- 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,485 @@+-- 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)++#if __GLASGOW_HASKELL__ > 604+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+#else+aLen :: HasBounds a => a Int e -> Int+aLen a = snd $ bounds a+aLenM :: (HasBounds a, Monad m) => a Int e -> m Int+aLenM = return . snd . bounds+#endif++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,346 @@+-- 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 )++-- | 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 && and (map isDigit $ take 14 d)+              then Right $+                   CalendarTime (read $ take 4 d)+                                (toEnum $ (+ (-1)) $ read $ take 2 $ drop 4 d)+                                (read $ take 2 $ drop 6 d) -- Day+                                (read $ take 2 $ drop 8 d) -- Hour+                                (read $ take 2 $ drop 10 d) -- Minute+                                (read $ take 2 $ drop 12 d) -- 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++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,435 @@++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, 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 Control.Monad.Reader (Reader, runReader, ask, asks, local)+import Data.List (intersperse)+import System.IO (Handle, stdout, hPutStr)+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 :: Reader 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 :: !DocumentInternals }+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 :: !DocumentInternals+                          }+type Printer = Printable -> Reader St Document++data Color = Blue | Red | Green | Cyan | Magenta++-- | 'DocumentInternals' represents a 'Printable' by the function+-- which concatenates another 'Printable' to its right.+type DocumentInternals = [Printable] -> [Printable]++-- | 'Document' is a wrapper around 'DocumentInternals' which allows+-- for empty Documents. The simplest 'Documents' are built from 'String's+-- using 'text'.+data Document = Document DocumentInternals+              | 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 runReader 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 $ local (\st -> st { current_prefix = current_prefix st . (p:) })+                   (do d' <- d+                       case d' of+                           Document d'' -> return $ Document $ (p:) . d''+                           Empty -> return Empty)+    where p = S s++lineColor :: Color -> Doc -> Doc+lineColor c d =+    Doc $ do pr <- asks printers+             unDoc $ lineColorT pr c d++hiddenPrefix :: String -> Doc -> Doc+hiddenPrefix s (Doc d) =+    Doc $ do pr <- asks printers+             let p = S (renderStringWith pr $ hiddenText s)+             local (\st -> st { current_prefix = current_prefix st . (p:) })+                       (do d' <- d+                           case d' of+                             Document d'' -> return $ Document $ (p:) . d''+                             Empty -> return 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 . return++-- | '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 $ do st <- ask+                       defP (printers st) x+mkColorPrintable :: Color -> Printable -> Doc+mkColorPrintable c x = Doc $ do st <- ask+                                colorP (printers st) c x+invisiblePrintable x = Doc $ do st <- ask+                                invisibleP (printers st) x+hiddenPrintable x = Doc $ do st <- ask+                             hiddenP (printers st) x+userchunkPrintable x = Doc $ do st <- ask+                                userchunkP (printers st) x++-- | '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 seems to+-- just replace the document with 'empty'. I'm confused (Florent).+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 $ return Empty+doc :: ([Printable] -> [Printable]) -> Doc+doc f = Doc $ return $ 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 $ do ad <- a+            case ad of+                Empty -> b+                Document af ->+                    do bd <- b+                       return $ Document (\s -> af $ case bd of+                                                         Empty -> s+                                                         Document bf -> bf s)++-- empty if a empty, else a then b+Doc a <?> Doc b =+    Doc $ do ad <- a+             case ad of+                 Empty -> return Empty+                 Document af ->+                     do bd <- b+                        return $ Document (\s -> af $ case bd of+                                                          Empty -> s+                                                          Document bf -> bf s)++-- a then space then b+Doc a <+> Doc b =+    Doc $ do ad <- a+             case ad of+                 Empty -> b+                 Document af ->+                     do bd <- b+                        return $ Document (\s -> af $ case bd of+                                                          Empty -> s+                                                          Document bf ->+                                                              space_p:bf s)++-- a above b+Doc a $$ Doc b =+   Doc $ do ad <- a+            case ad of+                Empty -> b+                Document af ->+                    do bd <- b+                       st <- ask+                       let pf = current_prefix st+                           sf = lineColorS $ printers st+                       return $ Document (\s -> af+                                              $ case bd of+                                                    Empty -> s+                                                    Document bf ->+                                                        sf (newline_p:pf (bf s)))++-- | '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/RegChars.hs view
@@ -0,0 +1,52 @@+-- 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 :: String -> (Char -> Bool)+regChars ('^':cs) = not . normalRegChars (unescapeChars cs)+regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs+regChars cs = normalRegChars $ unescapeChars cs++{-# INLINE unescapeChars #-}+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 :: 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,204 @@+-- 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 #-}++-- {-# 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 Autoconf (big_endian)+import ByteStringUtils (unsafeWithInternals)+import qualified Data.ByteString as B (ByteString, pack, length, concat)++import Control.Monad (unless)+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+                       unless big_endian $ fiddle_endianness ptr' len+                       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,288 @@+{-# OPTIONS_GHC -cpp -fffi #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..) ) 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 Darcs.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]++-- | 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.in view
@@ -0,0 +1,8 @@+--+-- Version information created at compile time by make.+--+module ThisVersion ( darcs_version ) where++{-# NOINLINE darcs_version #-}+darcs_version :: String+darcs_version = "@DARCS_VERSION@ (@DARCS_VERSION_STATE@)"
+ src/URL.hs view
@@ -0,0 +1,352 @@+{-# OPTIONS_GHC -cpp -fffi #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault,+             setDebugHTTP, setHTTPPipelining, waitUrl,+             Cachable(Cachable, Uncachable, MaxAge)+           ) 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 Darcs.Progress ( debugFail, debugMessage )+import Darcs.Lock ( removeFileMayNotExist )++#if defined(HAVE_CURL) || defined(HAVE_LIBWWW)+import Foreign.C.String ( withCString, peekCString, CString )+#elif defined(HAVE_HTTP)+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 }++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(HAVE_LIBWWW) || defined(CURL_PIPELINING_DEFAULT)+pipeliningLimit :: Int+pipeliningLimit = 100+#endif++pipeliningEnabledByDefault :: Bool+#if defined(HAVE_LIBWWW) || defined(CURL_PIPELINING_DEFAULT)+pipeliningEnabledByDefault = True+#else+pipeliningEnabledByDefault = False+#endif++{-# NOINLINE maxPipeLength #-}+maxPipeLength :: IORef Int+maxPipeLength = unsafePerformIO $ newIORef $+#if defined(HAVE_LIBWWW) || defined(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 = evalStateT urlThread' (UrlState Map.empty emptyQ 0)+    where 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, _) -> do+            put $ st { waitToStart = rest+                     , pipeLength = l + 1 }+            dbg ("URL.request_url ("++u++"\n"+++                 "              -> "++f++")")+            let f_new = f++"-new"+            liftIO $ do err <- request_url u f_new c+                        if null err+                           then do atexit $ removeFileMayNotExist f_new+                                   debugMessage "URL.request_url succeeded"+                           else do removeFileMayNotExist f_new+                                   debugMessage $ "Failed to start download URL "++u++": "++err+          _              -> 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") f+                                  mapM_ (safeCopyFile 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")+                                  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 f t = let new_t = t++"-new"+                             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++#if defined(HAVE_CURL) || defined(HAVE_LIBWWW)+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+#if defined(HAVE_LIBWWW) || defined(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)++#if defined(HAVE_LIBWWW)++setDebugHTTP = libwww_enable_debug++request_url u f cache =+    withCString u $ \ustr ->+    withCString f $ \fstr -> do+      err <- libwww_request_url ustr fstr (cachableToInt cache) >>= peekCString+      return err++wait_next_url = do+  e <- libwww_wait_next_url >>= peekCString+  u <- libwww_last_url >>= peekCString+  return (u, e)++foreign import ccall "hslibwww.h libwww_request_url"+  libwww_request_url :: CString -> CString -> CInt -> IO CString++foreign import ccall "hslibwww.h libwww_wait_next_url"+  libwww_wait_next_url :: IO CString++foreign import ccall "hslibwww.h libwww_last_url"+  libwww_last_url :: IO CString++foreign import ccall "hslibwww.h libwww_enable_debug"+  libwww_enable_debug :: IO ()++#elif defined(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 curl and libwww"+request_url _ _ _ = debugFail "URL.request_url: there is no curl or libwww!"+wait_next_url = debugFail "URL.wait_next_url: there is no curl or libwww!"++#endif
+ src/UTF8.lhs view
@@ -0,0 +1,148 @@+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>+++> module UTF8+>   ( encode ) where++> import Data.Char (ord)+> import Data.Word (Word8, Word16, Word32)+> import Data.Bits (Bits, shiftR, (.&.), (.|.))++++///- 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.++> 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+++With the above, a stream decoder is trivial:++> encode :: [Char] -> [Word8]+> encode = concatMap encodeOne+++Now follow the individual encoders for certain numbers of bytes...+          _+         / |  __  ___  __ __+        / ^| //  /__/ // //+       /.==| \\ //_  // //+It's  //  || // \_/_//_//_  and it's here to stay!++> encodeOne_onebyte :: Word8 -> [Word8]+> encodeOne_onebyte cp = [cp]+++00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx++> encodeOne_twobyte :: Word16 -> [Word8]+> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]+>     where+>     xs, ys :: Word8+>     ys = fromIntegral (shiftR cp 6)+>     xs = (fromIntegral cp) .&. 0x3F+++zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx++> 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)+++000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++> 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)
+ src/Workaround.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}++module Workaround ( renameFile, setExecutable, getCurrentDirectory,+                    installHandler, raiseSignal, Handler(..), Signal,+                    sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) where++#ifdef HAVE_SIGNALS+import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,+                         sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE,)+#endif++#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.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++#ifndef HAVE_SIGNALS+-- 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+#endif++#ifdef WIN32+{-+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,613 @@+% This file (unlike the rest of darcs) is in the public domain.+ ++\chapter{Best practices}++\section{Introduction}++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}++In Windows, using \verb|cmd.exe| (Command Prompt under Accessories):++\begin{verbatim}+> md %UserProfile%\.darcs\cache+> 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,160 @@+\chapter{Building darcs}++This chapter should walk you through the steps necessary to build darcs for+yourself.  There are in general two ways to build darcs.  One is for+building released versions from tarballs, and the other is to build the+latest and greatest darcs, from the darcs repo itself.++Please let me know if you have any problems building darcs, or don't have+problems described in this chapter and think there's something obsolete+here, so I can keep this page up-to-date.++\section{Prerequisites}+To build darcs you will need to have {\tt ghc}, the Glorious Glasgow+Haskell Compiler. You should have at the very minimum version 6.4.++It is a good idea (but not required) to have software installed that provide darcs+network access. The {\tt libwww-dev}, {\tt libwww-ssl-dev} or {\tt libcurl} packages+newer than than 7.18.0 are recommended because they provide pipelining support speed+up HTTP access. They have to be explicitly chosen with {\tt --with-libwww} or+{\tt --with-curl-pipelining}. Otherwise, darcs will automatically look for one of+libcurl, {\tt curl} or {\tt wget}.  You also might want to have scp+available if you want to grab your repos over ssh\ldots++To use the \verb!diff! command of darcs, a \verb!diff! program supporting+options \verb!-r! (recursive diff) and \verb!-N! (show new files as+differences against an empty file) is required. The \verb!configure!+script will look for \verb!gdiff!, \verb!gnudiff! and \verb!diff! in this+order. You can force the use of another program by setting the \verb!DIFF!+environment variable before running \verb!configure!.++To rebuild the documentation (which should not be necessary since it is+included in html form with the tarballs), you will need to have latex+installed, as well as latex2html if you want to build it in html form.+++\section{Building on Mac~OS~X}+To build on Mac~OS~X, you will need the Apple Developer Tools and the ghc+6.4 package installed.++\section{Building on Microsoft Windows}+To build on Microsoft Windows, you will need:++\begin{itemize}+\item \htmladdnormallinkfoot{MinGW}{http://www.mingw.org/} which provides the GCC+  toolchain for win32.+\item \htmladdnormallinkfoot{MSYS}{http://www.mingw.org/msys.shtml} which provides+  a unix build environment for win32.  Be sure to download the separate+  msysDTK, autoconf and automake.+\item \htmladdnormallinkfoot{zlib-1.2.1+}{http://www.gzip.org/zlib/} library+  and headers.+\item \htmladdnormallinkfoot{curl-7.12.2+}{http://curl.haxx.se/} library+  and headers.+\item If building with an SSL enabled curl you will need the OpenSSL+  libraries, unofficial builds are available at\\+  \htmladdnormallink{http://www.slproweb.com/products/Win32OpenSSL.html}{http://www.slproweb.com/products/Win32OpenSSL.html}.+\end{itemize}++Copy the zlib and curl libraries and headers to both GHC and MinGW.  GHC+stores C headers in \verb!<ghc-dir>/gcc-lib/include! and libraries in+\verb!<ghc-dir>/gcc-lib!.  MinGW stores headers in+\verb!<mingw-dir>/include! and libraries in \verb!<mingw-dir>/lib!.++Set PATH to include the \verb!<msys-dir>/bin!, \verb!<mingw-dir>/bin!,+\verb!<curl-dir>!, and a directory containing a pre-built darcs.exe if you+want the build's patch context stored for `\verb!darcs --exact-version!'.++\begin{verbatim}+C:\darcs> cd <darcs-source-dir>+C:\darcs> sh++$ export GHC=/c/<ghc-dir>/bin/ghc.exe+$ autoconf+$ ./configure --target=mingw+$ make+\end{verbatim}++\section{Building from tarball}+If you get darcs from a tarball, the procedure (after unpacking the tarball+itself) is as follows:+\begin{verbatim}+% ./configure+% make+# Optional, but recommended+% make test+% make install+\end{verbatim}++There are options to configure that you may want to check out with+\begin{verbatim}+% ./configure --help+\end{verbatim}++If your header files are installed in a non-standard location, you may need+to define the \verb!CFLAGS! and \verb!CPPFLAGS! environment variables to+include the path to the headers.  e.g. on NetBSD, you may need to run+\begin{verbatim}+% CFLAGS=-I/usr/pkg/include CPPFLAGS=-I/usr/pkg/include ./configure+\end{verbatim}++\section{Building darcs from the repository}+To build the latest darcs from its repository, you will first need a+working copy of Darcs 2. You can get darcs using:+\begin{verbatim}+% darcs get -v http://darcs.net/+\end{verbatim}+and once you have the darcs repository you can bring it up to date with a+\begin{verbatim}+% darcs pull+\end{verbatim}++The repository doesn't hold automatically generated files, which include+the configure script and the HTML documentation, so you need to run+\verb!autoconf! first.++You'll need \verb!autoconf! 2.50 or higher. Some systems have more than one+version of \verb!autoconf! installed. For example, \verb!autoconf! may point to+version 2.13, while \verb!autoconf259!  runs version 2.59.++Also note that \verb!make! is really "GNU make". On some systems, such as+the *BSDs, you may need to type \verb!gmake! instead of make for this to work.++If you want to create readable documentation you'll need to have latex installed.+\begin{verbatim}+% autoconf+% ./configure+% make+% make install+\end{verbatim}++If you want to tweak the configure options, you'll need to run {\tt+  ./configure} yourself after the make, and then run make again.++\section{Submitting patches to darcs}+I know, this doesn't really belong in this chapter, but if you're using the+repository version of darcs it's really easy to submit patches to me using+darcs. In fact, even if you don't know any Haskell, you could submit fixes+or additions to this document (by editing \verb!building_darcs.tex!) based+on your experience building darcs\ldots++To do so, just record your changes (which you made in the darcs repository)+\begin{verbatim}+% darcs record --no-test+\end{verbatim}+making sure to give the patch a nice descriptive name.  The+\verb!--no-test! options keeps darcs from trying to run the unit tests,+which can be rather time-consuming.  Then you can send the patch to the+darcs-devel mailing list by email by+\begin{verbatim}+% darcs send+\end{verbatim}+If you are using darcs 2.0.0 or earlier, please use+\begin{verbatim}+% darcs send -u+\end{verbatim}+instead.+The darcs repository stores the email address to which patches should be+sent by default.  The email address you see is actually my own, but when+darcs notices that you haven't signed the patch with my GPG key, it will+forward the message to darcs-devel.+
+ 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,304 @@+%  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 (or on Microsoft Windows, the+C:/Documents And Settings/user/Application Data/darcs directory).+Finally, the behavior of some darcs commands can be modified by setting+appropriate environment variables.++\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\_WGET & \ref{env:DARCS_WGET} \\+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}++\paragraph{DARCS\_EDITOR}+\label{env:DARCS_EDITOR}+When pulling up an editor (for example, when adding a long comment in+record), darcs uses the contents of DARCS\_EDITOR if it is defined.  If+not, it tries the contents of VISUAL, and if that isn't defined (or fails+for some reason), it tries EDITOR\@.  If none of those environment variables+are defined, darcs tries \verb!vi!, \verb!emacs!, \verb!emacs -nw! and+\verb!nano! in that order.++\paragraph{DARCS\_PAGER}+\label{env:DARCS_PAGER}+When using a pager for displaying a patch, darcs uses the contents of+DARCS\_PAGER if it is defined.  If not, it tries the contents of PAGER+and then \verb!less!.++\paragraph{DARCS\_TMPDIR}+\label{env:DARCS_TMPDIR}+If the environment variable DARCS\_TMPDIR is defined, darcs will use that+directory for its temporaries.  Otherwise it will use TMPDIR, if that is+defined, and if not that then \verb!/tmp! and if \verb!/tmp! doesn't exist,+it'll put the temporaries in \verb!_darcs!.++This is very helpful, for example, when recording with a test suite that+uses MPI, in which case using \verb!/tmp! to hold the test copy is no good,+as \verb!/tmp! isn't shared over NFS and thus the \verb!mpirun! call will+fail, since the binary isn't present on the compute nodes.++\paragraph{DARCS\_KEEP\_TMPDIR}+\label{env:DARCS_KEEP_TMPDIR}+If the environment variable DARCS\_KEEP\_TMPDIR is defined, darcs will+not remove temprary directories.++This can be useful for darcs debugging.++\paragraph{HOME}+\label{env:HOME}+HOME is used to find the per-user prefs directory, which is located at+\verb!$HOME/.darcs!.++%$ this dollar is a comment to make my emacs leave math mode... (stupid+%  emacs)++\paragraph{TERM}+\label{env:TERM}+If darcs is compiled with libcurses support and support for color output,+it uses the environment variable TERM to decide whether or not color is+supported on the output terminal.++\section{Remote repositories}++\paragraph{SSH\_PORT}+\label{env:SSH_PORT}+When using ssh, if the SSH\_PORT environment variable is defined, darcs will+use that port rather than the default ssh port (which is 22).++\paragraph{DARCS\_SSH}+\label{env:DARCS_SSH}+The DARCS\_SSH environment variable defines the command that darcs will use+when asked to run ssh.  This command is \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.++\paragraph{DARCS\_SCP and DARCS\_SFTP}+\label{env:DARCS_SCP}+\label{env:DARCS_SFTP}+The DARCS\_SCP and DARCS\_SFTP environment variables define the+commands that darcs will use when asked to run scp or sftp.  Darcs uses+scp and sftp to access repositories whose address is of the+form \verb!user@foo.org:foo! or \verb!foo.org:foo!.  Darcs will use+scp to copy single files (e.g.\ repository meta-information), and sftp+to copy multiple files in batches (e.g.\ patches).  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.  By default, \verb!scp! and \verb!sftp!+are used.  When you can use sftp, but not scp (e.g.\ some ISP web sites), it+works to set DARCS\_SCP to `sftp'.  The other way around does not work, i.e.\ +DARCS\_FTP must reference an sftp program, not scp.++\paragraph{DARCS\_PROXYUSERPWD}+\label{env:DARCS_PROXYUSERPWD}+This environment variable allows DARCS and libcurl to access remote repositories+via a password-protected HTTP proxy. The proxy itself is specified with the standard+environment variable for this purpose, namely 'http\_proxy'. The DARCS\_PROXYUSERPWD+environment variable specifies the proxy username and password. It must be given in +the form \emph{username:password}.++\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}++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.++\paragraph{DARCS\_WGET}+\label{env:DARCS_WGET}+This is a very old option that is only used if libcurl is not compiled+in and one of the DARCS\_GET\_FOO is not used. Using one of those+is recommended instead.++The DARCS\_WGET environment variable defines the command that darcs+will use to fetch all URLs for remote repositories.  The first word in+the command must be the name of an executable located in your path.+Extra arguments can be included as well, such as:++\begin{verbatim}+wget -q +\end{verbatim}++Darcs will append \verb!-i! to the argument list, which it uses to provide a+list of URLS to download. This allows wget to download multiple patches at the+same time. It's possible to use another command besides \verb!wget! with this+environment variable, but it must support the \verb!-i! option in the same way. ++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. 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,75 @@+-- 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.Monad ( when )+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 Autoconf( 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;+  when (length argv < 1) $+       do print_version+          help_cmd [] []+  when (length argv == 1 && (argv!!0 == "-h" || argv!!0 == "--help")) $+       help_cmd [] []+  when (length argv == 1 && (argv!!0 == "--overview")) $+       help_cmd [Verbose] []+  when (length argv == 1 && (argv!!0 == "-v" || argv!!0 == "--version")) $+       do putStrLn darcs_version+          exitWith $ ExitSuccess+  when (length argv == 1 && (argv!!0 == "--exact-version")) $+       do putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__+          putStrLn context+          exitWith $ ExitSuccess+  when (length argv == 1 && argv!!0 == "--commands") $+       do list_available_commands+          exitWith $ ExitSuccess+  hSetBinaryMode stdin True+  hSetBinaryMode stdout True+  run_the_command (head argv) (tail argv)
+ src/darcsman.hs view
@@ -0,0 +1,97 @@+-- 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; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++module Main (main) where++import Darcs.Commands+import Darcs.TheCommands+import Time++main :: IO ()+main = man (extract_commands command_control_list)++man :: [DarcsCommand] -> IO ()+man cs = do man_header+            unorganized <- man_organizer cs+            putStrLn ".SH OTHER COMMANDS"+            man_helper unorganized+            man_trailer++man_organizer :: [DarcsCommand] -> IO [DarcsCommand]+man_organizer commands = mo commands+                         [("CREATING REPOSITORIES",+                           ["initialize","get"]),+                          ("MODIFYING REPOSITORY CONTENTS",+                           ["add","remove","mv","replace"]),+                          ("WORKING WITH CHANGES",+                           ["record","pull","push","send","apply"]),+                          ("SEEING WHAT YOU'VE DONE",+                           ["whatsnew","query"])+                         ]+    where mo :: [DarcsCommand] -> [(String,[String])] -> IO [DarcsCommand]+          mo cs [] = return cs+          mo cs ((t,a):xs) =+              do putStrLn $ ".SH " ++ t+                 man_helper $ filter ((`elem` a) . command_name) cs+                 mo (filter (not . (`elem` a) . command_name) cs) xs++man_helper :: [DarcsCommand] -> IO ()+man_helper cmds =+  helper' "" cmds+  where helper' _ [] = return ()+        helper' s (c@DarcsCommand { }:cs) = do+            putStrLn $ ".TP"+            putStrLn $ ".B "++ s ++ " "  ++ command_name c+            putStrLn $ command_help c+            helper' s cs+        helper' s (c@SuperCommand { }:cs) = do+            helper' (command_name c ++ " " ++ s)+                      (extract_commands (command_sub_commands c))+            helper' s cs++man_trailer :: IO ()+man_trailer = do putStrLn ""+                 putStrLn ".SH BUGS"+                 putStrLn "Report bugs by mail to"+                 putStrLn ".B bugs@darcs.net"+                 putStrLn "or via the web site at"+                 putStrLn ".BR http://bugs.darcs.net/ ."+                 putStrLn ""+                 putStrLn ".SH AUTHOR"+                 putStrLn "David Roundy <droundy@abridgegame.org>."++man_header :: IO ()+man_header = do+  putStr ".TH DARCS \"1\" \""+  cl <- getClockTime+  ct <- toCalendarTime cl+  putStr $ show (ctMonth ct) ++ " " ++ show (ctYear ct)+  putStr "\" \"darcs\" \"User Commands\"\n"+  putStr $+   ".SH NAME\n"+++   "darcs \\- an advanced revision control system\n"+++   ".SH SYNOPSIS\n"+++   ".B darcs\n"+++   "\\fICOMMAND \\fR...\n"+++   ".SH DESCRIPTION\n"+++   "\n"+++   "darcs is a nifty revision control tool.  For more a detailed description,\n"+++   "see the html documentation, which should be available at\n"+++   "/usr/share/doc/darcs/manual/index.html.  To easily get more specific help\n"+++   "on each command, you can call `darcs COMMAND --help'.\n"+++   "\n"++
+ 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,215 @@+/*+ * 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));++}++// mmapping...++#ifdef _WIN32++/* I have no idea if this works or not, and it is very tied to the usage+ * of mmap in FastPackedString. Most arguments are ignored...+ */++char *my_mmap(size_t length, int fd)+{+  exit(1); /* mmap is not implemented on Windows */+}++int munmap(void *start, size_t length)+{+    UnmapViewOfFile(start);+}++#else++char *my_mmap(size_t len, int fd) {+  void *maybeok = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, 0);+  if (maybeok == MAP_FAILED) return NULL;+  else return (char *)maybeok;+}++#endif++// 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,18 @@+#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);++char *my_mmap(size_t len, int fd);++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/hslibwww.c view
@@ -0,0 +1,184 @@+#ifdef HAVE_LIBWWW++#include "hslibwww.h"++#include <stdio.h>+#include <string.h>++static const char darcs_version[] = PACKAGE_VERSION;++#include <WWWLib.h>+#include <WWWInit.h>++enum RESULT_CODES+  {+    RESULT_OK = 0,+    RESULT_REQUEST_NEW_FAIL,+    RESULT_NET_ADD_AFTER_FAIL,+    RESULT_REQUEST_ADD_CACHE_CONTROL_FAIL,+    RESULT_LOAD_TO_FILE_FAIL,+    RESULT_MALLOC_FAIL,+    RESULT_LIST_NEW_FAIL,+    RESULT_LIST_APPEND_OBJECT_FAIL,+    RESULT_EVENTLIST_NEW_LOOP+  };++static const char *error_strings[] =+  {+    "",+    "HTRequest_new() failed",+    "HTNet_addAfter() failed",+    "HTRequest_addCacheControl() failed",+    "HTLoadToFile() failed",+    "malloc() failed",+    "HTList_new() failed",+    "HTList_appendObject() failed",+    "HTEventList_newLoop() failed"+  };++struct Completed+{+  int error;+  char *url;+};++static BOOL debug = NO;+static BOOL init_done = NO;+static int error;+static HTList *completed_list = NULL;+static char *last_url = NULL;+static char libwww_error[80];+static const char libwww_error_fmt[] = "libwww error code: %i";++int terminate_handler(HTRequest *request,+                      HTResponse *response,+                      void *param,+                      int status)+{+  struct Completed *completed = malloc(sizeof(struct Completed));+  if (completed == NULL)+    error = RESULT_MALLOC_FAIL;+  else+    {+      if (HTList_appendObject(completed_list, completed) == NO)+        {+          error = RESULT_LIST_APPEND_OBJECT_FAIL;+          free(completed);+        }+      else+        {+          error = RESULT_OK;+          completed->error = status;+          completed->url = HTRequest_context(request);+        }+    }++  HTRequest_delete(request);+  HTEventList_stopLoop();++  // Return not HT_OK to stop executing after filters.+  return HT_ERROR;+}++const char *libwww_request_url(const char *url,+                               const char *filename,+                               int cache_time)+{+  BOOL result;++  if (init_done == NO)+    {+      HTProfile_newNoCacheClient("darcs", darcs_version);+      HTProxy_getEnvVar();+      HTAlert_setInteractive(NO);+      HTFormat_addCoding("*", NULL, HTIdentityCoding, 1.0);+      if (debug == YES)+        HTSetTraceMessageMask("sop");+      init_done = YES;+    }++  if (completed_list == NULL)+    {+      completed_list = HTList_new();+      if (completed_list == NULL)+        return error_strings[RESULT_LIST_NEW_FAIL];+    }++  HTRequest *const request = HTRequest_new();+  if (request == NULL)+    return error_strings[RESULT_REQUEST_NEW_FAIL];++  HTRequest_setContext(request, strdup(url));++  result = HTNet_addAfter(terminate_handler, NULL, NULL, HT_ALL, HT_FILTER_LAST);+  if (result == NO)+    return error_strings[RESULT_NET_ADD_AFTER_FAIL];++  if (cache_time == 0)+    {+      HTRequest_addGnHd(request, HT_G_PRAGMA_NO_CACHE);+      result = HTRequest_addCacheControl(request, "no-cache", "");+    }+  else if (cache_time > 0)+    {+      char buf[8];+      snprintf(buf, sizeof(buf), "%d", cache_time);+      buf[sizeof(buf) - 1] = '\0';+      result = HTRequest_addCacheControl(request, "max-age", buf);+    }+  if (result == NO)+    return error_strings[RESULT_REQUEST_ADD_CACHE_CONTROL_FAIL];++  result = HTLoadToFile(url, request, filename);+  if (result == NO)+    return error_strings[RESULT_LOAD_TO_FILE_FAIL];++  return error_strings[RESULT_OK];+}++const char *libwww_wait_next_url()+{+  if (last_url != NULL)+    {+      free(last_url);+      last_url = NULL;+    }++  error = RESULT_OK;+  if (HTList_isEmpty(completed_list) == YES &&+      HTNet_isEmpty() == NO &&+      HTEventList_newLoop() != HT_OK)+    return error_strings[RESULT_EVENTLIST_NEW_LOOP];++  if (HTList_isEmpty(completed_list) == NO)+    {+      struct Completed *completed = HTList_firstObject(completed_list);+      if (completed->error == HT_LOADED)+        libwww_error[0] = '\0';+      else+        {+          snprintf(libwww_error, sizeof(libwww_error),+                   libwww_error_fmt, completed->error);+          libwww_error[sizeof(libwww_error) - 1] = '\0';+        }+      last_url = completed->url;+      HTList_removeFirstObject(completed_list);+      free(completed);++      return libwww_error;+    }++  return error_strings[error];+}++const char *libwww_last_url()+{+  return last_url != NULL ? last_url : "";+}++void libwww_enable_debug()+{+  debug = YES;+}++#endif
+ src/hslibwww.h view
@@ -0,0 +1,9 @@+const char *libwww_request_url(const char *url,+                               const char *filename,+                               int cache_time);++const char *libwww_wait_next_url();++const char *libwww_last_url();++void libwww_enable_debug();
+ src/impossible.h view
@@ -0,0 +1,9 @@+import qualified HTTP as HTTP_+import qualified Darcs.Bug as Bug_++#define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__))++#define bug        (darcsBug (Bug_._bug HTTP_.fetchUrl))+#define impossible (darcsBug (Bug_._impossible HTTP_.fetchUrl))+#define fromJust   (darcsBug (Bug_._fromJust HTTP_.fetchUrl))+#define bugDoc     (darcsBug (Bug_._bugDoc HTTP_.fetchUrl))
+ 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,134 @@+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 )+import Autoconf ( darcs_version )++the_commands :: [DarcsCommand]+the_commands = extract_commands command_control_list++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++am_html :: IO Bool+am_html = do args <- getArgs+             case args of+               [_,"--html"] -> return True+               _ -> return False++preproc :: [String] -> IO [String]+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 $ "\\newcommand{\\htmladdnormallink}[2]{#1}" :+                  "\\newcommand{\\htmladdnormallinkfoot}[2]{#1\\footnotetext{\\tt #2}}"+                  : rest+preproc ("\\begin{code}":ss) = ignore ss+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 (s:ss) = do+  rest <- preproc ss+  case matchRegex (mkRegex "^\\\\input\\{(.+)\\}$") s of+    Just (fn:_) -> do cs <- readFile $ "src" </> fn -- ratify readFile: not part of+                                        -- darcs executable+                      this <- preproc $ lines cs+                      return $ this ++ rest+    _ -> case matchRegex (mkRegex "^(.*)\\\\haskell\\{(.+)\\}(.*)$") s of+         Just (before:var:after:_) ->+             case breakLast '_' var of+             (cn,"help") -> return $ (before++gh cn++after):rest+             (cn,"description") -> return $ (before++gd cn++after):rest+             ("darcs","version") -> return $ (before++darcs_version++after):rest+             aack -> error $ show aack+         _ -> case matchRegex (mkRegex "^(.*)\\\\options\\{(.+)\\}(.*)$") s of+              Just (before:comm:after:_) ->+                  return $ (before++get_options comm++after):rest+              _ ->  case matchRegex (mkRegex "^(.*)\\\\example\\{(.+)\\}(.*)$") s of+                    Just (before:fn:after:_) -> do+                        filecont <- readFile fn -- ratify readFile: not part of+                                                -- darcs executable+                        return $ (before++"\\begin{verbatim}"+++                                  filecont++"\\end{verbatim}"+                                  ++after):rest+                    _ -> return $ s : rest+  where breakLast chr str = (reverse $ tail l, reverse f)+            where (f, l) = break (==chr) $ reverse str++preproc [] = return []++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 =+    "\\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++ignore :: [String] -> IO [String]+ignore ("\\end{code}":ss) = preproc ss+ignore (_:ss) = ignore ss+ignore [] = return []++command_property :: (DarcsCommand -> String) -> [DarcsCommand] -> String+                 -> String+command_property property commands name =+    property $ last c+    where words_ :: String -> [String] -- "word" with '_' instead of spaces+          words_ s =+              case dropWhile (=='_') s of+                       "" -> []+                       s' -> w : words_ s''+                           where (w, s'') = break (=='_') s'+          names = words_ name+          c = get_c names commands++gh :: String -> String+gh = command_property command_help the_commands+gd :: String -> String+gd = command_property command_description the_commands
+ 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://darcs.net/DarcsWiki/ConvertingFromCvs}{http://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 mv}+      (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://darcs.net/DarcsWiki/ConvertingFromArch}{http://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,816 @@+%  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+\end{code}++\begin{code}+import Control.Monad (when)+import System.IO.Unsafe ( unsafePerformIO )+import ByteStringUtils+import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.ByteString as B ( empty, concat )+import Darcs.Patch+import Darcs.Patch.Test+import Darcs.Patch.Unit ( run_patch_unit_tests )+import Lcs ( shiftBoundaries )+import Test.QuickCheck+import System ( ExitCode(..), exitWith )+import System.IO ( hSetBuffering, stdout, BufferMode(..) )+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )+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 )+#include "impossible.h"+\end{code}++\chapter{Main body of code}++\begin{code}+main :: IO ()+main = do+  hSetBuffering stdout NoBuffering+  returnval <- newIORef 0+  patch_failures <- run_patch_unit_tests+  if patch_failures > 0+      then do putStrLn $ show patch_failures ++ " failures in Darcs.Patch.Unit."+              exitWith $ ExitFailure 1+      else putStrLn "No failures in Darcs.Patch.Unit."+  when (unpackPSfromUTF8 (BC.pack "hello world") /= "hello world") $+       do putStr "Problem with unpackPSfromUTF8\n"+          putStr $ "hello world isn't '" +++                 unpackPSfromUTF8 (BC.pack "hello world")++"'\n"+          exitWith $ ExitFailure 1+  when (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world")+        /= "hello world") $+       do putStr "Problem with binary to hex conversion and back again\n"+          exitWith $ ExitFailure 1+  putStr "Checking that email can be parsed... "+  quickCheck $ \s ->+      unlines ("":s++["", ""]) ==+              BC.unpack (read_email (renderPS+                       $ make_email "reponame" [] (Just (text "contents\n"))+                       (text $ unlines s) (Just "filename")))+  --putStr $ test_patch+  --exitWith ExitSuccess+  case run_tests returnval of+    run -> 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")+      putStr "Checking that B.concat works... "+      quickCheck prop_concatPS+      putStr "Checking that hex conversion works... "+      quickCheck prop_hex_conversion+      putStr "Checking that show and read work right... "+      quickCheck prop_read_show+      run "Checking known commutes... " commute_tests+      run "Checking known merges... " merge_tests+      run "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"+      putStr "Checking that commuting by patch and its inverse is ok... "+      quickCheck prop_commute_inverse+      --putStr "Checking that conflict resolution is valid... "+      --quickCheck prop_resolve_conflicts_valid+      putStr "Checking that a patch followed by its inverse is identity... "+      quickCheck prop_patch_and_inverse_is_identity+      -- The following tests are "wrong" with the Conflictor code.+      --putStr "Checking that a simple smart_merge is sufficient... "+      --quickCheck prop_simple_smart_merge_good_enough+      --putStr "Checking that an elegant merge is sufficient... "+      --quickCheck prop_elegant_merge_good_enough+      putStr "Checking that commutes are equivalent... "+      quickCheck prop_commute_equivalency+      putStr "Checking that merges are valid... "+      quickCheck prop_merge_valid+      putStr "Checking inverses being valid... "+      quickCheck prop_inverse_valid+      putStr "Checking other inverse being valid... "+      quickCheck prop_other_inverse_valid+      run "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... "+      --quickCheck prop_unravel_order_independent+      --putStr "Checking the unravelling of three merges... "+      --quickCheck prop_unravel_three_merge+      --putStr "Checking the unravelling of a merge of a sequence... "+      --quickCheck prop_unravel_seq_merge+      putStr "Checking inverse of inverse... "+      quickCheck prop_inverse_composition+      putStr "Checking the order of commutes... "+      quickCheck prop_commute_either_order+      putStr "Checking commutex either way... "+      quickCheck prop_commute_either_way+      putStr "Checking the double commutex... "+      quickCheck prop_commute_twice+      putStr "Checking that merges commutex and are well behaved... "+      quickCheck prop_merge_is_commutable_and_correct+      putStr "Checking that merges can be swapped... "+      quickCheck prop_merge_is_swapable+      putStr "Checking again that merges can be swapped (I'm paranoid) ... "+      quickCheck prop_merge_is_swapable+      run "Checking that the patch validation works... " test_check+      run "Checking commutex/recommute... " commute_recommute_tests+      run "Checking merge properties... " generic_merge_tests+      run "Testing the lcs code... " show_lcs_tests+      run "Checking primitive patch IO functions... " primitive_show_read_tests+      run "Checking IO functions... " show_read_tests+      run "Checking primitive commutex/recommute... "+          primitive_commute_recommute_tests+      trv <- readIORef returnval+      if trv == 0+         then exitWith ExitSuccess+         else exitWith $ ExitFailure trv+\end{code}++\section{run\_tests}++run\_tests is used to run a series of tests (which return a list of strings+describing their failures) and then update n IORef so the program can exit+with an error if one of the tests failed.++\begin{code}+run_tests :: (IORef Int) -> String -> [String] -> IO ()+run_tests return_val s ss = do+    putStr s+    if null ss+       then putStr "good.\n"+       else do modifyIORef return_val (+1)+               print_strings ss+               exitWith $ ExitFailure 1++print_strings :: [String] -> IO ()+print_strings [] = return ()+print_strings (s:ss) = do+  putStr s+  print_strings ss+\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]+unit_tester :: PatchUnitTest p -> [p] -> [String]+unit_tester _ []        = []+unit_tester thetest (p:ps) = (thetest p)++(unit_tester thetest ps)++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{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 = unit_tester t_show_read test_patches +++                  unit_tester t_show_read test_patches_named+primitive_show_read_tests :: [String]+primitive_show_read_tests = unit_tester 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 = unit_tester 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"]+\end{code}++\begin{code}+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)+\end{code}++\begin{code}+check_subcommutes :: Testable a => [(String, a)] -> String -> IO ()+check_subcommutes [] _ = return ()+check_subcommutes ((n,c):r) expl =+    do putStr $ "Checking " ++ expl ++ " for subcommute " ++ n ++ "... "+       quickCheck c+       check_subcommutes r expl+\end{code}++\end{document}++
+ src/win32/CtrlC.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fffi #-}+{-# 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 -fffi #-}+{-# 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,93 @@+{-# OPTIONS_GHC -cpp #-}+module System.Posix.Files where++import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.C.Error ( throwErrnoIfMinus1Retry )+import Foreign.C.String ( withCString )+import Foreign.C.Types ( CTime, CInt )+import Foreign.Ptr ( Ptr )++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)))++-- Dummy implementation of createLink.+createLink :: FilePath -> FilePath -> IO ()+createLink _ _ = fail "Dummy create link error should be caught."
+ 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.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);++
+ 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/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.sh view
@@ -0,0 +1,12 @@+#!/usr/bin/env bash++. lib+alias pwd=hspwd++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+cd ..++rm -rf temp1 temp2
+ 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,116 @@+#!/usr/bin/env bash++# Some tests for proper handling of filepaths++. lib++# ugly hack for Cygwin and hspwd+IFS=''+DIR=`hspwd`++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,19 @@+#!/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+IFS='' # annoying hack for cygwin and hspwd below+DIR=`hspwd`+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/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,48 @@+#!/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"+}+++lookfor readFile \+        "readFile doesn't ensure the file is closed before it is deleted!" \+        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,28 @@+#!/usr/bin/env bash++# http://bugs.darcs.net/issue1057: Identifying current repository when pulling from repository identified via symbolic link+++. lib++rm -rf temp+mkdir temp+cd temp++mkdir repo+cd repo+darcs init+cd ..++ln -s repo srepo+cd srepo+IFS='' # annoying hack for cygwin and hspwd below+DIR=`hspwd`+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,22 @@+#!/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+IFS='' # annoying hack for cygwin and hspwd below+DIR=`hspwd`+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/issue154_pull_dir_not_empty.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++# A test for pulling a patch to remove a directory when the local copy is not empty.+# Issue154++. 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,53 @@+#!/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 ..++# this is an ugly hack for Cygwin and pwd+IFS=''+DIR=`hspwd`++# 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,39 @@+#!/usr/bin/env bash++. lib++# issue70 and RT #349 - setpref should coalesce changes++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/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,137 @@+#!/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+IFS=""+REPO_ABS=`hspwd`+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/bug.sh view
@@ -0,0 +1,17 @@+#!/bin/env bash++set -ev++## The builtin ! has the wrong semantics for not.+not () { "$@" && exit 1 || :; }++rm -rf temp+mkdir temp+cd temp++not darcs show bug &> bugout+cat bugout+grep 'lease report this' bugout++cd ..+rm -rf temp
+ tests/network/changes.sh view
@@ -0,0 +1,8 @@+#!/usr/bin/env bash+set -ev++# Demonstrates issue385++test "$DARCS" || DARCS="$PWD"/../darcs++"$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/no_pristine.sh view
@@ -0,0 +1,32 @@+#!/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++mkdir temp1+cd temp1++darcs initialize --no-pristine-tree+echo ALL --author Testing Person >> _darcs/prefs/defaults+echo ALL --ignore-times >> _darcs/prefs/defaults++echo foo > bar+darcs add bar+darcs record -a -m baz bar++date > bar+darcs record --no-test -a -m 'patch 2'++darcs setpref test 'echo hello world'+darcs record -a -m 'setpref'++date >> bar+darcs record -a -m 'record with test'++cd ..++rm -rf temp1
+ 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,155 @@+#!/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+IFS=""+DIR=`hspwd`+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+perl -e 'print "a"x1048576' > 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,120 @@+#!/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+    perl -i~ -pe "$1" 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,52 @@+#!/usr/bin/env bash++# Some tests for 'darcs push'++. lib++# setting IFS is an ugly hack for Cygwin+# so that the hspwd backtick+IFS=''+DIR=`hspwd`++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 "can't push to current repository!" 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,33 @@+#!/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+# hack for cygwin and hspwd below+IFS=''+DIR=`hspwd`+# 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,93 @@+#!/usr/bin/env bash+set -ev++check_manifest () {+    IFS=' '+    : > 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+    IFS=''+}++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,56 @@+#!/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++# record works with absolute paths+# hack for Cygwin and hspwd+IFS=''+DIR=`hspwd`+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+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+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+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+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.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,56 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp++darcs init++echo "X X X" > foo+darcs rec -alm "Added"++# This should fail until replace handles spaces+darcs replace ' X ' ' XX ' --token-chars '[ X]' 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/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,33 @@+#!/bin/bash++set -ev++range="0 1 2"++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,35 @@+#!/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+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
@@ -0,0 +1,38 @@+#!/bin/bash++#  Issue578: A conflict rollback case for Darcs2++set -ev++rm -rf tmp_steve tmp_monica++mkdir tmp_steve+mkdir tmp_monica++cd tmp_steve+darcs init  --darcs-2+echo A >foo+darcs add foo+darcs record -Asteve -am 'Anote'++echo B >foo+darcs record -Asteve -am 'Bnote'++# Show the history as Steve sees it.+darcs changes -s+echo "######"++cd ../tmp_monica+darcs init --darcs-2+echo A>foo+darcs add foo+echo Z>bar+darcs add bar+darcs record -Amonica -am 'AZnote'+darcs pull -a ../tmp_steve+darcs changes+echo "######"+darcs rollback -a -m newpatch -A me --match 'exact Anote'++# previous failure result: darcs failed:  cannot roll back a 'rollback' patch.+
+ tests/tag.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+. lib++# Some tests for 'darcs tag'++rm -rf temp1 log+mkdir temp1+cd temp1+darcs init+touch one+darcs add one+darcs record --patch-name 'uno' --all+darcs tag  soup > log+not grep failed log+grep TAG log+darcs changes --last 1 > log+grep tagged log+cd ..+rm -rf temp1 log
+ tests/three_way_conflict.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1 temp2 temp3+mkdir -p temp1 temp2 temp3+cd temp1+darcs init+cd ../temp2+darcs init+cd ../temp3+darcs init++touch foo+darcs add foo+darcs record -a -A author -m add+darcs push -a ../temp2+darcs push -a ../temp1++echo A > foo+darcs record -a -A author -m AA+cd ../temp2+echo B > foo+darcs record -a -A author -m BB+cd ../temp1+echo C > foo+darcs record -a -A author -m CC++darcs pull -a ../temp2+darcs pull -a ../temp3++cd ../temp2+darcs pull -a ../temp3+darcs pull -a ../temp1+rm -rf temp1 temp2 temp3
+ tests/toolbox.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash++. lib++# setting IFS is an ugly hack for Cygwin+# so that the hspwd backtick+IFS=''+DIR=`hspwd`++abort_windows++# set up the repository+rm -rf temp1                    # another script may have left a mess.+mkdir temp1+cd temp1+darcs init+touch foo+darcs add foo+# trick: hitting 'enter' in interactive darcs record+echo n/ | tr / \\012 | darcs record+cd ..+rm -rf temp1
+ tests/tricky_unrecord.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash+set -ev++rm -rf temp+mkdir temp+cd temp+darcs init+date > temp.c+darcs add temp.c+darcs record --all -A test --patch-name=hi++mkdir d+darcs add d+darcs mv temp.c d/+darcs record --all -A test --patch-name=mvetc+darcs show contents d/temp.c | cmp d/temp.c -++echo y/d/y | tr / \\012 | darcs unrecord+darcs whatsnew+# darcs show contents d/temp.c | cmp d/temp.c -++darcs record --all -A test --patch-name=again+darcs show contents d/temp.c | cmp d/temp.c -++cd ..+rm -rf temp+
+ tests/uniqueoptions.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+echo+echo Checking that each command expects each option only once+echo++set -ev++if echo $OS | grep -i windows; then+    echo Noone knows how to handle newlines under cygwin, so we skip this test+    exit 0+fi++rm -rf temp1+mkdir temp1+cd temp1++for i in `darcs --commands | grep -v -- -- | xargs echo`; do+    echo -n Checking $i... ' '+    # only output actual command options, i.e. lines that contain a --+    darcs $i --help | grep -- "--" | sort > $i+    uniq $i > uni$i+    if cmp $i uni$i; then+        echo passed.+    else+        echo failed!+        diff -c uni$i $i+        exit 1+    fi+done++cd ..+rm -rf temp1+
+ tests/unpull-formerly-pl.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 unpull -p baz2world++darcs whatsnew | grep 'No changes'++grep 'love the baz' foo++echo y | darcs unpull -p bar2baz++grep 'love the bar' foo++echo y | darcs unpull -p nolove++grep 'love' foo && exit 1 || true++cd ..+rm -rf tempA+
+ tests/unpull.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+cat > f <<EOF+one+two+three+EOF+darcs rec -Ax -alm init+cp f g+cat > f <<EOF+three+one+EOF+darcs rec -Ax -am foo+echo y | darcs unpull -p foo+cmp f g+cd ..+rm -rf temp1
+ tests/unrecord-add.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo foo > foo+darcs add foo+darcs whatsnew > correct+cat correct++darcs record -a -m 'addfoo'++darcs unrecord -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1
+ tests/unrecord-dont-prompt.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++set -ev++# Check that the right patches get unrecorded using --dont-prompt-for-dependencies++rm -rf temp1+mkdir temp1+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+darcs unrec --no-deps -p foo1+darcs changes -p foo --count | grep 2+#foo1 is depended upon, we don't unpull it+echo y | darcs unrec --dont-prompt-for-dependencies -p foo1+#on the previous line, we don't get asked about foo2.+darcs changes -p foo --count | grep 0+#yet, it is unrecorded.+darcs changes -p bar --count | grep 2+cd ..+rm -rf temp1
+ tests/unrecord-remove.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo foo > foo+darcs add foo++darcs record -a -m 'addfoo'++darcs remove foo++darcs whatsnew > correct+cat correct++darcs record -a -m 'rmfoo'++darcs unrecord -a --last 1++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1
+ tests/unrecord-setpref.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash+set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init++darcs setpref boringfile foobar++darcs whatsnew > correct+cat correct++darcs record -a -m 'boringfoobar'++darcs unrecord -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1
+ tests/unrecord.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++set -ev++# Check that checkpoints are removed when tags are unrecorded++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo foo > f+darcs rec -Ax -alm init+darcs tag -Ax --checkpoint t+echo y | darcs unrec -t t+# the complete inventory has only one patch to check+darcs check --complete > out+# The following test fails because the new progress code only+# prints out information on slow commands.+#grep '1 of 1' out >/dev/null++# the checkpoint (if left) has two patches to check+# but it should have been removed+darcs check --partial > out+# The following test fails because the new progress code only+# prints out information on slow commands.+#grep '1 of 1' out >/dev/null+cd ..+rm -rf temp1
+ tests/unrevert-add.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo foo > foo+darcs add foo+darcs whatsnew > correct+cat correct++darcs revert -a++not darcs whatsnew++darcs unrevert -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1
+ tests/unrevert-replace-moved.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo hello world > foo+darcs add foo++darcs record -a -m 'addfoo'++darcs replace hello goodbye foo++darcs revert -a++not darcs whatsnew++darcs mv foo bar++echo hello my good friends >> bar++darcs unrevert -a++darcs whatsnew > unrecorded+cat unrecorded++grep 'bar .* hello goodbye' unrecorded++cat bar+grep 'goodbye world' bar+grep 'goodbye my good friends' bar++cd ..+rm -rf temp1
+ tests/unrevert.sh view
@@ -0,0 +1,21 @@+#!/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+cp foo bar+darcs revert -a+darcs show contents foo | cmp foo -++darcs unrevert -a+cmp foo bar++cd ..+rm -rf temp1+
+ tests/unrevert_cancel.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash++# From issue366 bug report++set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch a +touch b+darcs add *+darcs record -A moi -am init+echo plim >> a+echo plim >> b+echo y/y/y/ | tr / \\012 | darcs revert+echo ploum >> a +echo nyy | tr / \\012 | darcs unrevert++cd ..+rm -rf temp1
+ tests/what_sl.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash++set -ev++rm -rf temp1+mkdir temp1+cd temp1+darcs init+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++cd ..+rm -rf temp1+
+ tests/whatsnew-file.sh view
@@ -0,0 +1,61 @@+#!/usr/bin/env bash++. lib++# Some tests for 'darcs whatsnew '++rm -rf temp1++mkdir temp1+cd temp1++darcs init+date > foo+mkdir bar+echo hello world > bar/baz++darcs record -la -m "add foo"++echo goodbye world >> bar/baz++# goodbye should show up precisely once++darcs wh > out+cat out+grep goodbye out | wc -l | grep 1++darcs wh bar bar/baz > out+cat out+grep goodbye out | wc -l | grep 1++darcs mv foo bar+echo not date > bar/foo++darcs wh bar bar/baz > out+cat out+grep date out | wc -l | grep 1++darcs wh foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo foo foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo ./foo ../temp1/foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo bar/../foo > out+cat out+grep date out | wc -l | grep 1++# This one fails actually, but it's not my fault. Filed as issue1196.+#darcs wh foo foo/../foo/. > out+#cat out+#grep date out | wc -l | grep 1++cd ..++rm -rf temp1
+ tests/whatsnew.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash++. lib++# Some tests for 'darcs whatsnew '++rm -rf temp1 temp2++mkdir temp1+cd temp1++# RT#505 whatsnew -s after removal of file without a newline+darcs init+echo -n foobar > foo+darcs record -la -m "add foo" | grep "Finished record"+rm -f foo+darcs whatsnew -s | grep R+darcs record -a -m "remove foo"++# RT#245 --look-for-adds implies --summary+touch look_summary.txt+darcs whatsnew -l | grep -i "a ./look_summary.txt"++#whatsnew works with uncommon file names+if echo $OS | grep -i windows; then+  echo  test does not work on windows+  exit 0;+else+  touch \\+  darcs add \\+  darcs whatsnew > log+  not grep "no changes" log+fi++# whatsnew works with absolute paths+IFS='' # annoying hack for cygwin and hspwd below+DIR=`hspwd`+echo date.t > date.t+touch date.t+darcs add date.t+darcs whatsnew ${DIR}/date.t | grep hunk++cd ..++rm -rf temp1
+ tests/workingdir.sh view
@@ -0,0 +1,92 @@+#!/usr/bin/env bash++. lib++# test for working dir woes++# the setup...+rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+mkdir a+echo temp0 > a/x+darcs add a+darcs add a/x+darcs record -am "aa"+darcs mv a/x a/y+darcs record -am "x to y"+echo temp1 > b+darcs add b+darcs record -am "bb"+mkdir d+darcs add d+darcs record -am "dd"+darcs tag 1+echo 1-b2 > b+darcs record -am "b2"+cd ..++# try to move a file that we don't have the right to do+darcs get temp1 temp2 --to-patch aa+cd temp2+chmod u-w a+darcs pull -a+test -e b+chmod u+w a+cd ..+rm -rf temp2++# [issue319] try to overwrite file(s) in our working dir+darcs get temp1 temp2 --to-patch aa+cd temp2+echo temp2 > b+echo temp2 > d+darcs pull -a -t 1+grep temp1 b+grep temp2 b-darcs-backup0+grep temp2 d-darcs-backup0+# now make sure we didn't overdo it+darcs pull -a+grep '1-b2' b+test -e b-darcs-backup0+test ! -e b-darcs-backup1+cd ..+rm -rf temp2++# [issue298] backup working dir files with conflicts+darcs get temp1 temp2 --tag 1+cd temp2+echo 2-b2 > b+darcs pull -a+grep "v v v" b+grep "2-b2"  b-darcs-backup0+not grep "v v v" b-darcs-backup0+cd ..+rm -rf temp2++# [issue440] a) try to overwrite a file in our working dir+darcs get temp1 temp2 --to-patch a+cd temp2+echo temp2 > a/y+echo old-bak > a/y-darcs-backup0+darcs pull -a+grep temp0 a/y+grep old-bak a/y-darcs-backup0+grep temp2   a/y-darcs-backup1+cd ..+rm -rf temp2++# [issue440] b) try to overwrite a directory in our working dir+darcs get temp1 temp2 --to-patch a+cd temp2+mkdir a/y+echo old-bak > a/y-darcs-backup0+darcs pull -a+grep temp0 a/y+grep old-bak a/y-darcs-backup0+test -d a/y-darcs-backup1+cd ..+rm -rf temp2++rm -rf temp1
+ tools/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.
+ tools/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
+ tools/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();+
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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>
+ tools/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%;+}
+ tools/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+
+ tools/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+
+ tools/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-in-unstable`;+    # 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-in-unstable]",+         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);+}++
+ tools/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;+}
+ tools/zsh_completion_new view
@@ -0,0 +1,533 @@+#compdef darcs++# The Z Shell is copyright (c) 1992-2004 Paul Falstad, Richard Coleman,+# Zoltán Hidvégi, Andrew Main, Peter Stephenson, Sven Wischnowsky, and+# others.  All rights reserved.  Individual authors, whether or not+# specifically named, retain copyright in all changes; in what follows, they+# are referred to as `the Zsh Development Group'.  This is for convenience+# only and this body has no legal status.  The Z shell is distributed under+# the following licence; any provisions made in individual files take+# precedence.+#+# Permission is hereby granted, without written agreement and without+# licence or royalty fees, to use, copy, modify, and distribute this+# software and to distribute modified versions of this software for any+# purpose, provided that the above copyright notice and the following+# two paragraphs appear in all copies of this software.+#+# In no event shall the Zsh Development Group be liable to any party for+# direct, indirect, special, incidental, or consequential damages arising out+# of the use of this software and its documentation, even if the Zsh+# Development Group have been advised of the possibility of such damage.+#+# The Zsh Development Group specifically disclaim any warranties, including,+# but not limited to, the implied warranties of merchantability and fitness+# for a particular purpose.  The software provided hereunder is on an "as is"+# basis, and the Zsh Development Group have no obligation to provide+# maintenance, support, updates, enhancements, or modifications.++# This completion module is based on section 6.8 of 'A User's Guide to the Z-Shell' +# by Peter Stephenson and on the tla completion module by Jason McCarty.++# EXTENDED_GLOB is required fr pattern backreferences.+setopt EXTENDED_GLOB++local DARCS=$words[1]++# test whether to hide short options from completion+autoload is-at-least+local hide_short+if zstyle -s ":completion:${curcontext}" hide-shortopts hide_short; then+  case $hide_short in+    true|yes|on|1) hide_short='!' ;;+    *) hide_short='' ;;+  esac+else+  is-at-least 4.1 || hide_short='!'+fi++++_darcs_main() {+local DARCS=$words[1]+local arguments+local curcontext="$curcontext"++if (( CURRENT > 2 )); then+    local cmd=${words[2]}+    local var_cmd=cmd_${cmd//-/_}+    curcontext="${curcontext%:*:*}:darcs-${cmd}:"+    (( CURRENT-- ))+    shift words++    local short long arg desc action+    short=()+    long=()+    arg=()+    desc=()+    action=()   +    arguments=()+    +    # Collect all help lines which have a leading space.+    local input+    input=(${(f)"$($DARCS $cmd -h)"})+    input=(${input:#[^\ ]*})+    local i+    for (( i=1 ; i <= ${#input} ; i++ )); do+	# Assumption: the the argument descriptions from `darcs cmd -h` +	# have the following format:+	# [spaces]<-f>[spaces][--flag]<=<spaces>argument>[spaces][description]+	[[ "$input[i]" = (#b)' '#(-?|)' '#([^' ']#|)' '#(--[^=' ']#)(=([^' ']#)|)' '#(*) ]] \+		|| _message -e messages "cannot parse command help output." || return 1++	short[i]="$match[1]"+	long[i]="$match[3]"+	arg[i]="$match[5]"+	desc[i]="$match[6]"+	desc[i]="${${desc[i]//\[/\\[}//\]/\\]}" # escape brackets	++	case $arg[i] in+	DIRECTORY)+	  action[i]='_files -/' ;;+	FILE|FILENAME|IDFILE|KEYS)+	  action[i]='_files' ;;+	USERNAME)+	  action[i]='_users' ;;+	EMAIL|FROM)+	  action[i]='_email_addresses' ;;+	*)+ 	  action[i]='' ;;+ 	esac+    done+    +    # Compute the exludes for _arguments++    local excluded short_excluded long_excluded k++    for (( i=1 ; i <= ${#input} ; i++ )); do+	excluded=()+	for opt (${=excludes[$long[i]]}); do+	    k=$long[(i)$opt]+	    excluded=($excluded $short[k] $long[k])+	done++	# Generate arguments for _arguments.+	# Make long and short options mutually exclusive.+	short_excluded=($long[i] $excluded)+	long_excluded=($short[i] $excluded)+	[ $short[i] ] && arguments=("$arguments[@]"+	    "${hide_short}(${short_excluded})${short[i]}[${desc[i]}]${arg[i]:+:$arg[i]:$action[i]}")+	[ $long[i] ] && arguments=("$arguments[@]"+	    "(${long_excluded})${long[i]}${arg[i]:+=}[${desc[i]}]${arg[i]:+:$arg[i]:$action[i]}")+    done++    arguments=("$arguments[@]" "${(@P)var_cmd-*:FILE:_files}")+else+    local hline+    local -a cmdlist+    _call_program help-commands darcs --help | while read -A hline; do+	(( ${#hline} < 2 )) && continue+	[[ $hline[1] == darcs ]] && continue+ 	[[ $hline[1] == Usage: ]] && continue+ 	[[ $hline[1] == Use ]] && continue+ 	cmdlist=( $cmdlist "${hline[1]}:${hline[2,-1]}" )+     done+    arguments=(':commands:(($cmdlist))')+fi++_arguments -S -A '-*' \+    "$arguments[@]"+}++++#+# Command argument definitions+#+local -a cmd_initialize cmd_get+cmd_initialize=()+cmd_get=(':repository:_files -/' ':new repository name:_files -/')++local -a cmd_add cmd_remove cmd_move cmd_replace+cmd_add=('*:new files:_darcs_new_file_or_tree')+cmd_remove=('*:existing controlled files:_darcs_controlled_files -e')+cmd_move=('*:existing controlled files:_darcs_controlled_files -e')+cmd_replace=(':old token:' ':new token:' '*:existing controlled files:_darcs_controlled_files -e')++local -a cmd_record cmd_pull cmd_push cmd_send cmd_apply+cmd_record=('*:controlled files:_darcs_controlled_files')+cmd_pull=(':repository:_darcs_repository_or_tree')+cmd_push=(':repository:_darcs_repository_or_tree')+cmd_send=(':repository:_darcs_repository_or_tree')+cmd_apply=(':patch file:_files')++local -a cmd_whatsnew cmd_changes+cmd_whatsnew=('*:controlled files:_darcs_controlled_files')+cmd_changes=('*:controlled files:_darcs_controlled_files')++local -a cmd_tag cmd_setpref cmd_check cmd_optimize+cmd_tag=()+cmd_setpref=(':preference key:(test predist boringfile binaries)' ':value:_files')+cmd_check=()+cmd_optimize=()++local -a cmd_amend_record cmd_rollback cmd_unrecord cmd_unpull cmd_revert cmd_unrevert+cmd_amend_record=('*:controlled files:_darcs_controlled_files')+cmd_rollback=()+cmd_unrecord=()+cmd_unpull=()+cmd_revert=('*:controlled files:_darcs_controlled_files')+cmd_unrevert=()++local -a cmd_diff cmd_annotate+cmd_diff=('*:controlled files:_darcs_controlled_files')+cmd_annotate=('*:controlled files:_darcs_controlled_files')++local -a cmd_resolve cmd_dist cmd_trackdown cmd_repair+cmd_resolve=()+cmd_dist=()+cmd_trackdown=(':initialization:' ':command:')+cmd_repair=()+++#+# Completion functions+#++(( $+functions[_darcs_new_files] )) ||+_darcs_new_files () {+    local -a new_files+    local -a local_files+    local in_tree_head in_tree_tail+    _darcs_make_tree_path in_tree_head in_tree_tail || return 1+    new_files=(${(f)"$(cd $(_darcs_absolute_tree_root)/$in_tree_head; $DARCS whatsnew -sl .)"})  +    new_files=(${${new_files:#[^a]*}//a /})++    local_files=()+    for file ($new_files); do+	[[ $file:h = $in_tree_head && $file:t = ${in_tree_tail}* ]] && local_files+=$file:t+    done++    compset -P '*/'+    _description new_files expl "new files"+    compadd "$expl[@]" "$local_files[@]"+}+++++# _darcs_controlled_files [-e|r] [-f|d]+#+# Adds controlled files to the completion. Can take either+# -e or -r as flags which respectively only add the existing+# files or the deleted files. Can take either -f or -d which+# respectively add only the files or directories.+(( $+functions[_darcs_controlled_files] )) ||+_darcs_controlled_files() {+    local abs_root=$(_darcs_absolute_tree_root)+    local only_removed only_existing only_files only_dirs+    zparseopts -E \+	'r=only_removed' 'e=only_existing' \+	'f=only_files' 'd=only_dirs'++    local in_tree_head in_tree_tail+    _darcs_make_tree_path in_tree_head in_tree_tail+    local recorded_dir+    if [[ -d $abs_root/_darcs/current ]]; then+        recorded_dir="$abs_root/_darcs/current/$in_tree_head"+    else+        recorded_dir="$abs_root/_darcs/pristine/$in_tree_head"+    fi+    local -a controlled_files controlled_dirs existing_files existing_dirs +    local -a dir_display_strs removed_dir_display_strs+    controlled_files=${(z)$(print $recorded_dir/$in_tree_tail*(.:t))}+    controlled_dirs=${(z)$(print $recorded_dir/$in_tree_tail*(/:t))}+    existing_files=() existing_dirs=()+    removed_files=() removed_dirs=() +    dir_display_strs=() removed_dir_display_strs=()+    local dir file+    for dir ($controlled_dirs); do+	if [[ -e $abs_root/$in_tree_head/$dir ]]; then+	    existing_dirs+="$dir"+	    dir_display_strs+="$dir/"	+	else+	    removed_dirs+="$dir"+	    removed_dir_display_strs+="$dir/"+	fi+    done+    for file ($controlled_files); do+	if [[ -e $abs_root/$in_tree_head/$file ]]; then+	    existing_files+="$file"+	else+	    removed_files+="$file"+	fi+    done++    compset -P '*/'+    if (( ! ${#only_removed} )); then +	_description controlled_files expl "existing revision controlled files"+	(( ! ${#only_dirs} )) && compadd "$expl[@]" $existing_files+	(( ! ${#only_files} )) \+	    && compadd "$expl[@]" -q -S / -d dir_display_strs -a -- existing_dirs+    fi+    if (( ! ${#only_existing} )); then+	_description removed_files expl "removed revision controlled files"+	(( ! ${#only_dirs} )) && compadd "$expl[@]" $removed_files+	(( ! ${#only_files} )) \+	    && compadd "$expl[@]" -q -S / -d removed_dir_display_strs -a -- removed_dirs+    fi+}++(( $+functions[_darcs_repositories] )) ||+_darcs_repositories() {+    local local_repos_path="$(_darcs_absolute_tree_root)/_darcs/prefs/repos"+    local global_repos_path="$HOME/.darcs/repos"+    local -a local_repos global_repos+    local -a global_repos+    [[ -e $local_repos_path ]] && cat $local_repos_path | read -A local_repos+    [[ -e $global_repos_path ]] && cat $global_repos_path | read -A global_repos+    local_repos=${local_repos:# #}+    global_repos=${global_repos:# #}+    _description repositories expl "repositories"+    (( ${#local_repos} )) && compadd "$expl[@]" -- "$local_repos[@]"+    (( ${#global_repos} )) && compadd "$expl[@]" -- "$global_repos[@]"+}++++# Combination completion functions++(( $+functions[_darcs_new_file_or_tree] )) ||+_darcs_new_file_or_tree() {+    local base_dir=$( cd ${$(_darcs_repodir):-.}; pwd -P)+    [[ -z $(_darcs_absolute_tree_root $base_dir) ]] && return 1+    local -a ignored_files+    ignored_files=(_darcs)+    _alternative 'newfiles:new file:_darcs_new_files' \+		 "directories:tree:_path_files -/ -W$base_dir -Fignored_files"+}++(( $+functions[_darcs_repository_or_tree] )) ||+_darcs_repository_or_tree() {+    local -a ignored_files+    ignored_files=(_darcs)+    _alternative 'repository:repository:_darcs_repositories' \+		 "directories:directories:_path_files -/ -Fignored_files"+}+++#+# Mutually exclusive options +#++typeset -A excludes+excludes=(+# Output+    --summary                     '--no-summary'+    --no-summary                  '--summary'+    --context                     '          --xml-output --human-readable --unified'+    --xml-output                  '--context              --human-readable --unified'+    --human-readable              '--context --xml-output                  --unified'+    --unified                     '--context --xml-output --human-readable          '++# Verbosity+    --verbose                     '          --quiet --standard-verbosity'+    --quiet                       '--verbose         --standard-verbosity'+    --standard-verbosity          '--verbose --quiet                     '++# Traversal+    --recursive                   '--not-recursive'+    --not-recursive               '--recursive'+    --look-for-adds               '--dont-look-for-adds'+    --dont-look-for-adds          '--look-for-adds'++# Pattern+    --from-match                  '             --from-patch --from-tag'+    --from-patch                  '--from-match              --from-tag'+    --from-tag                    '--from-patch --from-match           '+    --to-match                    '           --to-patch -to-tag'+    --to-patch                    '--to-match            -to-tag'+    --to-tag                      '--to-match --to-patch        '++# Repository Properties+    --plain-pristine-tree         '--no-pristine-tree'+    --no-pristine-tree            '--plain-pristine-tree'+    --parial                      '--complete'+    --complete                    '--partial'+    --compress                    '--dont-compress'+    --dont-compress               '--compress'+    --set-default                 '--no-set-default'+    --no-set-default              '--set-default'++# Logs+    --edit-long-comment           '--skip-long-comment --leave-test-directory'+    --skip-long-comment           '--edit-long-comment --leave-test-directory'+    --prompt-long-comment         '--edit-long-comment --skip-long-comment'++# Security+    --sign                        '       --sign-as --sign-ssl --dont-sign'+    --sign-as                     '--sign           --sign-ssl --dont-sign'+    --sign-ssl                    '--sign --sign-as            --dont-sign'+    --dont-sign                   '--sign --sign-as --sign-ssl            '+    --verify                      '         --verify-ssl --no-verify'+    --verify-ssl                  '--verify              --no-verify'+    --no-verify                   '--verify --verify-ssl            '+    --apply-as                    '--apply-as-myself'+    --apply-as-myself             '--apply-as'++# Conflicts+    --mark-conflicts              '--allow-conflicts --no-resolve-conflicts --dont-allow-conflicts'+    --allow-conflicts             '--mark-conflicts --no-resolve-conflicts --dont-allow-conflicts'+    --no-resolve-conflicts        '--mark-conflicts --allow-conflicts --dont-allow-conflicts'+    --dont-allow-conflicts        '--mark-conflicts --allow-conflicts --no-resolve-conflicts '++# Test+    --test                        '--no-test'+    --no-test                     '--test'+    --leave-test-directory        '--remove-test-directory'+    --remove-test-directory       '--leave-test-directory'++# Misc+    --force                       '--no-force'+    --no-force                    '--force'+    --ask-deps                    '--no-ask-deps'+    --no-ask-deps                 '--ask-deps'+    --date-trick                  '--no-date-trick'+    --no-date-trick               '--date-trick'+    --set-scripts-executable      '--dont-set-scripts-executable'+    --dont-set-scripts-executable '--set-scripts-executable'+)++++#+# Utility functions+#++# _darcs_make_tree_path in_tree_head_name in_tree_tail_name path+# Set in_tree_head_name in_tree_tail_name to the corresponding path+# parts from inside the current darcs tree.+_darcs_make_tree_path () {+    [[ -z $3 || $3 = '.' ]] && 3=${PREFIX:-./}+    local _in_tree=$(_darcs_path_from_root ${$(_darcs_repodir):-.}/$3)+    [[ -z $_in_tree ]] && return 1+    4='' 5=''+    if [[ ${3[-1]} = / ]]; then +	4=$_in_tree+    else+	4=$_in_tree:h+	[[ $_in_tree:t != . ]] && 5=$_in_tree:t+    fi+    set -A "$1" "$4"+    set -A "$2" "$5"+}++_darcs_repodir () {+    local index=$words[(i)--repodir*]+    if (( index < CURRENT )); then+	if [[ $words[$index] = --repodir ]]; then+	    (( index++ ))+	    print $words[$index]+	else+	    print ${words[$index]#*=}+	fi+    fi+}++_darcs_absolute_tree_root () {+    local root=$(_darcs_repodir)+    [[ -z $root ]] && root=$(pwd -P)+    while [[ ! $root -ef / ]]; do+	[[ -d $root/_darcs ]] && break+	root="$root/.."+    done+    [[ $root -ef / ]] || print $(cd $root; pwd -P)+}++_darcs_tree_root () {+    local abs=$(_darcs_absolute_tree_root)+    local rel=$(_darcs_relative_path $abs $(pwd -P))+    [[ -n $abs ]] && print $rel+}++# _darcs_paths_from_root name paths+# Sets name to the paths relative to the darcs tree root.+# If no argument is given then the current directory+# is assumed.+_darcs_paths_from_root () {+    local name=$1+    abs=$(_darcs_absolute_tree_root)+    [[ -z $abs ]] && set -A "$name" && return 1+    shift+    1=${1:=$PWD}+    local -a subpaths+    _darcs_filter_for_subpaths subpaths $abs $*+    local i+    for (( i=1; i<=${#subpaths}; i++ )); do+	[[ $subpaths[$i] != '.' ]] && subpaths[$i]="./$subpaths[$i]"+    done+    set -A "$name" "$subpaths[@]"+}++_darcs_path_from_root() {+    local path+    _darcs_paths_from_root path $1+    [[ -n $path ]] && print "$path"+}++# _darcs_filter_for_in_dir name dir paths+# Sets name to the relative paths from dir to the given paths which +# traverse dir. It ignores paths which are not in dir.+_darcs_filter_for_subpaths () {+    local name=$1 dir=$2 +    shift 2+    local p rel+    local -a accepted_paths +    accepted_paths=()+    for p; do+	rel=$(_darcs_path_difference $p $dir)+	[[ -n $rel ]] && accepted_paths+="$rel"+    done+    set -A "$name" "$accepted_paths[@]"+}++# _darcs_path_difference p1 p2+# Print the path from p2 to p1. If p2 is not an ancestor of p1 then it +# prints a blank string. If they point to the same directory then it returns+# a single period. p2 needs to be a directory path.+_darcs_path_difference () {+    local diff=$(_darcs_relative_path $1 $2)+    [[ ${diff%%/*} != .. ]] && print $diff || return 1+}+++# Print the a relative path from the second directory to the first,+# defaulting the second directory to $PWD if none is specified.+# Taken from the zsh mailing list.+_darcs_relative_path () {+    2=${2:=$PWD}+    [[ -d $2 && -d $1:h ]] || return 1+    [[ ! -d $1 ]] && 3=$1:t 1=$1:h+    1=$(cd $1; pwd -P)+    2=$(cd $2; pwd -P)+    [[ $1 -ef $2 ]] && print ${3:-.} && return++    local -a cur abs+    cur=(${(s:/:)2})        # Split 'current' directory into cur+    abs=(${(s:/:)1} $3)     # Split target directory into abs++    # Compute the length of the common prefix, or discover a subdiretory:+    integer i=1+    while [[ i -le $#abs && $abs[i] == $cur[i] ]]+    do+	((++i > $#cur)) && print ${(j:/:)abs[i,-1]} && return+    done++    2=${(j:/:)cur[i,-1]/*/..}       # Up to the common prefix directory and+    1=${(j:/:)abs[i,-1]}            # down to the target directory or file++    print $2${1:+/$1}+}++# Code to make sure _darcs is run when we load it+_darcs_main "$@"
+ tools/zsh_completion_old view
@@ -0,0 +1,26 @@+#-*- mode: shell-script;-*-++# darcs command line completion for zsh -- example+# Copyright 2002 "David Roundy" <droundy@abridgegame.org>+#++# Old zsh compctl style+_darcs_first()+{+    local prefix+    prefix=$1+    reply=( $( darcs --commands | grep "^${prefix}" ) )+}++_darcs_rest()+{+    local first second prefix rest+    prefix=$1+    read -c first second rest+    reply=( $( darcs ${second} --list-option | grep "^${prefix}") )+}+# this would complete on files as well, if first and rest didn't match.+# since darcs does this when passed --list-option, no need+# compctl -F -x 'p[1,1]' -K _darcs_first - 'p[2,-1]' -K _darcs_rest -- darcs+compctl -x 'p[1,1]' -K _darcs_first - 'p[2,-1]' -K _darcs_rest -- darcs+