darcs-beta 2.7.98.3 → 2.7.99.1

raw patch · 96 files changed

+4538/−2747 lines, 96 filesdep ~basedep ~test-frameworkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, test-framework

API changes (from Hackage documentation)

Files

• contrib/darcs_completion +3/−3
• darcs-beta.cabal +39/−18
• doc/src/darcs.tex +1/−1
• release/distributed-context +1/−1
• src/CommandLine.hs +46/−28
• src/Darcs/Annotate.hs +190/−99
• src/Darcs/Arguments.hs +22/−5
• src/Darcs/ColorPrinter.hs +1/−1
• src/Darcs/Commands/Add.hs +223/−153
• src/Darcs/Commands/AmendRecord.hs +221/−155
• src/Darcs/Commands/Annotate.hs +4/−3
• src/Darcs/Commands/Apply.hs +49/−21
• src/Darcs/Commands/Changes.hs +88/−55
• src/Darcs/Commands/Diff.hs +30/−24
• src/Darcs/Commands/Dist.hs +98/−76
• src/Darcs/Commands/Help.hs +1/−2
• src/Darcs/Commands/Move.hs +60/−6
• src/Darcs/Commands/Pull.hs +57/−28
• src/Darcs/Commands/Record.hs +14/−6
• src/Darcs/Commands/Replace.hs +3/−3
• src/Darcs/Commands/Revert.hs +5/−5
• src/Darcs/Commands/Rollback.hs +1/−1
• src/Darcs/Commands/Test.hs +67/−0
• src/Darcs/Commands/Unrevert.hs +4/−3
• src/Darcs/Commands/WhatsNew.hs +120/−94
• src/Darcs/Diff.hs +112/−62
• src/Darcs/External.hs +7/−7
• src/Darcs/Flags.hs +82/−27
• src/Darcs/Global.hs +126/−61
• src/Darcs/Match.hs +1/−1
• src/Darcs/Patch.hs +88/−46
• src/Darcs/Patch/Apply.hs +51/−16
• src/Darcs/Patch/ApplyMonad.hs +36/−11
• src/Darcs/Patch/FileName.hs +16/−9
• src/Darcs/Patch/Format.hs +15/−14
• src/Darcs/Patch/Info.hs +11/−0
• src/Darcs/Patch/Merge.hs +32/−15
• src/Darcs/Patch/Named.hs +5/−4
• src/Darcs/Patch/Prim/V3/Apply.hs +0/−1
• src/Darcs/Patch/Prim/V3/Core.hs +9/−5
• src/Darcs/Patch/Prim/V3/Details.hs +0/−6
• src/Darcs/Patch/Prim/V3/ObjectMap.hs +0/−2
• src/Darcs/Patch/Prim/V3/Read.hs +6/−10
• src/Darcs/Patch/Prim/V3/Show.hs +12/−17
• src/Darcs/Patch/Set.hs +22/−11
• src/Darcs/Patch/Show.hs +1/−1
• src/Darcs/Patch/Split.hs +10/−6
• src/Darcs/Patch/TokenReplace.hs +6/−3
• src/Darcs/Patch/TouchesFiles.hs +29/−18
• src/Darcs/Patch/V2/Non.hs +162/−123
• src/Darcs/Patch/V2/Real.hs +875/−782
• src/Darcs/PrintPatch.hs +5/−2
• src/Darcs/Repository.hs +3/−7
• src/Darcs/Repository/Cache.hs +2/−2
• src/Darcs/Repository/HashedRepo.hs +4/−0
• src/Darcs/Repository/Internal.hs +3/−3
• src/Darcs/Repository/Merge.hs +1/−1
• src/Darcs/Repository/State.hs +2/−2
• src/Darcs/Resolution.hs +28/−18
• src/Darcs/RunCommand.hs +30/−16
• src/Darcs/SelectChanges.hs +96/−76
• src/Darcs/Ssh.hs +120/−78
• src/Darcs/TheCommands.hs +4/−1
• src/Darcs/Utils.hs +269/−120
• src/DateMatcher.hs +98/−80
• src/English.hs +25/−15
• src/Exec.hs +75/−44
• src/IsoDate.hs +11/−3
• src/Lcs.hs +11/−1
• src/Progress.hs +210/−108
• src/Ratified.hs +7/−1
• src/SHA1.hs +10/−0
• src/URL.hs +8/−0
• src/Workaround.hs +87/−36
• src/darcs.hs +54/−39
• src/test.hs +3/−0
• tests/amend-unrecord.sh +5/−2
• tests/failing-issue1522_trailing_slash_borkage.sh +35/−0
• tests/failing-issue2100-add-failures.sh +39/−0
• tests/issue1645-ignore-symlinks-case-fold.sh +1/−1
• tests/issue1645-ignore-symlinks.sh +11/−11
• tests/issue1749-rmdir.sh +3/−3
• tests/issue1763-pull-fails-on-non-ascii-filenames.sh +4/−1
• tests/issue194.sh +1/−1
• tests/issue2013_send_to_context.sh +2/−2
• tests/issue2136-changes_created_as_for_multiple_files.sh +86/−0
• tests/issue2139-mv-to-dir.sh +54/−0
• tests/match-date.sh +0/−1
• tests/mv-formerly-pl.sh +1/−1
• tests/network/issue2090-transfer-mode.sh +2/−0
• tests/network/ssh.sh +2/−0
• tests/pending_has_conflicts.sh +1/−3
• tests/rename_shouldnt_affect_prefixes.sh +50/−0
• tests/rmdir.sh +0/−6
• tests/rollback.sh +1/−1
• tests/workingdir.sh +12/−12

@@ -2,8 +2,8 @@  # darcs command line completion. # Copyright 2002 "David Roundy" <droundy@abridgegame.org>-#-have darcs &&+# This archive should be copied in the directory /etc/bash_completion.d/+ _darcs() {     local cur@@ -48,5 +48,5 @@     return 0  }-[ "$have" ] && complete -F _darcs -o default darcs+complete -F _darcs -o default darcs 

@@ -1,5 +1,5 @@ Name: darcs-beta-version:        2.7.98.3+version:        2.7.99.1 License:        GPL License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -122,13 +122,13 @@   description: Build with warnings-as-errors  -- If base >= 4.4 is used, the standard directory functions--- do Unicode translation. Use an explicit flag so we can+-- do Unicode translation. Use a flag so we can -- detect this situation and use a workaround.-flag base44+flag force-char8-encoding   default:     False-  -- once we have a workaround remove the manual: line-  manual:      True-  description: Allow base 4.4 or above: note, there are known problems with Unicode filenames (http://bugs.darcs.net/issue2095)+  description: Allow base 4.5 or above on Unix. base 4.4 introduces a change in+               the behaviour of filenames that requires API calls in+               base 4.5 to workaround. So base 4.4 is not supported at all.  -- ---------------------------------------------------------------------- -- darcs library@@ -191,6 +191,7 @@                       Darcs.Commands.ShowRepo                       Darcs.Commands.ShowTags                       Darcs.Commands.Tag+                      Darcs.Commands.Test                       Darcs.Commands.TrackDown                       Darcs.Commands.TransferMode                       Darcs.Commands.Util@@ -323,11 +324,11 @@                       SHA1                       URL                       URL.Request-                      URL.Curl                       URL.HTTP                       Workaround      other-modules:    Version+                      URL.Curl      c-sources:        src/atomic_create.c                       src/fpstring.c@@ -353,10 +354,14 @@     if os(solaris)       cc-options:     -DHAVE_SIGINFO_H -    if flag(base44)-      build-depends: base >= 4 && < 4.6+    if os(windows)+      build-depends:  base >= 4 && < 4.6     else-      build-depends: base >= 4 && < 4.4+      if flag(force-char8-encoding)+        build-depends:  base >= 4.5 && < 4.6+        cpp-options:    -DFORCE_CHAR8_ENCODING+      else+        build-depends:  base >= 4 && < 4.4      build-depends:   extensible-exceptions >= 0.1 && < 0.2,                      regex-compat >= 0.95.1,@@ -510,10 +515,14 @@   if os(solaris)     cc-options:     -DHAVE_SIGINFO_H -  if flag(base44)-    build-depends: base >= 4 && < 4.6+  if os(windows)+    build-depends:  base >= 4 && < 4.6   else-    build-depends: base >= 4 && < 4.4+    if flag(force-char8-encoding)+      build-depends:  base >= 4.5 && < 4.6+      cpp-options:    -DFORCE_CHAR8_ENCODING+    else+      build-depends:  base >= 4 && < 4.4    build-depends:   extensible-exceptions >= 0.1 && < 0.2,                    regex-compat >= 0.95.1,@@ -594,7 +603,7 @@ Executable          darcs-test   main-is:          test.hs -  build-tools: ghc >= 6.10 && < 7.2+  build-tools: ghc >= 6.10 && < 7.6     if !flag(test)@@ -612,7 +621,7 @@                      HUnit        >= 1.0,                      cmdlib       >= 0.2.1 && < 0.4,                      shellish     >= 0.1.3 && < 0.2,-                     test-framework             >= 0.2.2,+                     test-framework             >= 0.4.0,                      test-framework-hunit       >= 0.2.2,                      test-framework-quickcheck2 >= 0.2.8 @@ -669,6 +678,14 @@     if flag(threaded)       ghc-options:    -threaded +    if flag(curl)+      extra-libraries:   curl+      includes:          curl/curl.h+      cpp-options:       -DHAVE_CURL+      c-sources:         src/hscurl.c+      cc-options:        -DHAVE_CURL++     if flag(hpc)       ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test @@ -691,10 +708,14 @@     if os(solaris)       cc-options:     -DHAVE_SIGINFO_H -    if flag(base44)-      build-depends: base >= 4 && < 4.6+    if os(windows)+      build-depends:  base >= 4 && < 4.6     else-      build-depends: base >= 4 && < 4.4+      if flag(force-char8-encoding)+        build-depends:  base >= 4.5 && < 4.6+        cpp-options:    -DFORCE_CHAR8_ENCODING+      else+        build-depends:  base >= 4 && < 4.4      if !os(windows)       build-depends: unix >= 1.0 && < 2.6

@@ -1236,7 +1236,7 @@  \darcsCommand{tag} \darcsCommand{setpref}-\darcsCommand{check}+\darcsCommand{test}  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

@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.7.98.3\nGanesh Sittampalam <ganesh@earth.li>**20120119060551\n Ignore-this: bc156878e2f54804226a43035ea5da28\n] \n"+Just "\nContext:\n\n[TAG 2.7.99.1\nFlorent Becker <florent.becker@ens-lyon.org>**20120401092449\n Ignore-this: 23fef1226d1278f70993402dc13ea30d\n] \n"

@@ -15,6 +15,14 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +-- |+-- Module      : CommandLine+-- Copyright   : 2005 Benedikt Schmidt+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+-- -- |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@@ -42,46 +50,57 @@ -- >              ("a %s %<",(["a","<insert subject here>"], True))] -- > -- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases-module CommandLine ( parseCmd, addUrlencoded ) where-import Text.ParserCombinators.Parsec++module CommandLine+    ( parseCmd+    , addUrlencoded+    ) where++import Control.Arrow ( (***) ) import Data.Char ( ord, intToDigit, toUpper ) import Data.List ( find )+import Text.ParserCombinators.Parsec  -- | 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))+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)+arg :: FTable -> Parser String+arg ftable = quotedArg ftable <|> unquotedArg ftable -unquotedArg ftable = do (try $ format ftable)-                          <|> (many1 $ noneOf [' ', '\t', '"', '%'])+unquotedArg :: FTable -> Parser String+unquotedArg ftable = try (format ftable) <|> many1 (noneOf " \t\"%") -quotedArg ftable = between (char '"') (char '"') $ quoteContent ftable+quotedArg :: FTable -> Parser String+quotedArg ftable = between quoteChar quoteChar $ quoteContent ftable+  where+    quoteChar = char '"' +quoteContent :: FTable -> Parser String quoteContent ftable = do s1 <- escape-                               <|> (try $ format ftable)-                               <|> (many1 (noneOf ['"', '\\', '%']))+                               <|> try (format ftable)+                               <|> many1 (noneOf "\"\\%")                          s2 <- quoteContent ftable                          return $ s1 ++ s2                      <|> return ""  formatRedir :: Parser Bool-formatRedir = do _ <- string "%<"-                 return True-            <|> return False+formatRedir = (string "%<" >> return True)+              <|> return False +format :: FTable -> Parser String format ftable = do _ <- char '%'-                   c <- oneOf  (map fst ftable)+                   c <- oneOf (map fst ftable)                    return $ expandFormat ftable c +escape :: Parser String escape = do _ <- char '\\'             c <- anyChar             return [c]@@ -92,12 +111,12 @@                   return r  separator :: Parser ()-separator = do skipMany1 space+separator = skipMany1 space  expandFormat :: FTable -> Char -> String expandFormat ftable c = case find ((==c) . fst) ftable of-                          Just (_,s) -> s-                          Nothing -> error "impossible"+                            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@@ -106,17 +125,16 @@ -- 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+parseCmd ftable = parse (commandline ftable) ""  urlEncode :: String -> String urlEncode s = concatMap escapeC s-    where escapeC x = if allowed x then [x] else '%':(intToHex $ ord x)+    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']-                      ++ "!'()*-.~"+          allowed x = x `elem` allowedChars+          allowedChars = ['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)+addUrlencoded ftable = ftable ++ map (toUpper *** urlEncode) ftable

@@ -22,120 +22,195 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Annotate ( annotate, annotateDirectory, format, machineFormat ) where-import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Data.Maybe( isJust, catMaybes )-import Data.List( nub, groupBy )+-- |+-- Module      : Darcs.Annotate+-- Copyright   : 2010 Petr Rockai+-- License     : MIT+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Annotate+    (+      annotate+    , annotateDirectory+    , format+    , machineFormat+    ) where++import Prelude hiding ( pi )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M import qualified Data.Vector as V++import Data.List( nub, groupBy )+import Data.Maybe( isJust, catMaybes, isNothing )++import Control.Monad.State ( modify, when, gets, State, execState )+import Control.Applicative( (<$>) )++import Darcs.Patch.ApplyMonad( ApplyMonad(..) ) import Darcs.Patch.FileName( FileName, movedirfilename, fn2ps, ps2fn ) import Darcs.Patch.Apply ( Apply, apply, ApplyState ) import Darcs.Patch.Info ( PatchInfo(..), humanFriendly, piAuthor, makeFilename ) import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd )+import Darcs.Witnesses.Ordered++import Storage.Hashed.Tree( Tree ) import Lcs( getChanges ) import Printer( renderString )-import Darcs.Witnesses.Ordered import ByteStringUtils ( linesPS, unlinesPS )-import Control.Monad.State ( modify, when, gets, State, execState )-import Control.Applicative( (<$>) )-import qualified Data.Map as M-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Storage.Hashed.Tree( Tree )  #include "gadts.h" #include "impossible.h" -data FileOrDirectory = File | Directory deriving (Show, Eq)-data Annotated = Annotated { annotated :: V.Vector (Maybe PatchInfo, B.ByteString)-                           , current :: [(Int, B.ByteString)]-                           , path :: Maybe FileName-                           , what :: FileOrDirectory-                           , currentInfo :: PatchInfo }-                 deriving Show +data FileOrDirectory = File+                     | Directory+                       deriving (Show, Eq)++data Annotated = Annotated+    { annotated   :: V.Vector (Maybe PatchInfo, B.ByteString)+    , current     :: [(Int, B.ByteString)]+    , path        :: Maybe FileName+    , what        :: FileOrDirectory+    , currentInfo :: PatchInfo+    } deriving Show++ type AnnotatedM = State Annotated +-- XXX: No explicit method nor default method for 'editFile', 'editDirectory' instance ApplyMonad AnnotatedM Tree where   type ApplyMonadBase AnnotatedM = AnnotatedM++  nestedApply _ _ = undefinedFun "nestedApply"+  liftApply _ _   = undefinedFun "liftApply"+  getApplyState   = undefinedFun "getApplyState"+  putApplyState _ = undefinedFun "putApplyState"+  mReadFilePS     = undefinedFun "mReadFilePS"++  mDoesFileExist _      = return True   mDoesDirectoryExist _ = return True-  mReadFilePS = fail "mReadFilePS undefined for Annotated"-  mCreateDirectory _ = return ()-  mCreateFile _ = return ()-  mRemoveFile f = do p <- gets path-                     when (p == Just f) $ modify (\x -> x { path = Nothing })-                     updateDirectory f+  mCreateDirectory _    = return ()+  mCreateFile _         = return ()++  mRemoveFile f = do+      p <- gets path+      when (p == Just f) $ modify (\x -> x { path = Nothing })+      updateDirectory f+   mRemoveDirectory = mRemoveFile-  mRename a b =-    do p <- gets path-       w <- gets what-       when (isJust p) $-         modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }-       when (w == Directory) $ do-         let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))-         modify $ \st -> st { current = map fix $ current st }-  mModifyFilePS f job = do p <- gets path-                           when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)-  mModifyFilePSs f job = do p <- gets path-                            when (p == Just f) $ updateFile job -updateFile :: ([B.ByteString] -> AnnotatedM [B.ByteString]) -> AnnotatedM ()+  mRename a b = do+      p <- gets path+      w <- gets what+      when (isJust p) $+          modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }+      when (w == Directory) $ do+          let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))+          modify $ \st -> st { current = map fix $ current st }++  mModifyFilePS f job = do+      p <- gets path+      when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)++  mModifyFilePSs f job = do+      p <- gets path+      when (p == Just f) $ updateFile job++undefinedFun :: Monad m+             => String+             -> m a+undefinedFun name = fail $ name ++ " undefined for Annotated"+++updateFile :: ([B.ByteString]+           -> AnnotatedM [B.ByteString])+           -> AnnotatedM () updateFile job = (==File) <$> gets what >>= flip when go-  where go = do before <- map snd `fmap` gets current-                after <- job before-                reannotate $ getChanges before after-        reannotate [] = return ()-        reannotate ((off, remove, add):rest) = do-          i <- gets currentInfo-          c <- gets current-          a <- gets annotated-          modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] ++-                                       drop (off + length remove) c-                           , annotated = merge i a $ take (length remove) $ drop off c }-          reannotate rest-        merge i a l = a V.// [ (line, (Just i, B.empty))-                             | (line, _) <- l, line >= 0 && line < V.length a]+  where+    go = do+        before <- map snd `fmap` gets current+        after <- job before+        reannotate $ getChanges before after +    reannotate [] = return ()+    reannotate ((off, remove, add):rest) = do+        i <- gets currentInfo+        c <- gets current+        a <- gets annotated+        modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] +++                                     drop (off + length remove) c+                         , annotated = merge i a $ take (length remove) $ drop off c+                         }+        reannotate rest++    merge i a l = a V.// [ (line, (Just i, B.empty))+                         | (line, _) <- l, line >= 0 && line < V.length a]++ updateDirectory :: FileName -> AnnotatedM () updateDirectory p = (==Directory) <$> gets what >>= flip when go-  where go = do let line = fn2ps p-                files <- gets current-                case filter ((==line) . snd) files of-                  [match@(ident, _)] -> reannotate ident match line-                  _ -> return ()-        reannotate ident match line =-          modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]-                           , current = filter (/= match) $ current x }-        update line inf = (Just inf, BC.concat [ " -- created as: ", line ])+  where+    go = do let line = fn2ps p+            files <- gets current+            case filter ((==line) . snd) files of+              [match@(ident, _)] -> reannotate ident match line+              _ -> return ()+    reannotate ident match line =+      modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]+                       , current = filter (/= match) $ current x }+    update line inf = (Just inf, BC.concat [ " -- created as: ", line ]) + complete :: Annotated -> Bool-complete x = V.all (isJust . fst) $ annotated x+complete x = (V.all (isJust . fst) $ annotated x) || (isNothing $ path x) -annotate' :: (Apply p, ApplyState p ~ Tree) =>-             FL (PatchInfoAnd p) C(x y) -> Annotated -> Annotated++annotate' :: (Apply p, ApplyState p ~ Tree)+          => FL (PatchInfoAnd p) C(x y)+          -> Annotated+          -> Annotated annotate' NilFL ann = ann annotate' (p :>: ps) ann-  | complete ann = ann-  | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p })+    | complete ann = ann+    | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p }) + annotate :: (Apply p, ApplyState p ~ Tree)-         => FL (PatchInfoAnd p) C(x y) -> FileName -> B.ByteString -> Annotated+         => FL (PatchInfoAnd p) C(x y)+         -> FileName+         -> B.ByteString+         -> Annotated annotate patches inipath inicontent = annotate' patches initial-  where initial = Annotated { path = Just inipath-                            , currentInfo = error "There is no currentInfo."-                            , current = zip [0..] (linesPS inicontent)-                            , what = File-                            , annotated = V.replicate (length $ breakLines inicontent)-                                                      (Nothing, B.empty) }+  where+    initial = Annotated { path = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = zip [0..] (linesPS inicontent)+                        , what = File+                        , annotated = V.replicate (length $ breakLines inicontent)+                                                      (Nothing, B.empty)+                        } + annotateDirectory :: (Apply p, ApplyState p ~ Tree)-                  => FL (PatchInfoAnd p) C(x y) -> FileName -> [FileName] -> Annotated+                  => FL (PatchInfoAnd p) C(x y)+                  -> FileName+                  -> [FileName]+                  -> Annotated annotateDirectory patches inipath inicontent = annotate' patches initial-  where initial = Annotated { path = Just inipath-                            , currentInfo = error "There is no currentInfo."-                            , current = zip [0..] (map fn2ps inicontent)-                            , what = Directory-                            , annotated = V.replicate (length inicontent) (Nothing, B.empty) }+  where+    initial = Annotated { path = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = zip [0..] (map fn2ps inicontent)+                        , what = Directory+                        , annotated = V.replicate (length inicontent) (Nothing, B.empty)+                        } + machineFormat :: B.ByteString -> Annotated -> String machineFormat d a = unlines [ case i of                                  Just inf -> makeFilename inf@@ -144,28 +219,44 @@                               ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add                             | ((i, add), line) <- zip (V.toList $ annotated a) (breakLines d) ] -format :: B.ByteString -> Annotated -> String++format :: B.ByteString+       -> Annotated+       -> String format d a = pi_list ++ "\n" ++ file-  where pis = nub $ catMaybes . map fst $ V.toList (annotated a)-        pi_list = unlines $ [ show n ++ ": " ++ renderString (humanFriendly i)-                            | (n :: Int, i) <- zip [1..] pis ]-        pi_map = M.fromList (zip pis [1 :: Int ..])-        file_ann = groupBy (\a b -> fst a == fst b) $ zip (V.toList $ annotated a) (breakLines d)-        file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++-                        "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]-                      | chunk <- file_ann ]-        line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]-        annotation (Just i, _) | Just n <- M.lookup i pi_map =-          pad 20 (piMail i) ++ " " ++ pad 4 ("#" ++ show n)-        annotation _ = pad 25 "unknown"-        pad n str = replicate (n - length str) ' ' ++ (take n str)-        indent n str = replicate n ' ' ++ str-        piMail pi-          | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi-          | otherwise = piAuthor pi+  where+    pi_list = unlines $ [ show n ++ ": " ++ renderString (humanFriendly i)+                        | (n :: Int, i) <- zip [1..] pis ] +    file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) +++                    "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]+                  | chunk <- file_ann ]++    pis = nub $ catMaybes . map fst $ V.toList (annotated a)++    pi_map = M.fromList (zip pis [1 :: Int ..])++    file_ann = groupBy (\x y -> fst x == fst y) $ zip (V.toList $ annotated a) (breakLines d)++    line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]++    annotation (Just i, _) | Just n <- M.lookup i pi_map =+        pad 20 (piMail i) ++ " " ++ pad 4 ("#" ++ show n)+    annotation _ = pad 25 "unknown"++    pad n str = replicate (n - length str) ' ' ++ (take n str)++    indent n str = replicate n ' ' ++ str++    piMail pi+        | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi+        | otherwise = piAuthor pi+++breakLines :: BC.ByteString+           -> [BC.ByteString] breakLines s = case BC.split '\n' s of-  [] -> []-  split | BC.null (last split) -> init split-        | otherwise -> split+    [] -> []+    split | BC.null (last split) -> init split+          | otherwise -> split 

@@ -65,6 +65,7 @@                          summary, unified, tokens,                          partial,                          diffCmdFlag, diffflags, unidiff, xmloutput,+                         pauseForGui,                          forceReplace, dryRun, dryRunNoxml,                          printDryRunMessageAndExit, showFriendly,                          matchOne, matchSeveral, matchRange,@@ -257,6 +258,8 @@ getContent (ApplyAs s) = StringContent s getContent (DiffCmd s) = StringContent s getContent (ExternalMerge s) = StringContent s+getContent PauseForGui = NoContent+getContent NoPauseForGui = NoContent getContent (DiffFlags s) = StringContent s getContent (OnePattern _) = NoContent -- FIXME!!! getContent (SeveralPattern _) = NoContent -- FIXME!!!@@ -555,6 +558,7 @@   askLongComment, matchOneNontag, changesReverse, creatorhash,   changesFormat, matchOneContext, happyForwarding, sendToContext,   diffCmdFlag, storeInMemory, useExternalMerge,+  pauseForGui,   pullConflictOptions, target, ccSend, ccApply, applyConflictOptions, reply, xmloutput,   distnameOption, patchnameOption, editDescription,   output, outputAutoName, unidiff, repoCombinator,@@ -738,7 +742,7 @@                 [DarcsNoArgOption [] ["add"]                  NoAmendUnrecord "add the changes to patch (default)",                  DarcsNoArgOption [] ["unrecord"]-                 AmendUnrecord "substract the changes from patch"]+                 AmendUnrecord "subtract the changes from patch"]  ignoretimes =     DarcsMultipleChoiceOption@@ -818,7 +822,7 @@ -- from @_darcs/prefs@, and if it's not possible, ask the user. getAuthor :: [DarcsFlag] -> IO String getAuthor (Author a:_) = return a-getAuthor (Pipe:_) = do askUser "Who is the author? "+getAuthor (Pipe:_) = askUser "Who is the author? " getAuthor (_:flags) = getAuthor flags getAuthor [] = do   easy_author <- getEasyAuthor@@ -890,9 +894,9 @@            DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"] unified = DarcsMultipleChoiceOption           [DarcsNoArgOption ['u'] ["unified"] Unified-          "output patch in a darcs-specific format similar to diff -u",+          "output changes in a darcs-specific format similar to diff -u",            DarcsNoArgOption  [] ["no-unified"] NonUnified-          "output patch in darcs' usual format"]+          "output changes in darcs' usual format"]  unidiff = DarcsMultipleChoiceOption           [DarcsNoArgOption ['u'] ["unified"] Unified@@ -903,6 +907,19 @@ diffCmdFlag = DarcsSingleOption $   DarcsArgOption [] ["diff-command"] DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)" +pauseForGui = DarcsMultipleChoiceOption+    [ DarcsNoArgOption+        []+        ["pause-for-gui"]+        PauseForGui+        "pause for an external diff or merge command to finish [DEFAULT]"+    , DarcsNoArgOption+        []+        ["no-pause-for-gui"]+        NoPauseForGui+        "return immediately after external diff or merge command finishes"+    ]+ storeInMemory = DarcsMultipleChoiceOption     [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory      "do patch application in memory rather than on disk",@@ -1110,7 +1127,7 @@        DarcsNoArgOption [] ["allow-conflicts"]        AllowConflicts "allow conflicts, but don't mark them",        DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]-       NoAllowConflicts "fail if there patches that would create conflicts",+       NoAllowConflicts "fail if there are patches that would create conflicts",        DarcsNoArgOption [] ["skip-conflicts"]        SkipConflicts "filter out any patches that would create conflicts"       ]

@@ -6,7 +6,7 @@ import Darcs.External (getTermNColors) import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),                 invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,-                unsafeText, unsafeChar, space, unsafePackedString,+                unsafeText, unsafePackedString,                 renderStringWith, prefix ) import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr ) import Data.Bits ( bit, xor )

@@ -15,88 +15,115 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.Commands.Add ( add, expandDirs ) where+-- |+-- Module      : Darcs.Commands.Add+-- Copyright   : 2002-2004 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable -import Data.List ( (\\), nub)-import Data.Maybe( isNothing )+module Darcs.Commands.Add+    (+      add+    , expandDirs+    ) where+++#include "gadts.h"+#include "impossible.h"++ import Control.Monad ( when, unless, liftM )-import Storage.Hashed.Tree( Tree, findTree, expand )-import Storage.Hashed.AnchoredPath( floatPath, anchorPath, parents )+import Data.List ( (\\), nub )+import Data.Maybe ( isNothing, maybeToList )+import Printer ( text )+import Storage.Hashed.Tree ( Tree, findTree, expand )+import Storage.Hashed.AnchoredPath ( floatPath, anchorPath, parents )+import System.FilePath.Posix ( takeDirectory, (</>) )+import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )+import System.Directory ( getPermissions, readable ) -import Darcs.Commands(DarcsCommand(..), putVerbose, putWarning, nodefaults)-import Darcs.Arguments (noskipBoring, allowProblematicFilenames,-                       recursive, workingRepoDir, dryRunNoxml, umaskOption,-                       listFiles, listUnregisteredFiles,-                        DarcsFlag ( Recursive, DryRun, Verbose, Quiet),-                        fixSubPaths,+import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.Arguments (  noskipBoring, allowProblematicFilenames,+                          recursive, workingRepoDir, dryRunNoxml, umaskOption,+                          listFiles, listUnregisteredFiles,+                          DarcsFlag ( Recursive, DryRun, Verbose, Quiet ),+                          fixSubPaths,                       )-import Darcs.Flags( includeBoring, doAllowCaseOnly, doAllowWindowsReserved,)-import Darcs.Utils ( withCurrentDirectory, nubsort )-import Darcs.Repository.State( readRecordedAndPending )-import Darcs.Repository ( amInHashedRepository, withRepoLock, RepoJob(..), addToPending )+import Darcs.Commands ( DarcsCommand(..), putVerbose, putWarning, nodefaults)+import Darcs.Flags ( includeBoring, doAllowCaseOnly, doAllowWindowsReserved ) import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), nullFL )-import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )-import Darcs.Utils ( treeHas, treeHasDir, treeHasAnycase, getFileStatus ) import Darcs.RepoPath ( SubPath, toFilePath, simpleSubPath, toPath )+import Darcs.Repository.State ( readRecordedAndPending )+import Darcs.Repository ( amInHashedRepository, withRepoLock, RepoJob(..), addToPending ) import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )-import Data.Maybe ( maybeToList )-import System.FilePath.Posix ( takeDirectory, (</>) )-import qualified System.FilePath.Windows as WindowsFilePath-import System.Posix.Files( isRegularFile, isDirectory, isSymbolicLink )-import System.Directory ( getPermissions, readable )-import Printer( text )+import Darcs.Utils ( treeHas, treeHasDir, treeHasAnycase, getFileStatus, withCurrentDirectory, nubsort )+import Darcs.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft ) -#include "gadts.h"-#include "impossible.h"  addDescription :: String addDescription = "Add one or more new files or directories." + addHelp :: String addHelp =- "Generally a repository contains both files that should be version\n" ++- "controlled (such as source code) and files that Darcs should ignore\n" ++- "(such as executables compiled from the source code).  The `darcs add'\n" ++- "command is used to tell Darcs which files to version control.\n" ++- "\n" ++- "When an existing project is first imported into a Darcs repository, it\n" ++- "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++- "initial source files into darcs.\n"++- "\n" ++- "Adding symbolic links (symlinks) is not supported.\n\n"+    "Generally a repository contains both files that should be version\n" +++    "controlled (such as source code) and files that Darcs should ignore\n" +++    "(such as executables compiled from the source code).  The `darcs add'\n" +++    "command is used to tell Darcs which files to version control.\n" +++    "\n" +++    "When an existing project is first imported into a Darcs repository, it\n" +++    "is common to run `darcs add -r *' or `darcs record -l' to add all\n" +++    "initial source files into darcs.\n"+++    "\n" +++    "Adding symbolic links (symlinks) is not supported.\n\n" -add :: DarcsCommand-add = DarcsCommand {commandProgramName = "darcs",-                    commandName = "add",-                    commandHelp = addHelp ++ addHelp',-                    commandDescription = addDescription,-                    commandExtraArgs = -1,-                    commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],-                    commandCommand = addCmd,-                    commandPrereq = amInHashedRepository,-                    commandGetArgPossibilities = listUnregisteredFiles,-                    commandArgdefaults = nodefaults,-                    commandAdvancedOptions = [umaskOption],-                    commandBasicOptions =-                    [noskipBoring, allowProblematicFilenames,-                     recursive "add contents of subdirectories",-                     workingRepoDir, dryRunNoxml]}  addHelp' :: String addHelp' =- "Darcs will ignore all files and folders that look `boring'.  The\n" ++- "--boring option overrides this behaviour.\n" ++- "\n" ++- "Darcs will not add file if another file in the same folder has the\n" ++- "same name, except for case.  The --case-ok option overrides this\n" ++- "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++- "files a folder to have the same name except for case (for example,\n" ++- "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" ++- "unusable on those systems!\n\n"+    "Darcs will ignore all files and folders that look `boring'.  The\n" +++    "--boring option overrides this behaviour.\n" +++    "\n" +++    "Darcs will not add file if another file in the same folder has the\n" +++    "same name, except for case.  The --case-ok option overrides this\n" +++    "behaviour.  Windows and OS X usually use filesystems that do not allow\n" +++    "files a folder to have the same name except for case (for example,\n" +++    "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" +++    "unusable on those systems!\n\n" -addCmd :: [DarcsFlag] -> [String] -> IO ()++add :: DarcsCommand+add = DarcsCommand+    {+      commandProgramName          = "darcs"+    , commandName                 = "add"+    , commandHelp                 = addHelp ++ addHelp'+    , commandDescription          = addDescription+    , commandExtraArgs            = -1+    , commandExtraArgHelp         = [ "<FILE or DIRECTORY> ..." ]+    , commandCommand              = addCmd+    , commandPrereq               = amInHashedRepository+    , commandGetArgPossibilities  = listUnregisteredFiles+    , commandArgdefaults          = nodefaults+    , commandAdvancedOptions      = [umaskOption]+    , commandBasicOptions =+        [+          noskipBoring+        , allowProblematicFilenames+        , recursive "add contents of subdirectories"+        , workingRepoDir+        , dryRunNoxml+        ]+    }+++addCmd :: [DarcsFlag]+       -> [String]+       -> IO () addCmd opts args   | null args = putStrLn $ "Nothing specified, nothing added." ++       "Maybe you wanted to say `darcs add --recursive .'?"@@ -106,9 +133,12 @@         [] -> fail "No valid arguments were given"         _ -> addFiles opts fs -addFiles :: [DarcsFlag] -> [SubPath] -> IO ()-addFiles opts origfiles = withRepoLock opts $ RepoJob $ \repository ->- do -- TODO do not expand here, and use findM/findIO or such later++addFiles :: [DarcsFlag]  -- ^ Command options+         -> [SubPath]+         -> IO ()+addFiles opts origfiles = withRepoLock opts $ RepoJob $ \repository -> do+    -- TODO do not expand here, and use findM/findIO or such later     -- (needs adding to hashed-storage first though)     cur <- expand =<< readRecordedAndPending repository     let parlist = getParents cur (map toFilePath origfiles)@@ -122,18 +152,24 @@                else boringFileFilter     let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts     mapM_ (putWarning fixedOpts . text . ((msgSkipping msgs ++ " boring file ")++)) $-      flist \\ nboring flist+        flist \\ nboring flist     Sealed ps <- fmap unFreeLeft $ addp msgs fixedOpts cur $ nboring flist     when (nullFL ps && not (null origfiles) && not (Quiet `elem` opts)) $         fail "No files were added"     unless gotDryRun $ addToPending repository ps   where     gotDryRun = DryRun `elem` opts-    msgs | gotDryRun = dryRunMessages-         | otherwise = normalMessages+    msgs+        | gotDryRun = dryRunMessages+        | otherwise = normalMessages + addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)-     => AddMessages -> [DarcsFlag] -> Tree IO -> [FilePath] -> IO (FreeLeft (FL prim))+     => AddMessages+     -> [DarcsFlag]+     -> Tree IO+     -> [FilePath]+     -> IO (FreeLeft (FL prim)) addp msgs opts cur0 files = do     (ps, dups) <-         foldr@@ -154,116 +190,150 @@     unless (null dups) $ do        dupMsg <-          case uniq_dups of-         [f] ->-           do+         [f] -> do            isDir <- doesDirectoryReallyExist f            if isDir-               then return $-                 "The following directory "++msgIs msgs++" already in the repository"-               else return $-                 "The following file "++msgIs msgs++" already in the repository"-         fs   ->-           do+             then return $+               "The following directory " +++               msgIs msgs ++ " already in the repository"+             else return $+               "The following file " +++               msgIs msgs ++ " already in the repository"+         fs   -> do            areDirs <- mapM doesDirectoryReallyExist fs            if and areDirs-               then return $-                 "The following directories "++msgAre msgs++" already in the repository"-               else-                 (if or areDirs-                      then return $-                        "The following files and directories " ++-                        msgAre msgs ++ " already in the repository"-                      else return $-                        "The following files " ++ msgAre msgs ++ " already in the repository")+             then return $+               "The following directories " +++               msgAre msgs ++ " already in the repository"+             else+               (if or areDirs+                  then return $+                    "The following files and directories " +++                    msgAre msgs ++ " already in the repository"+                  else return $+                    "The following files " +++                    msgAre msgs ++ " already in the repository")        putWarning opts . text $ dupMsg ++ caseMsg        mapM_ (putWarning opts . text) uniq_dups     return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps- where-  addp' :: Tree IO -> FilePath -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)-  addp' cur f = do-    already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f-    mstatus <- getFileStatus f-    case (already_has, is_badfilename, mstatus) of-      (True, _, _) -> return (cur, Nothing, Just f)-      (_, True, _) ->-        do putWarning opts . text $-             "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."-           return add_failure-      (_, _, Just s) | isDirectory s    -> trypatch $ freeGap (adddir f :>: NilFL)-                     | isRegularFile s  -> trypatch $ freeGap (addfile f :>: NilFL)-                     | isSymbolicLink s -> do-                               putWarning opts . text $ "Sorry, file " ++ f ++-                                  " is a symbolic link, which is unsupported by darcs."-                               return add_failure-      _ -> do putWarning opts . text $ "File "++ f ++" does not exist!"-              return add_failure-      where is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)-            add_failure = (cur, Nothing, Nothing)-            trypatch :: FreeLeft (FL prim) -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)-            trypatch p = do perms <- getPermissions f-                            if not $ readable perms-                              then do-                                putWarning opts . text $-                                  msgSkipping msgs ++ " '" ++ f ++ "': permission denied "-                                return (cur, Nothing, Nothing)-                              else trypatch' p-            trypatch' p = do Sealed p' <- return $ unFreeLeft p-                             ok <- treeHasDir cur parentdir-                             if ok-                               then do-                                   tree <- applyToTree p' cur-                                   putVerbose opts . text $ msgAdding msgs++" '"++f++"'"-                                   return (tree, Just p, Nothing)-                               else do-                                   putWarning opts . text $ msgSkipping msgs ++ " '" ++ f ++ "' ... couldn't add parent directory '" ++ parentdir ++ "' to repository"-                                   return (cur, Nothing, Nothing)-                             `catch` \e -> do-                               putWarning opts . text $ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e-                               return (cur, Nothing, Nothing)-            parentdir = takeDirectory f-  gotAllowCaseOnly = doAllowCaseOnly opts-  gotAllowWindowsReserved = doAllowWindowsReserved opts+  where+    addp' :: Tree IO+          -> FilePath+          -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+    addp' cur f = do+      already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f+      mstatus <- getFileStatus f+      case (already_has, is_badfilename, mstatus) of+        (True, _, _) -> return (cur, Nothing, Just f)+        (_, True, _) -> do+            putWarning opts . text $+              "The filename " ++ f ++ " is invalid under Windows.\n" +++              "Use --reserved-ok to allow it."+            return add_failure+        (_, _, Just s)+            | isDirectory s    -> trypatch $ freeGap (adddir f :>: NilFL)+            | isRegularFile s  -> trypatch $ freeGap (addfile f :>: NilFL)+            | isSymbolicLink s -> do+                putWarning opts . text $+                    "Sorry, file " ++ f +++                    " is a symbolic link, which is unsupported by darcs."+                return add_failure+        _ -> do+            putWarning opts . text $ "File "++ f ++" does not exist!"+            return add_failure+        where+          is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)+          add_failure = (cur, Nothing, Nothing)+          trypatch :: FreeLeft (FL prim)+                   -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+          trypatch p = do+              perms <- getPermissions f+              if not $ readable perms+                then do+                    putWarning opts . text $+                        msgSkipping msgs ++ " '" ++ f ++ "': permission denied "+                    return (cur, Nothing, Nothing)+                else trypatch' p+          trypatch' p = do+              Sealed p' <- return $ unFreeLeft p+              ok <- treeHasDir cur parentdir+              if ok+                then do+                    tree <- applyToTree p' cur+                    putVerbose opts . text $+                        msgAdding msgs ++ " '" ++ f ++ "'"+                    return (tree, Just p, Nothing)+                else do+                    putWarning opts . text $+                        msgSkipping msgs ++ " '" ++ f +++                            "' ... couldn't add parent directory '" +++                            parentdir ++ "' to repository"+                    return (cur, Nothing, Nothing)+              `catch` \e -> do+                  putWarning opts . text $+                      msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e+                  return (cur, Nothing, Nothing)+          parentdir = takeDirectory f+    gotAllowCaseOnly = doAllowCaseOnly opts+    gotAllowWindowsReserved = doAllowWindowsReserved opts -doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f =-  maybe False isDirectory `fmap` getFileStatus f -data AddMessages =-    AddMessages-    { msgSkipping  :: String+data AddMessages = AddMessages+    {+      msgSkipping  :: String     , msgAdding    :: String     , msgIs        :: String     , msgAre       :: String     } -normalMessages, dryRunMessages :: AddMessages-normalMessages =-    AddMessages-    { msgSkipping  = "Skipping"++normalMessages :: AddMessages+normalMessages = AddMessages+    {+      msgSkipping  = "Skipping"     , msgAdding    = "Adding"     , msgIs        = "is"     , msgAre       = "are"     }-dryRunMessages =-    AddMessages-    { msgSkipping  = "Would skip"+++dryRunMessages :: AddMessages+dryRunMessages = AddMessages+    {+      msgSkipping  = "Would skip"     , msgAdding    = "Would add"     , msgIs        = "would be"     , msgAre       = "would be"     } -expandDirs :: [SubPath] -> IO [SubPath]-expandDirs fs = liftM (map (fromJust . simpleSubPath)) (concat `fmap` mapM (expandOne . toPath) fs) -expandOne :: FilePath -> IO [FilePath]+doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f+++expandDirs :: [SubPath]+           -> IO [SubPath]+expandDirs fs =+    liftM (map (fromJust . simpleSubPath)) $+      concat `fmap` mapM (expandOne . toPath) fs+++expandOne :: FilePath+          -> IO [FilePath] expandOne "" = listFiles expandOne f = do-  isdir <- doesDirectoryReallyExist f-  if not isdir then return [f]-     else do fs <- withCurrentDirectory f listFiles-             return $ f: map (f </>) fs+    isdir <- doesDirectoryReallyExist f+    if not isdir+      then return [f]+      else do+        fs <- withCurrentDirectory f listFiles+        return $ f: map (f </>) fs -getParents :: Tree IO -> [FilePath] -> [FilePath]++getParents :: Tree IO+           -> [FilePath]+           -> [FilePath] getParents cur = map (anchorPath "") . go . map floatPath-  where go fs = filter (isNothing . findTree cur) $ concatMap parents fs+  where+    go fs = filter (isNothing . findTree cur) $ concatMap parents fs 

@@ -15,142 +15,193 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.Commands.AmendRecord ( amendrecord ) where+-- |+-- Module      : Darcs.Commands.AmendRecord+-- Copyright   : 2004, 2007 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Commands.AmendRecord+    (+      amendrecord+    , amendunrecord+    ) where+++#include "gadts.h"+ import Data.Maybe ( isJust, isNothing )-import System.Directory ( removeFile )-import System.Exit ( ExitCode(..), exitWith )+import Data.List ( intersect ) import Control.Applicative ( (<$>) ) import Control.Monad ( when, unless )+import System.Directory ( removeFile )+import System.Exit ( ExitCode(..), exitWith ) +import Darcs.Arguments ( DarcsFlag ( All, AmendUnrecord, Unified ),+                         fixSubPaths, setEnvDarcsFiles,+                        allInteractive, ignoretimes,+                        askLongComment, askdeps, keepDate, author, patchnameOption,+                        leaveTestDir, nocompress, lookforadds,+                         workingRepoDir,+                        matchOneNontag, umaskOption,+                         test, listRegisteredFiles,+                        getEasyAuthor, setScriptsExecutableOption, amendUnrecord+                        , unified+                      )+import Darcs.Commands ( DarcsCommand(..), commandAlias, nodefaults )+import Darcs.Commands.Record ( getDate, getLog, askAboutDepends )+import Darcs.Commands.Util ( announceFiles ) import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,                                EditLongComment, PromptLongComment, KeepDate)                    , isInteractive                    , diffingOpts, compression, removeFromAmended ) import Darcs.Lock ( worldReadableTemp )-import Darcs.RepoPath ( toFilePath )+import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,+                     infopatch, getdeps, adddeps, effect, invertFL+                   )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,+                          PatchInfo, patchinfo, isInverted, isTag, invertName,+                        )+import Darcs.Patch.Prim ( canonizeFL )+import Darcs.Patch.Split ( primSplitter ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc )+import Darcs.RepoPath ( toFilePath, SubPath() ) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withGutsOf,                     tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,                     amInHashedRepository                         , invalidateIndex, unrecordedChanges                         , testTentative+                        , readRecorded                   ) import Darcs.Repository.Prefs ( globalPrefsDirDoc )-import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,-                     infopatch, getdeps, adddeps, effect, invertFL-                   )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Prim ( canonizeFL )-import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,-                          PatchInfo, patchinfo, isInverted, isTag, invertName,-                        )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL ) import Darcs.SelectChanges ( selectChanges, WhichChanges(..),                              selectionContextPrim,                              runSelection,                              withSelectedPatchFromRepo )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Commands.Record ( getDate, getLog, askAboutDepends )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Arguments ( DarcsFlag ( All ),-                         fixSubPaths, setEnvDarcsFiles,-                        allInteractive, ignoretimes,-                        askLongComment, askdeps, keepDate, author, patchnameOption,-                        leaveTestDir, nocompress, lookforadds,-                         workingRepoDir,-                        matchOneNontag, umaskOption,-                         test, listRegisteredFiles,-                        getEasyAuthor, setScriptsExecutableOption, amendUnrecord-                      ) import Darcs.Utils ( askUser, clarifyErrors, PromptConfig(..), promptChar )-import Darcs.RepoPath ( SubPath() )+import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL )+ import Printer ( putDocLn ) import Storage.Hashed.Tree( Tree )-#include "gadts.h" + amendrecordDescription :: String-amendrecordDescription =- "Improve a patch before it leaves your repository."+amendrecordDescription = "Improve a patch before it leaves your repository."   amendrecordHelp :: String amendrecordHelp =- "Amend-record updates a `draft' patch with additions or improvements,\n" ++- "resulting in a single `finished' patch.  This is better than recording\n" ++- "the additions and improvements as separate patches, because then\n" ++- "whenever the `draft' patch is copied between repositories, you would\n" ++- "need to make sure all the extra patches are copied, too.\n" ++- "\n" ++- "Do not copy draft patches between repositories, because a finished\n" ++- "patch cannot be copied into a repository that contains a draft of the\n" ++- "same patch.  If this has already happened, `darcs obliterate' can be\n" ++- "used to remove the draft patch.\n" ++- "\n" ++- -- FIXME: is the following still true in Darcs 2.1? --twb- "Do not run amend-record in repository that other developers can pull\n" ++- "from, because if they pull while an amend-record is in progress, their\n" ++- "repository may be corrupted.\n" ++- "\n" ++- "When recording a draft patch, it is a good idea to start the name with\n" ++- "`DRAFT:' so that other developers know it is not finished.  When\n" ++- "finished, remove it with `darcs amend-record --edit-long-comment'.\n" ++- "To change the patch name without starting an editor, use --patch-name.\n" ++- "\n" ++- "Like `darcs record', if you call amend-record with files as arguments,\n" ++- "you will only be asked about changes to those files.  So to amend a\n" ++- "patch to foo.c with improvements in bar.c, you would run:\n" ++- "\n" ++- "    darcs amend-record --match 'touch foo.c' bar.c\n" ++- "\n" ++- "It is usually a bad idea to amend another developer's patch.  To make\n" ++- "amend-record only ask about your own patches by default, you can add\n" ++- "something like `amend-record match David Roundy' to " ++ globalPrefsDirDoc ++ "defaults, \n" ++- "where `David Roundy' is your name.\n" +    "Amend-record updates a `draft' patch with additions or improvements,\n" +++    "resulting in a single `finished' patch.  This is better than recording\n" +++    "the additions and improvements as separate patches, because then\n" +++    "whenever the `draft' patch is copied between repositories, you would\n" +++    "need to make sure all the extra patches are copied, too.\n" +++    "\n" +++    "Do not copy draft patches between repositories, because a finished\n" +++    "patch cannot be copied into a repository that contains a draft of the\n" +++    "same patch.  If this has already happened, `darcs obliterate' can be\n" +++    "used to remove the draft patch.\n" +++    "\n" +++    -- FIXME: is the following still true in Darcs 2.1? --twb+    "Do not run amend-record in repository that other developers can pull\n" +++    "from, because if they pull while an amend-record is in progress, their\n" +++    "repository may be corrupted.\n" +++    "\n" +++    "When recording a draft patch, it is a good idea to start the name with\n" +++    "`DRAFT:' so that other developers know it is not finished.  When\n" +++    "finished, remove it with `darcs amend-record --edit-long-comment'.\n" +++    "To change the patch name without starting an editor, use --patch-name.\n" +++    "\n" +++    "Like `darcs record', if you call amend-record with files as arguments,\n" +++    "you will only be asked about changes to those files.  So to amend a\n" +++    "patch to foo.c with improvements in bar.c, you would run:\n" +++    "\n" +++    "    darcs amend-record --match 'touch foo.c' bar.c\n" +++    "\n" +++    "It is usually a bad idea to amend another developer's patch.  To make\n" +++    "amend-record only ask about your own patches by default, you can add\n" +++    "something like `amend-record match David Roundy' to " ++ globalPrefsDirDoc +++    "defaults, \n" +++    "where `David Roundy' is your name.\n" + amendrecord :: DarcsCommand-amendrecord = DarcsCommand {commandProgramName = "darcs",-                            commandName = "amend-record",-                            commandHelp = amendrecordHelp,-                            commandDescription = amendrecordDescription,-                            commandExtraArgs = -1,-                            commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                            commandCommand = amendrecordCmd,-                            commandPrereq = amInHashedRepository,-                            commandGetArgPossibilities = listRegisteredFiles,-                            commandArgdefaults = nodefaults,-                            commandAdvancedOptions = [nocompress, ignoretimes, umaskOption,-                                                        setScriptsExecutableOption],-                            commandBasicOptions = [matchOneNontag,-                                                   test,-                                                    leaveTestDir,-                                                    allInteractive,-                                                    author, patchnameOption, askdeps, askLongComment, keepDate,-                                                    lookforadds,-                                                    workingRepoDir, amendUnrecord]}+amendrecord = DarcsCommand+    {+      commandProgramName          = "darcs"+    , commandName                 = "amend-record"+    , commandHelp                 = amendrecordHelp+    , commandDescription          = amendrecordDescription+    , commandExtraArgs            = -1+    , commandExtraArgHelp         = ["[FILE or DIRECTORY]..."]+    , commandCommand              = amendrecordCmd+    , commandPrereq               = amInHashedRepository+    , commandGetArgPossibilities  = listRegisteredFiles+    , commandArgdefaults          = nodefaults+    , commandAdvancedOptions =+        [+          nocompress+        , ignoretimes+        , umaskOption+        , setScriptsExecutableOption+        ]+    , commandBasicOptions =+        [+          matchOneNontag+        , test+        , leaveTestDir+        , allInteractive+        , author+        , patchnameOption+        , askdeps+        , askLongComment+        , keepDate+        , lookforadds+        , workingRepoDir+        , amendUnrecord+        , unified+        ]+    } -amendrecordCmd :: [DarcsFlag] -> [String] -> IO ()-amendrecordCmd opts args = if null args-  then doAmendRecord opts Nothing-  else do++amendunrecord :: DarcsCommand+amendunrecord = (commandAlias "amend-unrecord" Nothing amendrecord)+    { commandCommand = \fs -> commandCommand amendrecord (AmendUnrecord : fs)+    , commandDescription = "Alias for `darcs " ++ commandName amendrecord +++      " --unrecord '.\n" +++      "This allows changes already recorded in the patch to be removed."+    }+++amendrecordCmd :: [DarcsFlag]+               -> [String]+               -> IO ()+amendrecordCmd opts [] = doAmendRecord opts Nothing+amendrecordCmd opts args = do     files <- fixSubPaths opts args     if null files       then fail "No valid arguments were given, nothing to do."       else doAmendRecord opts $ Just files + doAmendRecord :: [DarcsFlag] -> Maybe [SubPath] -> IO () doAmendRecord opts files =     withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do     withSelectedPatchFromRepo "amend" repository opts $ \ (_ :> oldp) -> do         announceFiles files "Amending changes in"             -- auxiliary function needed because the witness types differ for the isTag case+        pristine <- readRecorded repository         let go :: FORALL(u1) FL (PrimOf p) C(r u1) -> IO ()             go NilFL | not (hasEditMetadata opts) = putStrLn "No changes!"             go ch =               do let context = selectionContextPrim "add"-                                      (filter (==All) opts)+                                      (intersect [All,Unified] opts)                                       (Just primSplitter)                                       (map toFilePath <$> files)+                                      (Just pristine)                  (chosenPatches :> _) <- runSelection (selectChanges First ch) context                  addChangesToPatch opts repository oldp chosenPatches         if not (isTag (info oldp))@@ -158,9 +209,10 @@            then if removeFromAmended opts                    then do let sel = selectChanges Last (effect oldp)                                context = selectionContextPrim "unrecord"-                                             (filter (==All) opts)+                                             (intersect [All,Unified] opts)                                              (Just primSplitter)                                              (map toFilePath <$> files)+                                             (Just pristine)                            (_ :> chosenPrims) <- runSelection sel context                            let invPrims = reverseRL (invertFL chosenPrims)                            addChangesToPatch opts repository oldp invPrims@@ -179,88 +231,102 @@                              else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend-record)."                            go NilFL + addChangesToPatch :: forall p C(r u t x y) . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag] -> Repository p C(r u t) -> PatchInfoAnd p C(x t)-                  -> FL (PrimOf p) C(t y) -> IO ()+                  => [DarcsFlag]+                  -> Repository p C(r u t)+                  -> PatchInfoAnd p C(x t)+                  -> FL (PrimOf p) C(t y)+                  -> IO () addChangesToPatch opts repository oldp chs =-                  if (nullFL chs && not (hasEditMetadata opts))-                  then putStrLn "You don't want to record anything!"-                  else do-                       invalidateIndex repository-                       withGutsOf repository $ do-                         repository' <- tentativelyRemovePatches repository (compression opts)-                                                                 (oldp :>: NilFL)-                         (mlogf, newp) <- updatePatchHeader opts repository' oldp chs-                         setEnvDarcsFiles newp-                         repository'' <- tentativelyAddPatch repository' (compression opts) newp-                         let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf-                         rc <- testTentative repository-                         when (rc /= ExitSuccess) $ do-                             when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failmsg-                             putStrLn $ "Looks like you have a bad patch: '" ++ patchDesc newp ++ "'"-                             let prompt = "Shall I amend it anyway?"-                             yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-                             case yn of-                               'y' -> return ()-                               _ -> exitWith rc `clarifyErrors` failmsg-                         finalizeRepositoryChanges repository'' `clarifyErrors` failmsg-                         maybe (return ()) removeFile mlogf-                         putStrLn "Finished amending patch:"-                         putDocLn $ description newp+    if (nullFL chs && not (hasEditMetadata opts))+    then putStrLn "You don't want to record anything!"+    else do+         invalidateIndex repository+         withGutsOf repository $ do+           repository' <- tentativelyRemovePatches repository (compression opts)+                                                   (oldp :>: NilFL)+           (mlogf, newp) <- updatePatchHeader opts repository' oldp chs+           setEnvDarcsFiles newp+           repository'' <- tentativelyAddPatch repository' (compression opts) newp+           let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf+           rc <- testTentative repository+           when (rc /= ExitSuccess) $ do+               when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failmsg+               putStrLn $ "Looks like you have a bad patch: '" ++ patchDesc newp ++ "'"+               let prompt = "Shall I amend it anyway?"+               yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])+               case yn of+                 'y' -> return ()+                 _ -> exitWith rc `clarifyErrors` failmsg+           finalizeRepositoryChanges repository'' `clarifyErrors` failmsg+           maybe (return ()) removeFile mlogf+           putStrLn "Finished amending patch:"+           putDocLn $ description newp + updatePatchHeader :: forall p C(x y r u t) . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag] -> Repository p C(r u t)-                  -> PatchInfoAnd p C(t x) -> FL (PrimOf p) C(x y)+                  => [DarcsFlag]+                  -> Repository p C(r u t)+                  -> PatchInfoAnd p C(t x)+                  -> FL (PrimOf p) C(x y)                   -> IO (Maybe String, PatchInfoAnd p C(t y)) updatePatchHeader opts repository oldp chs = do -                       let newchs = canonizeFL (effect oldp +>+ chs)+    let newchs = canonizeFL (effect oldp +>+ chs) -                       let old_pdeps = getdeps $ hopefully oldp-                       newdeps <- if AskDeps `elem` opts-                                  then askAboutDepends repository newchs opts old_pdeps-                                  else return old_pdeps+    let old_pdeps = getdeps $ hopefully oldp+    newdeps <- if AskDeps `elem` opts+               then askAboutDepends repository newchs opts old_pdeps+               else return old_pdeps -                       let old_pinf = info oldp-                           prior    = (piName old_pinf, piLog old_pinf)-                           make_log = worldReadableTemp "darcs-amend-record"-                           old_author = piAuthor old_pinf-                       date <- if KeepDate `elem` opts then return (piDateString old_pinf) else getDate opts-                       warnIfHijacking opts old_author-                       (new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs-                       let new_author = case getAuthor opts of-                                        Just a  -> a-                                        Nothing -> piAuthor old_pinf-                           maybe_invert = if isInverted old_pinf then invertName else id-                       new_pinf <- maybe_invert `fmap` patchinfo date new_name-                                                                 new_author new_log+    let old_pinf = info oldp+        prior    = (piName old_pinf, piLog old_pinf)+        make_log = worldReadableTemp "darcs-amend-record"+        old_author = piAuthor old_pinf+    date <- if KeepDate `elem` opts then return (piDateString old_pinf) else getDate opts+    warnIfHijacking opts old_author+    (new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs+    let new_author = case getAuthor opts of+                     Just a  -> a+                     Nothing -> piAuthor old_pinf+        maybe_invert = if isInverted old_pinf then invertName else id+    new_pinf <- maybe_invert `fmap` patchinfo date new_name+                                              new_author new_log -                       let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)+    let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps) -                       return (mlogf, newp)+    return (mlogf, newp) -warnIfHijacking :: [DarcsFlag] -> String -> IO ()++warnIfHijacking :: [DarcsFlag]+                -> String+                -> IO () warnIfHijacking opts old_author = do-  authors_here <- getEasyAuthor-  let edit_author = isJust (getAuthor opts)-  unless (edit_author || any (== old_author) authors_here) $-    do yorn <- askUser $-        "You're not "++old_author ++"! Amend anyway? "-       case yorn of ('y':_) -> return ()-                    _       -> exitWith ExitSuccess+    authors_here <- getEasyAuthor+    let edit_author = isJust (getAuthor opts)+    unless (edit_author || any (== old_author) authors_here) $ do+      yorn <- askUser $+          "You're not " ++ old_author ++"! Amend anyway? "+      case yorn of ('y':_) -> return ()+                   _       -> exitWith ExitSuccess -hasEditMetadata :: [DarcsFlag] -> Bool-hasEditMetadata (Author _:_) = True-hasEditMetadata (LogFile _:_) = True-hasEditMetadata (PatchName _:_) = True-hasEditMetadata (EditLongComment:_) = True++hasEditMetadata :: [DarcsFlag]+                -> Bool+hasEditMetadata []                    = False+hasEditMetadata (Author _:_)          = True+hasEditMetadata (LogFile _:_)         = True+hasEditMetadata (PatchName _:_)       = True+hasEditMetadata (EditLongComment:_)   = True hasEditMetadata (PromptLongComment:_) = True-hasEditMetadata (AskDeps:_) = True-hasEditMetadata (_:fs) = hasEditMetadata fs-hasEditMetadata [] = False+hasEditMetadata (AskDeps:_)           = True+hasEditMetadata (_:fs)                = hasEditMetadata fs -getAuthor :: [DarcsFlag] -> Maybe String-getAuthor (Author a:_) = Just a-getAuthor (_:as) = getAuthor as-getAuthor []     = Nothing++getAuthor :: [DarcsFlag]+          -> Maybe String+getAuthor (Author a:_)  = Just a+getAuthor (_:as)        = getAuthor as+getAuthor []            = Nothing 

@@ -40,7 +40,7 @@ import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate ) import Data.ByteString.Lazy ( toChunks ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Patch.ApplyMonad( withFilePaths )+import Darcs.Patch.ApplyMonad( withFileNames ) import Darcs.Patch.FileName( fp2fn ) import System.FilePath( (</>) ) import Darcs.RepoPath( toFilePath )@@ -128,8 +128,9 @@   (Sealed patches, initial, path) <-     if haveNonrangeMatch opts        then do Sealed x <- getOnePatchset repository opts-               [path] <- return $ withFilePaths [fp2fn $ toFilePath origpath]-                                     (getNonrangeMatchS opts r)+               let fn = [fp2fn $ toFilePath origpath]+                   nonRangeMatch = getNonrangeMatchS opts r+                   (_, [path], _) = withFileNames Nothing fn nonRangeMatch                initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS opts r) recorded                return $ (seal $ newset2RL x, initial, toFilePath path)        else return $ (seal $ newset2RL r, recorded, toFilePath origpath)

@@ -29,21 +29,35 @@ import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Commands ( DarcsCommand(..), putVerbose ) import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All),-                         matchSeveral,-                         setEnvDarcsPatches,-                         getCc, workingRepoDir,-                        notest, nocompress, applyConflictOptions,-                        useExternalMerge,-                        ignoretimes, getSendmailCmd,-                        reply, verify, listFiles,-                        fixFilePathOrStd, umaskOption,-                        allInteractive, sendmailCmd,-                        leaveTestDir, happyForwarding,-                        dryRun, printDryRunMessageAndExit,-                        setScriptsExecutableOption, restrictPaths,-                        changesReverse, makeScriptsExecutable-                      )+import Darcs.Arguments+    ( DarcsFlag( All, Interactive, Reply )+    , allInteractive+    , applyConflictOptions+    , changesReverse+    , dryRun+    , fixFilePathOrStd+    , getCc+    , getSendmailCmd+    , happyForwarding+    , ignoretimes+    , leaveTestDir+    , listFiles+    , makeScriptsExecutable+    , matchSeveral+    , nocompress+    , notest+    , pauseForGui+    , printDryRunMessageAndExit+    , reply+    , restrictPaths+    , sendmailCmd+    , setEnvDarcsPatches+    , setScriptsExecutableOption+    , umaskOption+    , useExternalMerge+    , verify+    , workingRepoDir+    ) import Darcs.Flags(doHappyForwarding, doReverse, isInteractive)  import qualified Darcs.Arguments as DarcsArguments ( ccApply )@@ -133,12 +147,19 @@                       commandPrereq = amInHashedRepository,                       commandGetArgPossibilities = listFiles,                       commandArgdefaults = const stdindefault,-                      commandAdvancedOptions = [reply, DarcsArguments.ccApply,-                                                  happyForwarding,-                                                  sendmailCmd,-                                                  ignoretimes, nocompress,-                                                  setScriptsExecutableOption, umaskOption,-                                                  restrictPaths, changesReverse],+                      commandAdvancedOptions =+                        [ reply+                        , DarcsArguments.ccApply+                        , happyForwarding+                        , sendmailCmd+                        , ignoretimes+                        , nocompress+                        , setScriptsExecutableOption+                        , umaskOption+                        , restrictPaths+                        , changesReverse+                        , pauseForGui+                        ],                       commandBasicOptions = [verify,                                               allInteractive]++dryRun++                                               [matchSeveral,@@ -264,6 +285,13 @@  "A patch bundle may introduce unresolved conflicts with existing\n" ++  "patches or with the working tree.  By default, Darcs will add conflict\n" ++  "markers (see `darcs mark-conflicts').\n" +++ "\n" +++ "The --external-merge option lets you resolve these conflicts\n" +++ "using an external merge tool.  In the option, '%a' is replaced with\n" +++ "the common ancestor (merge base), '%1' with the first version, '%2'\n" +++ "with the second version, and '%o' with the path where your resolved\n" +++ "content should go.  For example, to use the xxdiff visual merge tool\n" +++ "you'd specify: --external-merge='xxdiff -m -O -M %o %1 %a %2'\n" ++  "\n" ++  "The --allow-conflicts option will skip conflict marking; this is\n" ++  "useful when you want to treat a repository as just a bunch of patches,\n" ++

@@ -23,9 +23,10 @@ import Prelude hiding ( log ) import Unsafe.Coerce (unsafeCoerce) -import Data.List ( intersect, sort, nub )+import Data.List ( intersect, sort, nub, find ) import Data.Maybe ( fromMaybe, fromJust, isJust )-import Control.Monad ( when, unless )+import Control.Arrow ( second )+import Control.Monad.State.Strict import Control.Applicative ((<$>))  import Darcs.Patch.PatchInfoAnd ( hopefullyM, info )@@ -55,8 +56,8 @@ import Darcs.Patch.Bundle( contextPatches ) import Darcs.Patch.TouchesFiles ( lookTouch ) import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, invert, xmlSummary, description, applyToFilepaths,-                     listTouchedFiles, effect )+import Darcs.Patch ( RepoPatch, invert, xmlSummary, description,+                     effectOnFilePaths, listTouchedFiles, effect ) import Darcs.Witnesses.Eq ( EqCheck(..) ) import Darcs.Witnesses.Ordered ( FL(NilFL), RL(..), filterFLFL, filterRL,                                  reverseFL, (:>)(..), mapRL )@@ -64,9 +65,8 @@                matchAPatchread, haveNonrangeMatch,                matchFirstPatchset, matchSecondPatchset,              )-import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),-                 renderString, prefix, text, vcat, vsep, (<>),-                 ($$), empty, errorDoc, insertBeforeLastline )+import Printer ( Doc, putDocLnWith, simplePrinters, (<+>), prefix, text, vcat,+                 vsep, (<>), ($$), errorDoc, insertBeforeLastline ) import Darcs.ColorPrinter ( fancyPrinters ) import Progress ( setProgressMode, debugMessage ) import Darcs.SelectChanges ( viewChanges )@@ -127,8 +127,10 @@     Nothing -> return $ Sealed NilFL     Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files                   `catch` \_ -> return (Sealed NilFL) -- this is triggered when repository is remote-  let filez = map (fn2fp . normPath . fp2fn) . applyToFilepaths (invert unrec) . map toFilePath <$> files-      filtered_changes p = maybe_reverse $ getChangesInfo opts filez p+  let normfp = fn2fp . normPath . fp2fn+      undoUnrecordedOnFPs = effectOnFilePaths (invert unrec)+      recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files+      filtered_changes p = maybe_reverse $ getChangesInfo opts recFiles p   debugMessage "About to read the repository..."   patches <- readRepo repository   debugMessage "Done reading the repository."@@ -137,7 +139,7 @@                 fp = map fst fp_and_fs             viewChanges opts fp     else do when (isJust files && not (XMLOutput `elem` opts)) $-                 putStrLn $ "Changes to "++unwords (fromJust filez)++":\n"+                 putStrLn $ "Changes to "++unwords (fromJust recFiles)++":\n"             debugMessage "About to print the changes..."             let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters             ps <- readRepo repository -- read repo again to prevent holding onto@@ -169,7 +171,9 @@  getChangesInfo :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe [FilePath]                -> PatchSet p C(x y)-               -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [FilePath], Doc)+               -> ( [(Sealed2 (PatchInfoAnd p), [FilePath])]+                  , [(FilePath, FilePath)]+                  , Maybe Doc ) getChangesInfo opts plain_fs ps =     case (sp1s, sp2s) of       (Sealed p1s, Sealed p2s) ->@@ -177,7 +181,7 @@             _ :> us ->               let ps' = filterRL pf (reverseFL us) in                 case plain_fs of-                  Nothing -> foldr (\x xs -> (x, []) -:- xs) ([], [], empty) $+                  Nothing -> foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $                     maybe id take (maxCount opts) ps'                   Just fs -> let fs' = map (\x -> "./" ++ x) fs in                     filterPatchesByNames (maxCount opts) fs' ps'@@ -191,31 +195,50 @@              then matchAPatchread opts              else \_ -> True --- | Take a list of filenames and patches and produce a list of--- patches that actually touch the given files with list of touched--- file names, a new file list that represents the same set of files--- as in input, before the returned patches would have been applied,--- and possibly an error. Additionaly, the function takes a "depth--- limit" -- maxcount, that could be Nothing (return everything) or--- "Just n" -- returns at most n patches touching the file (starting--- from the beginning of the patch list).+-- | Take a list of filenames and patches and produce a list of patches that+-- actually touch the given files with a list of touched file names, a list of+-- original-to-current filepath mappings, indicating the original names of the+-- affected files and possibly an error. Additionaly, the function takes a+-- "depth limit" -- maxcount, that could be Nothing (return everything) or+-- "Just n" -- returns at most n patches touching the file (starting from the+-- beginning of the patch list). filterPatchesByNames :: (RepoPatch p, ApplyState p ~ Tree) =>                            Maybe Int -- ^ maxcount                         -> [FilePath] -- ^ filenames                         -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist-                        -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [FilePath], Doc)-filterPatchesByNames (Just 0) _ _ = ([], [], empty)-filterPatchesByNames _ [] _ = ([], [], empty)-filterPatchesByNames _ _ [] = ([], [], empty)-filterPatchesByNames maxcount fs ((Sealed2 hp):ps)-    | Just p <- hopefullyM hp =-    case lookTouch fs (invert p) of-    (True, []) -> ([(Sealed2 hp, fs)], fs, empty)-    (True, fs') -> (Sealed2 hp, fs) -:- filterPatchesByNames-                                         (subtract 1 `fmap` maxcount) fs' ps-    (False, fs') -> filterPatchesByNames maxcount fs' ps-filterPatchesByNames _ _ ((Sealed2 hp):_) =-    ([], [], text "Can't find changes prior to:" $$ description hp)+                        -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)+filterPatchesByNames maxcount fns patches = removeNonRenames $+    evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where+        removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)+        removeIds = filter (\(a, b) -> a /= b)+        initRenames = map (\x -> (x, x)) fns+        returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd+        filterPatchesByNames' [] _ = returnFinal+        filterPatchesByNames' _ [] = returnFinal+        filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do+            (count, renames) <- get+            let stopNow = case count of+                                Nothing -> False+                                Just c -> c <= 0+            if stopNow+                then returnFinal+                else case hopefullyM hp of+                    Nothing -> do+                        let err = text "Can't find changes prior to:"+                                  $$ description hp+                        return ([], renames, Just err)+                    Just p ->+                        case lookTouch (Just renames) fs (invert p) of+                            (True, affected, [], renames') -> do+                                return ([(s2hp, affected)], renames', Nothing)+                            (True, affected, fs', renames') -> do+                                let sub1Mb c = (subtract 1) <$> c+                                modify $ \(c, _) -> (sub1Mb c, renames')+                                rest <- filterPatchesByNames' fs' ps+                                return $ (s2hp, affected) -:- rest+                            (False, _, fs', renames') -> do+                                modify $ second (const renames')+                                filterPatchesByNames' fs' ps  -- | Note, lazy pattern matching is required to make functions like -- filterPatchesByNames lazy in case you are only not interested in@@ -228,25 +251,22 @@ changelog :: forall p C(start x)            . (RepoPatch p, ApplyState p ~ Tree)           => [DarcsFlag] -> PatchSet p C(start x)-          -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [FilePath], Doc)+          -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)           -> Doc-changelog opts patchset (pis_and_fs, orig_fs, errstring)+changelog opts patchset (pis_and_fs, createdAsFs, mbErr)     | Count `elem` opts = text $ show $ length pis_and_fs     | MachineReadable `elem` opts =-        if renderString errstring == ""-        then vsep $ map (unseal2 (showPatchInfo.info)) pis-        else errorDoc errstring+        maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc mbErr     | XMLOutput `elem` opts =          text "<changelog>"-      $$ vcat xml_file_names+      $$ vcat created_as_xml       $$ vcat actual_xml_changes       $$ text "</changelog>"     | Summary `elem` opts || Verbose `elem`  opts =-           vsep (map (number_patch change_with_summary) pis_and_fs)-        $$ errstring-    | otherwise = vsep (map (number_patch description') pis_and_fs)-               $$ errstring-    where change_with_summary :: (Sealed2 (PatchInfoAnd p), [FilePath]) -> Doc+        mbAppendErr $ vsep (map (number_patch change_with_summary) pis_and_fs)+    | otherwise = mbAppendErr $ vsep (map (number_patch description') pis_and_fs)+    where mbAppendErr = maybe id (\err -> ($$ err)) mbErr+          change_with_summary :: (Sealed2 (PatchInfoAnd p), [FilePath]) -> Doc           change_with_summary (Sealed2 hp, fs)               | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts                                           then description hp $$ text "" $$@@ -268,10 +288,20 @@           actual_xml_changes = if Summary `elem` opts                                then map xml_with_summary pis                                else map (toXml . (unseal2 info)) pis-          xml_file_names = map (createdAsXml first_change) orig_fs-          first_change = if doReverse opts-                         then unseal2 info $ head pis-                         else unseal2 info $ last pis++          created_as_xml = map create createdAsFs where+            create rename@(_, as) = createdAsXml (first_change_of as) rename+            -- We need to reorder the patches when they haven't been reversed+            -- already, so that we find the *first* patch that modifies a given+            -- file, not the last (by default, the list is oldest->newest).+            reorderer = if not (doReverse opts) then reverse else id+            oldest_first_pis_and_fs = reorderer pis_and_fs+            couldnt_find fn = error $ "Couldn't find first patch affecting " +++                                      fn ++ " in pis_and_fs"+            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs+            find_first_change_of fn = fromMaybe (couldnt_find fn)+              (mb_first_change_of fn)+            first_change_of = unseal2 info . fst . find_first_change_of           number_patch f x = if NumberPatches `elem` opts                              then case get_number (fst x) of                                   Just n -> text (show n++":") <+> f x@@ -312,7 +342,7 @@   (_ :> ps') <- contextPatches `fmap` readRepo repository   let ps = mapRL (\p -> (seal2 p, [])) ps'   unless fancy $ putStrLn "\nContext:\n"-  putDocLnWith simplePrinters $ changelog opts' emptyset (ps, [], empty)+  putDocLnWith simplePrinters $ changelog opts' emptyset (ps, [], Nothing)     where opts' = if fancy then opts else MachineReadable : opts           fancy = HumanReadable `elem` opts || XMLOutput `elem` opts           emptyset = PatchSet NilRL NilRL@@ -320,9 +350,12 @@ log :: DarcsCommand log = commandAlias "log" Nothing changes -createdAsXml :: PatchInfo -> String -> Doc-createdAsXml pinfo as = text "<created_as original_name='"-                       <> escapeXML as-                       <> text "'>"-                    $$    toXml pinfo-                    $$    text "</created_as>"+createdAsXml :: PatchInfo -> (String, String) -> Doc+createdAsXml pinfo (current, createdAs) =+    text "<created_as current_name='"+       <> escapeXML current+       <> text "' original_name='"+       <> escapeXML createdAs+       <> text "'>"+    $$    toXml pinfo+    $$    text "</created_as>"

@@ -21,7 +21,7 @@  import System.FilePath.Posix ( takeFileName ) import Workaround ( getCurrentDirectory )-import Darcs.Utils ( askUser, withCurrentDirectory )+import Darcs.Utils ( askEnter, withCurrentDirectory ) import Control.Monad ( when ) import Data.List ( (\\) ) @@ -30,13 +30,18 @@ import Darcs.External( diffProgram ) import CommandLine ( parseCmd ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(DiffFlags, DiffCmd,-                                   LastN, AfterPatch),-                        matchRange, storeInMemory,-                        diffCmdFlag, diffflags, unidiff,-                         workingRepoDir, fixSubPaths,-                      )-import Darcs.Flags ( isNotUnified )+import Darcs.Arguments+    ( DarcsFlag(AfterPatch, DiffCmd, DiffFlags, LastN)+    , diffCmdFlag+    , diffflags+    , fixSubPaths+    , matchRange+    , pauseForGui+    , storeInMemory+    , unidiff+    , workingRepoDir+    )+import Darcs.Flags ( isNotUnified, wantGuiPause ) import Darcs.Patch.PatchInfoAnd ( info ) import Darcs.RepoPath ( AbsolutePath, SubPath, toFilePath, sp2fn ) import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch,@@ -70,6 +75,7 @@  "the `darcs whatsnew' command, since it outputs a line-by-line diff,\n" ++  "and it is also slower.  As with `darcs whatsnew', if you specify\n" ++  "files or directories, changes to other files are not listed.\n" +++ "The command always uses an external diff utility.\n" ++  "\n" ++  "With the --patch option, the comparison will be made between working\n" ++  "trees with and without that patch.  Patches `after' the selected patch\n" ++@@ -105,11 +111,18 @@                              commandPrereq = amInHashedRepository,                              commandGetArgPossibilities = return [],                              commandArgdefaults = nodefaults,-                             commandAdvancedOptions = [],-                             commandBasicOptions = [matchRange,-                                                     diffCmdFlag,-                                                     diffflags, unidiff,-                                                     workingRepoDir, storeInMemory]}+                             commandAdvancedOptions =+                                [ pauseForGui+                                ],+                             commandBasicOptions =+                                [ matchRange+                                , diffCmdFlag+                                , diffflags+                                , unidiff+                                , workingRepoDir+                                , storeInMemory+                                ]+                           }  getDiffOpts :: [DarcsFlag] -> [String] getDiffOpts opts | isNotUnified opts = get_nonU_diff_opts opts@@ -118,11 +131,6 @@           get_nonU_diff_opts (_:fs) = get_nonU_diff_opts fs           get_nonU_diff_opts [] = [] -hasDiffCmdFlag :: [DarcsFlag] -> Bool-hasDiffCmdFlag (DiffCmd _:_) = True-hasDiffCmdFlag (_:t) = hasDiffCmdFlag t-hasDiffCmdFlag []  = 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 'diffProgram'.  Note that this potentially involves parsing the@@ -180,14 +188,12 @@             case getDiffCmdAndArgs cmd opts f1 f2 of              Left err -> fail err              Right (d_cmd, d_args) ->-              let other_diff = hasDiffCmdFlag opts in-              do when other_diff $ putStrLn $+              let pausingForGui = wantGuiPause opts in+              do when pausingForGui $ putStrLn $                    "Running command '" ++ unwords (d_cmd:d_args) ++ "'"                  output <- execPipeIgnoreError d_cmd d_args empty-                 when other_diff $ do--- Warning:  A do-notation statement discarded a result of type String.-                    _ <- askUser "Hit return to move on..."-                    return ()+                 when pausingForGui $+                    askEnter "Hit return to move on..."                  return output            withTempDirs :: String -> (AbsolutePath -> AbsolutePath -> IO a) -> IO a

@@ -15,98 +15,126 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -module Darcs.Commands.Dist ( dist ) where+-- |+-- Module      : Darcs.Commands.Dist+-- Copyright   : 2003 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Commands.Dist+    (+      dist+    ) where++import Prelude hiding ( writeFile )++import Data.ByteString.Lazy ( writeFile )+import Data.Char ( isAlphaNum )+import Control.Monad ( when ) import System.Directory ( setCurrentDirectory )-import Workaround ( getCurrentDirectory )-import System.Exit ( ExitCode(..), exitWith ) import System.Cmd ( system )+import System.Exit ( ExitCode(..), exitWith ) import System.FilePath.Posix ( takeFileName, (</>) )-import Data.Char ( isAlphaNum )-import Control.Monad ( when )++import Workaround ( getCurrentDirectory ) import Codec.Archive.Tar ( pack, write ) import Codec.Archive.Tar.Entry ( entryPath ) import Codec.Compression.GZip ( compress )-import Prelude hiding ( writeFile )-import Data.ByteString.Lazy ( writeFile ) -import Darcs.Commands ( DarcsCommand(..),-                        nodefaults ) import Darcs.Arguments ( DarcsFlag(Verbose, Quiet, DistName, SetScriptsExecutable), distnameOption,                          workingRepoDir, matchOne, storeInMemory,                          setScriptsExecutableOption )-import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch )-import Darcs.Repository ( amInHashedRepository, withRepoReadLock, RepoJob(..), --withRecorded,+import Darcs.Commands ( DarcsCommand(..), nodefaults )+import Darcs.Lock ( withTempDir )+import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch, firstMatch, getFirstMatch )+import Darcs.Repository ( amInHashedRepository, withRepoReadLock, RepoJob(..),                           setScriptsExecutable,                           createPartialsPristineDirectoryTree ) import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Lock ( withTempDir ) import Darcs.RepoPath ( AbsolutePath, toFilePath ) import Darcs.Utils ( withCurrentDirectory ) + distDescription :: String distDescription = "Create a distribution tarball." + distHelp :: String distHelp =- "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++- "the repository's root directory, containing the recorded state of the\n" ++- "working tree (unrecorded changes and the _darcs directory are\n" ++- "excluded).\n" ++- "\n" ++- "If a predist command is set (see `darcs setpref'), that command will\n" ++- "be run on the tarball contents prior to archiving.  For example,\n" ++- "autotools projects would set it to `autoconf && automake'.\n" ++- "\n" ++- "By default, the tarball (and the top-level directory within the\n" ++- "tarball) has the same name as the repository, but this can be\n" ++- "overridden with the --dist-name option.\n"+    "The `darcs dist' command creates a compressed archive (a `tarball') in\n" +++     "the repository's root directory, containing the recorded state of the\n" +++     "working tree (unrecorded changes and the _darcs directory are\n" +++     "excluded).\n" +++     "\n" +++     "If a predist command is set (see `darcs setpref'), that command will\n" +++     "be run on the tarball contents prior to archiving.  For example,\n" +++     "autotools projects would set it to `autoconf && automake'.\n" +++     "\n" +++     "By default, the tarball (and the top-level directory within the\n" +++     "tarball) has the same name as the repository, but this can be\n" +++     "overridden with the --dist-name option.\n" - -- FIXME: this is tedious and ugly.- {-- ++ "\n" ++- "Suppose you use a version numbering scheme `major.minor.patch', and\n" ++- "you tag each release `major.minor'.  You can then calculate the\n" ++- "version number by taking the newest tag and appending a dot and the\n" ++- "number of patches since that tag.  If you use the directory name as\n" ++- "the project name, you can make tarballs of the form name-version.tgz\n" ++- "using the following shell script:\n" ++- "\n" ++- "  major_minor=$(darcs show tags | head -1) &&\n" ++- "  patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" ++- "  version=$major_minor.$patch_level &&\n" ++- "  project=${PWD##*/} &&\n" ++- "  darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n"- -}+     -- FIXME: this is tedious and ugly.+     {-+     ++ "\n" +++     "Suppose you use a version numbering scheme `major.minor.patch', and\n" +++     "you tag each release `major.minor'.  You can then calculate the\n" +++     "version number by taking the newest tag and appending a dot and the\n" +++     "number of patches since that tag.  If you use the directory name as\n" +++     "the project name, you can make tarballs of the form name-version.tgz\n" +++     "using the following shell script:\n" +++     "\n" +++     "  major_minor=$(darcs show tags | head -1) &&\n" +++     "  patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" +++     "  version=$major_minor.$patch_level &&\n" +++     "  project=${PWD##*/} &&\n" +++     "  darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n"+     -} + dist :: DarcsCommand-dist = DarcsCommand {commandProgramName = "darcs",-                     commandName = "dist",-                     commandHelp = distHelp,-                     commandDescription = distDescription,-                     commandExtraArgs = 0,-                     commandExtraArgHelp = [],-                     commandCommand = distCmd,-                     commandPrereq = amInHashedRepository,-                     commandGetArgPossibilities = return [],-                     commandArgdefaults = nodefaults,-                     commandAdvancedOptions = [],-                     commandBasicOptions = [distnameOption,-                                              workingRepoDir,-                                              matchOne,-                                              setScriptsExecutableOption,-                                              storeInMemory]}+dist = DarcsCommand+    {+      commandProgramName = "darcs"+    , commandName = "dist"+    , commandHelp = distHelp+    , commandDescription = distDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = distCmd+    , commandPrereq = amInHashedRepository+    , commandGetArgPossibilities = return []+    , commandArgdefaults = nodefaults+    , commandAdvancedOptions = []+    , commandBasicOptions =+        [+          distnameOption+        , workingRepoDir+        , matchOne+        , setScriptsExecutableOption+        , storeInMemory+        ]+    } -distCmd :: [DarcsFlag] -> [String] -> IO ()++distCmd :: [DarcsFlag]+        -> [String]+        -> IO () distCmd opts _ = withRepoReadLock opts $ RepoJob $ \repository -> do-  distname <- getDistName opts-  predist <- getPrefval "predist"   formerdir <- getCurrentDirectory+  let distname = getDistName formerdir [x | DistName x <- opts]+  predist <- getPrefval "predist"   let resultfile = formerdir </> distname ++ ".tar.gz"   withTempDir "darcsdist" $ \tempdir -> do     setCurrentDirectory formerdir     withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do       if haveNonrangeMatch opts-        then withCurrentDirectory ddir $ getNonrangeMatch repository opts+        then+            if firstMatch opts+                then withCurrentDirectory ddir $ getFirstMatch repository opts+                else withCurrentDirectory ddir $ getNonrangeMatch repository opts         else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir)       ec <- case predist of Nothing -> return ExitSuccess                             Just pd -> system pd@@ -121,30 +149,24 @@               putStrLn "Dist aborted due to predist failure"               exitWith ec + -- | This function performs the actual distribution action itself. -- NB - it does /not/ perform the pre-dist, that should already -- have completed successfully before this is invoked. doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO () doDist opts tempdir ddir resultfile = do-  setCurrentDirectory (toFilePath tempdir)-  let safeddir = safename $ takeFileName $ toFilePath ddir-  entries <- pack "." [safeddir]-  when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries-  writeFile resultfile $ compress $ write entries-  when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile+    setCurrentDirectory (toFilePath tempdir)+    let safeddir = safename $ takeFileName $ toFilePath ddir+    entries <- pack "." [safeddir]+    when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries+    writeFile resultfile $ compress $ write entries+    when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile   where     safename n@(c:_) | isAlphaNum c  = n     safename n = "./" ++ n -guessRepoName :: IO String-guessRepoName = do-  pwd <- getCurrentDirectory-  if '/' `elem` pwd-     then return $ reverse $ takeWhile (/='/') $ reverse pwd-     else return "cantguessreponame" -getDistName :: [DarcsFlag] -> IO String-getDistName (DistName dn:_) = return dn-getDistName (_:fs) = getDistName fs-getDistName _ = guessRepoName+getDistName :: FilePath -> [String] -> FilePath+getDistName _ (dn:_) = dn+getDistName currentDirectory _ = takeFileName currentDirectory 

@@ -32,8 +32,7 @@ import Darcs.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort ) import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager ) import Data.Char ( isAlphaNum, toLower, toUpper )-import Data.List ( groupBy, isPrefixOf, partition, intercalate, nub )-import Data.Maybe ( isNothing, mapMaybe )+import Data.List ( groupBy, isPrefixOf, intercalate, nub ) import English ( andClauses ) import Printer (text, vcat, vsep, ($$)) import System.Exit ( ExitCode(..), exitWith )

@@ -33,7 +33,7 @@ import System.FilePath.Posix ( (</>), takeFileName ) import System.Directory ( renameDirectory ) import Workaround ( renameFile )-import Darcs.Repository.State ( readRecordedAndPending )+import Darcs.Repository.State ( readRecordedAndPending, readRecorded ) import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository, addToPending ) import Darcs.Witnesses.Ordered ( FL(..), toFL ) import Darcs.Witnesses.Sealed ( Sealed(..), unseal, freeGap, FreeLeft, unFreeLeft )@@ -109,17 +109,71 @@               [] -> fail "Nothing to move."               froms' -> moveFilesToDir opts froms' to' +data FileKind = Dir | File+              deriving (Show, Eq)++data FileStatus =+  Nonexistant+  | Unadded FileKind+  | Shadow FileKind -- ^ known to darcs, but absent in working copy+  | Known FileKind+  deriving Show++fileStatus :: Tree IO -> Tree IO -> Tree IO ->+              FilePath -> IO FileStatus+fileStatus work cur rec fp = do+  exists_in_cur <- treeHas cur fp+  exists_in_rec <- treeHas rec fp+  exists_in_work <- treeHas work fp+  case (exists_in_rec, exists_in_cur, exists_in_work) of+    (_, True, True) -> do+      isDirCur <- treeHasDir cur fp+      isDirWork <- treeHasDir work fp+      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp+      return . Known $ if isDirCur then Dir else File++    (_, False, True) -> do+      isDir <- treeHasDir work fp+      if isDir+        then return $ Unadded Dir+        else return $ Unadded File+    (False, False, False) -> return Nonexistant+    (_, _, False) -> do+      isDir <- treeHasDir cur fp+      if isDir+        then return $ Shadow Dir+        else return $ Shadow File++-- | Takes two filenames (as 'Subpath'), and tries to move the first+-- into/onto the second. Needs to guess what that means: renaming or moving+-- into a directory, and whether it is a post-hoc move. moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO () moveFile opts old new = withRepoLock opts $ RepoJob $ \repository -> do   work <- readPlainTree "."   cur <- readRecordedAndPending repository+  rec <- readRecorded repository   let old_fp = toFilePath old       new_fp = toFilePath new-  new_is_a_dir <- treeHasDir work new_fp-  old_is_a_dir <- treeHasDir cur old_fp-  if new_is_a_dir && not old_is_a_dir-   then moveToDir repository opts [old_fp] new_fp-   else do+  new_fs <- fileStatus work cur rec new_fp+  old_fs <- fileStatus work cur rec old_fp+  case (old_fs, new_fs) of+    (Nonexistant, _) -> fail $ old_fp ++ " is inexistant."+    (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."+    (Known _, Nonexistant) -> simpleMove repository opts cur work old_fp new_fp+    (Known _, Shadow _) -> simpleMove repository opts cur work old_fp new_fp+    (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."+    (Known _, Known Dir) -> moveToDir repository opts [old_fp] new_fp+    (Known _, Unadded Dir) -> fail $ new_fp ++ " is not known to darcs; please add it to the repository."+    (Known _, _) -> fail $ new_fp ++ " already exists."+    (Shadow k, Unadded k') | k == k' -> simpleMove repository opts cur work old_fp new_fp+    (Shadow _, Known Dir) -> moveToDir repository opts [old_fp] new_fp+    (Shadow k, _) -> fail $ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp ++ " : " +++                                          "did you already move it elsewhere?"++simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)+           -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath+           -> IO ()+simpleMove repository opts cur work old_fp new_fp = do     addpatch <- checkNewAndOldFilenames opts cur work (old_fp,new_fp)     withSignalsBlocked $ do       case unFreeLeft <$> addpatch of

@@ -26,20 +26,45 @@  import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo ) import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments ( DarcsFlag( Verbose, DryRun, MarkConflicts,-                                   Intersection, Complement, AllowConflicts,-                                   NoAllowConflicts, XMLOutput ),-                         nocompress, ignoretimes, setEnvDarcsPatches,-                         depsSel, pullConflictOptions, useExternalMerge,-                         matchSeveral, fixUrl,-                         allInteractive, repoCombinator,-                         printDryRunMessageAndExit,-                         test, dryRun,-                         setDefault, summary, workingRepoDir, remoteRepo,-                         setScriptsExecutableOption,-                         networkOptions, umaskOption, allowUnrelatedRepos, restrictPaths, changesReverse,-                         getOutput, output, makeScriptsExecutable-                      )+import Darcs.Arguments+    ( DarcsFlag+        ( AllowConflicts+        , Complement+        , DryRun+        , Intersection+        , MarkConflicts+        , NoAllowConflicts+        , Verbose+        , XMLOutput+        )+    , allInteractive+    , allowUnrelatedRepos+    , changesReverse+    , depsSel+    , dryRun+    , fixUrl+    , getOutput+    , ignoretimes+    , makeScriptsExecutable+    , matchSeveral+    , networkOptions+    , nocompress+    , output+    , pauseForGui+    , printDryRunMessageAndExit+    , pullConflictOptions+    , remoteRepo+    , repoCombinator+    , restrictPaths+    , setDefault+    , setEnvDarcsPatches+    , setScriptsExecutableOption+    , summary+    , test+    , umaskOption+    , useExternalMerge+    , workingRepoDir+    ) import Darcs.Flags( doReverse, isInteractive ) import Darcs.Repository ( Repository, identifyRepositoryFor, withGutsOf,                           amInHashedRepository, withRepoLock, RepoJob(..),@@ -96,7 +121,9 @@  "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"+ "recently either pushed or pulled.\n" +++ "\n" +++ "See 'darcs help apply' for detailed description of many options.\n"  fetchHelp :: String fetchHelp =@@ -123,9 +150,10 @@          commandPrereq = amInHashedRepository,          commandGetArgPossibilities = getPreflist "repos",          commandArgdefaults = defaultrepo,-         commandAdvancedOptions = [repoCombinator,-                                     remoteRepo] ++-                                    networkOptions,+         commandAdvancedOptions =+            [ repoCombinator+            , remoteRepo+            ] ++ networkOptions,          commandBasicOptions = [matchSeveral,                                   allInteractive]                                  ++dryRun++@@ -147,16 +175,17 @@                      commandPrereq = amInHashedRepository,                      commandGetArgPossibilities = getPreflist "repos",                      commandArgdefaults = defaultrepo,-                     commandAdvancedOptions = [repoCombinator,-                                                 nocompress,-                                                 ignoretimes,-                                                 remoteRepo,-                                                 setScriptsExecutableOption,-                                                 umaskOption,-                                                 restrictPaths,-                                                 changesReverse-                                                ] ++-                                                networkOptions,+                     commandAdvancedOptions =+                        [ repoCombinator+                        , nocompress+                        , ignoretimes+                        , remoteRepo+                        , setScriptsExecutableOption+                        , umaskOption+                        , restrictPaths+                        , changesReverse+                        , pauseForGui+                        ] ++ networkOptions,                      commandBasicOptions = [matchSeveral,                                               allInteractive,                                               pullConflictOptions,

@@ -39,7 +39,7 @@                     readTentativeRepo,                     tentativelyAddPatch, finalizeRepositoryChanges                         , testTentative-                        , invalidateIndex, unrecordedChanges )+                        , invalidateIndex, unrecordedChanges, readRecorded ) import Darcs.Patch ( RepoPatch, Patchy, PrimOf, PrimPatch, namepatch, summaryFL, anonymous,                      adddeps, fromPrims ) import Darcs.Patch.Set ( PatchSet(..) )@@ -60,7 +60,7 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub ) import Darcs.Commands.Util ( announceFiles, filterExistingFiles ) import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,-                                    EditLongComment, LogFile, Pipe,+                                    EditLongComment, LogFile, Pipe, Quiet,                                     PatchName, AskDeps, All ),                          fileHelpAuthor,                          getAuthor, workingRepoDir, lookforadds,@@ -69,7 +69,8 @@                          allPipeInteractive, leaveTestDir, test,                          author, patchnameOption, umaskOption, ignoretimes,                          nocompress, rmlogfile, logfile, listRegisteredFiles,-                         setScriptsExecutableOption )+                         setScriptsExecutableOption+                         , unified ) import Darcs.Flags (willRemoveLogFile, diffingOpts, compression, isInteractive) import Darcs.Utils ( askUser, promptYorn, PromptConfig(..), promptChar, editFile, clarifyErrors ) import Progress ( debugMessage)@@ -115,7 +116,7 @@                                                askdeps,                                                askLongComment,                                                lookforadds,-                                               workingRepoDir]}+                                               workingRepoDir, unified]}  commitDescription :: String commitDescription = "Redirect the user to record, push or send."@@ -150,6 +151,7 @@       Nothing -> do when (Pipe `elem` opts) $ do _ <- getDate opts                                                  return ()                     putStrLn "No changes!"+                    exitFailure       Just ch -> doRecord repository opts existing_files ch     where allow_empty_with_askdeps :: FL p C(x y) -> Maybe (FL p C(x y))           allow_empty_with_askdeps NilFL@@ -180,9 +182,11 @@     my_author <- getAuthor opts     debugMessage "I'm slurping the repository."     debugMessage "About to select changes..."+    pristine <- readRecorded repository     (chs :> _ ) <- runSelection (selectChanges First ps) $                   selectionContextPrim "record" opts (Just primSplitter)                                        (map toFilePath <$> files)+                                       (Just pristine)     when (is_empty_but_not_askdeps chs) $               do putStrLn "Ok, if you don't want to record anything, that's fine!"                  exitWith ExitSuccess@@ -228,7 +232,8 @@                                     `clarifyErrors` failuremessage                  debugMessage "Syncing timestamps..."                  when (isJust logf) $ removeFile (fromJust logf)-                 putStrLn $ "Finished recording patch '"++name++"'"+                 when (Quiet `notElem` opts) $+                     putStrLn $ "Finished recording patch '"++name++"'"     where failuremessage = "Failed to record patch '"++name++"'" ++                            case logf of Just lf -> "\nLogfile left in "++lf++"."                                         Nothing -> ""@@ -415,5 +420,8 @@  "\n" ++  "If your test command is tediously slow (e.g. `make all') and you are\n" ++  "recording several patches in a row, you may wish to use --no-test to\n" ++- "skip all but the final test.\n"+ "skip all but the final test.\n" +++ "\n" +++ "To see some context (unchanged lines) around each change, use the\n" +++ "--unified option.\n" 

@@ -34,11 +34,11 @@                     applyToWorking,                     readUnrecorded, readRecordedAndPending                   )-import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace, applyToTree, fromPrim )+import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace, applyToTree ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileName( fn2fp ) import Darcs.Patch.Patchy ( Apply )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, mapFL_FL )+import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL ) import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..) ) import Darcs.Patch.RegChars ( regChars ) import Data.Char ( isSpace )@@ -202,7 +202,7 @@ -- a caret (@^@) is treated as a complementary set. isTok :: String -> String -> Bool isTok _ "" = False-isTok toks s = and $ map (regChars toks) s+isTok toks s = all (regChars toks) s  -- | This function checks for @--token-chars@ on the command-line.  If -- found, it validates the argument and returns it, without the

@@ -29,7 +29,7 @@                         ignoretimes, workingRepoDir,                         allInteractive,                         fixSubPaths,-                        listRegisteredFiles, umaskOption,+                        listRegisteredFiles, umaskOption, unified                       ) import Darcs.Utils ( askUser ) import Darcs.RepoPath ( toFilePath )@@ -39,7 +39,7 @@                     amInHashedRepository, readRecorded,                     unrecordedChanges                   )-import Darcs.Patch ( invert, applyToFilepaths, commute )+import Darcs.Patch ( invert, effectOnFilePaths, commute ) import Darcs.Patch.Split ( reversePrimSplitter ) import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) ) import Darcs.SelectChanges ( selectChanges, WhichChanges(Last), selectionContextPrim, runSelection )@@ -78,7 +78,7 @@                        commandGetArgPossibilities = listRegisteredFiles,                        commandArgdefaults = nodefaults,                        commandAdvancedOptions = [ignoretimes, umaskOption],-                       commandBasicOptions = [allInteractive,+                       commandBasicOptions = [allInteractive, unified,                                                workingRepoDir]}  revertCmd :: [DarcsFlag] -> [String] -> IO ()@@ -87,13 +87,13 @@     else Just . sort <$> fixSubPaths opts args   announceFiles files "Reverting changes in"   changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files-  let pre_changed_files = applyToFilepaths (invert changes) . map toFilePath <$> files+  let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files   rec <- readRecorded repository   Sealed touching_changes <- return (chooseTouching pre_changed_files changes)   (case touching_changes of     NilFL -> putStrLn "There are no changes to revert!"     _ -> do-      let context = selectionContextPrim "revert" opts (Just reversePrimSplitter) pre_changed_files+      let context = selectionContextPrim "revert" opts (Just reversePrimSplitter) pre_changed_files (Just rec)       (norevert:>p) <- runSelection (selectChanges Last changes) context       if nullFL p        then putStrLn $ "If you don't want to revert after all," ++

@@ -121,7 +121,7 @@   when (nullFL ps) $ do putStrLn "No patches selected!"                         exitWith ExitSuccess   setEnvDarcsPatches ps-  let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp+  let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp Nothing       hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)   runSelection (selectChanges Last hunks) hunks_context >>=                if (rollbackInWorkingDir opts)

@@ -0,0 +1,67 @@+--  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.++module Darcs.Commands.Test ( test ) where+import System.Exit ( exitWith )++import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )+import Darcs.Arguments ( DarcsFlag(Test)+                       , leaveTestDir+                       , workingRepoDir+                       )+import Darcs.Repository ( Repository, amInHashedRepository, withRepository,+                          testRecorded, RepoJob(..) )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Apply( ApplyState )+import Printer ( text )+import Storage.Hashed.Tree( Tree )++#include "gadts.h"++testDescription :: String+testDescription = "Run regression test."++testHelp :: String+testHelp =+ "If a regression test is defined (see `darcs setpref') it will be run.\n"++test :: DarcsCommand+test = DarcsCommand  {commandProgramName = "darcs",+                      commandName = "test",+                      commandHelp = testHelp,+                      commandDescription = testDescription,+                      commandExtraArgs = 0,+                      commandExtraArgHelp = [],+                      commandCommand = testCmd,+                      commandPrereq = amInHashedRepository,+                      commandGetArgPossibilities = return [],+                      commandArgdefaults = nodefaults,+                      commandAdvancedOptions = [],+                      commandBasicOptions = [ leaveTestDir,+                                              workingRepoDir+                                             ]}++testCmd :: [DarcsFlag] -> [String] -> IO ()+testCmd opts _ = withRepository (Test:opts) (RepoJob (test' opts))++test'+  :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag] -> Repository p C(r u t) -> IO ()+test' opts repository = do+    putInfo opts $ text "Running test on current repository state."+    rc <- testRecorded repository+    exitWith rc

@@ -27,7 +27,7 @@ import Darcs.Flags( diffingOpts ) import Darcs.Arguments ( DarcsFlag( MarkConflicts ),                          ignoretimes, workingRepoDir,-                        allInteractive, umaskOption,+                        allInteractive, umaskOption, unified                       ) import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),                           unrevertUrl, considerMergeToWorking,@@ -82,7 +82,8 @@                          commandAdvancedOptions = [umaskOption],                          commandBasicOptions = [ignoretimes,                                                   allInteractive,-                                                  workingRepoDir]}+                                                  workingRepoDir,+                                                  unified]}  unrevertCmd :: [DarcsFlag] -> [String] -> IO () unrevertCmd opts [] = withRepoLock opts $ RepoJob $ \repository -> do@@ -92,7 +93,7 @@   unrec <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing   Sealed h_them <- return $ mergeThem us them   Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) NilFL h_them-  let context = selectionContextPrim "unrevert" opts Nothing Nothing+  let context = selectionContextPrim "unrevert" opts Nothing Nothing (Just rec)   (p :> skipped) <- runSelection (selectChanges First pw) context   tentativelyAddToPending repository opts p   withSignalsBlocked $

@@ -19,39 +19,63 @@  #include "gadts.h" -module Darcs.Commands.WhatsNew ( whatsnew, status ) where-import System.Exit ( ExitCode(..), exitWith )-import Data.List ( sort, (\\) )-import Control.Monad ( when )+module Darcs.Commands.WhatsNew+    (+      whatsnew+    , status+    ) where+ import Control.Applicative ( (<$>) )+import Data.List ( delete )+import System.Exit ( ExitCode(..), exitWith ) +import Storage.Hashed.Tree( Tree )++import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,+                         ignoretimes, noskipBoring, unified, summary,+                         fixSubPaths, listRegisteredFiles ) import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias ) import Darcs.Commands.Util ( announceFiles )-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,-                        ignoretimes, noskipBoring,-                         unified, summary,-                         fixSubPaths,-                        listRegisteredFiles,-                      )+import Darcs.Diff( treeDiff ) import Darcs.Flags( isUnified, diffingOpts )-+import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, plainSummaryPrims,+                     primIsHunk, applyToTree )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Patchy ( Patchy )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.Prim.Class ( PrimDetails(..) )+import Darcs.Patch.TouchesFiles( choosePreTouching )+import Darcs.RepoPath( SubPath, toFilePath ) import Darcs.Repository ( Repository, withRepository, RepoJob(..)                         , amInRepository                         , unrecordedChanges, readRecorded ) import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, plainSummaryPrims, primIsHunk, applyToTree )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.TouchesFiles( choosePreTouching )-import Darcs.Patch.Permutations ( partitionRL )-import Darcs.RepoPath( SubPath, toFilePath ) import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..), nullFL )+import Darcs.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..) ) import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Darcs.Diff( treeDiff )-import Storage.Hashed.Tree( Tree )- import Printer ( putDocLn, renderString, vcat, text ) +whatsnew :: DarcsCommand+whatsnew = DarcsCommand { commandProgramName = "darcs"+                        , commandName = "whatsnew"+                        , commandHelp = whatsnewHelp+                        , commandDescription = whatsnewDescription+                        , commandExtraArgs = -1+                        , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+                        , commandCommand = whatsnewCmd+                        , commandPrereq = amInRepository+                        , commandGetArgPossibilities = listRegisteredFiles+                        , commandArgdefaults = nodefaults+                        , commandAdvancedOptions = [ignoretimes, noskipBoring]+                        , commandBasicOptions = [ summary+                                                , unified+                                                , lookforadds+                                                , workingRepoDir+                                                ]+                        }+ whatsnewDescription :: String whatsnewDescription = "List unrecorded changes in the working tree." @@ -71,6 +95,8 @@  "  `M f -N +M rP' means a modified file, with N lines deleted, M\n" ++  "  lines added, and P lexical replacements.\n" ++  "  `f -> g' means a moved file or directory.\n" +++ "  `a f' and `a d/' respectively mean a new, but unadded, file or\n" +++ "  directory, when using --look-for-adds.\n" ++  "\n" ++  "  An exclamation mark (!) as in `R! foo.c', means the hunk is known to\n" ++  "  conflict with a hunk in another patch.  The phrase `duplicated'\n" ++@@ -84,84 +110,84 @@  "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++  "there are no unrecorded changes.\n" -whatsnew :: DarcsCommand-whatsnew = DarcsCommand {commandProgramName = "darcs",-                         commandName = "whatsnew",-                         commandHelp = whatsnewHelp,-                         commandDescription = whatsnewDescription,-                         commandExtraArgs = -1,-                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                         commandCommand = whatsnewCmd,-                         commandPrereq = amInRepository,-                         commandGetArgPossibilities = listRegisteredFiles,-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [ignoretimes, noskipBoring],-                         commandBasicOptions = [summary, unified,-                                                 lookforadds,-                                                 workingRepoDir]}--filteredChanges :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-                => [DarcsFlag] -> Repository p C(r u t)-                -> Maybe [SubPath] -> IO (Sealed (FL (PrimOf p) C(t)))-filteredChanges opts repo files =-  choosePreTouching (map toFilePath <$> files) `fmap` unrecordedChanges (diffingOpts opts) repo files- whatsnewCmd :: [DarcsFlag] -> [String] -> IO ()-whatsnewCmd opts' args-  | LookForAdds `elem` opts' && NoSummary `notElem` opts' =-    -- add Summary to the opts since 'darcs whatsnew --look-for-adds'-    -- implies summary-    withRepository (Summary:opts')-                       $ RepoJob $ \(repository :: Repository p C(r u r)) -> do-    files <- if null args then return Nothing-        else Just <$> fixSubPaths opts' args+whatsnewCmd opts args =+   withRepository opts $ RepoJob $ \(repo :: Repository p C(r u t)) -> do+    files <- if null args+                 then return Nothing+                 else Just <$> fixSubPaths opts args+    let isLookForAdds = LookForAdds `elem` opts && NoSummary `notElem` opts+        -- LookForAdds implies Summary, unless it's explcitly disabled.+        optsModifier = if isLookForAdds+                           then (Summary :) . (LookForAdds `delete`)+                           else id+        opts' = optsModifier opts+    Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files+    pristine <- readRecorded repo+    -- If we are looking for adds, return the corresponding FL of changes.+    Sealed unaddedNewPathsPs <- if isLookForAdds+        then do+            -- Use opts not opts', here, since we *do* want to look for adds.+            Sealed lookChanges <- filteredUnrecordedChanges opts repo files+            noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine+            lookAddsTree <- applyAddPatchesToPristine lookChanges pristine+            ftf <- filetypeFunction+            -- Return the patches that create files/dirs that aren't yet added.+            unFreeLeft <$> treeDiff ftf noLookAddsTree lookAddsTree+        else return (Sealed NilFL)     announceFiles files "What's new in"-    Sealed all_changes <- filteredChanges opts' repository files-    Sealed chold <- filteredChanges (opts' \\ [LookForAdds]) repository files-    pristine <- readRecorded repository-    ftf <- filetypeFunction-    cho_adds :> _ <- return $ partitionRL primIsHunk $ reverseFL chold-    cha :> _ <- return $ partitionRL primIsHunk $ reverseFL all_changes+    exitOnNoChanges (unaddedNewPathsPs, noLookChanges)+    printChanges opts' pristine noLookChanges+    printUnaddedPaths unaddedNewPathsPs+  where+    -- |Filter out hunk patches (leaving add patches) and return the tree+    -- resulting from applying the filtered patches to the pristine tree.+    applyAddPatchesToPristine ps pristine = do+        adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps+        applyToTree (reverseRL adds) pristine -    cho_adds_t <- applyToTree (reverseRL cho_adds) pristine-    cha_t <- applyToTree (reverseRL cha) pristine-    Sealed chn <- unFreeLeft `fmap` treeDiff ftf cho_adds_t cha_t :: IO (Sealed (FL (PrimOf p) C(r)))+    exitOnNoChanges :: (FL p C(x y), FL p C(u v)) -> IO ()+    exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"+                                        exitWith $ ExitFailure 1+    exitOnNoChanges _ = return () -    exitOnNoChanges (chn, chold)-    putDocLn $ plainSummaryPrims 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 :: PrimPatch prim => FL prim C(x y) -> IO ()-          printSummary NilFL = return ()-          printSummary new = putDocLn $ lower_as $ renderString $ plainSummaryPrims new+    printUnaddedPaths :: PrimPatch p => FL p C(x y) -> IO ()+    printUnaddedPaths NilFL = return ()+    printUnaddedPaths ps =+        putDocLn . lowercaseAs . renderString . plainSummaryPrims $ ps -whatsnewCmd opts args-  | otherwise =-    withRepository opts $ RepoJob $ \repository -> do-    files <- if null args then return Nothing-        else Just . sort <$> fixSubPaths opts args-    announceFiles files "What's new in"-    Sealed changes <- filteredChanges opts repository files-    when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1)-    printSummary repository changes-       where printSummary :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-                          => Repository p C(r u t) -> FL (PrimOf p) C(r y) -> IO ()-             printSummary _ NilFL = do putStrLn "No changes!"-                                       exitWith $ ExitFailure 1-             printSummary r ch | Summary `elem` opts = putDocLn $ plainSummaryPrims ch-                               | isUnified opts = do pristine <- readRecorded r-                                                     contextualPrintPatch pristine ch-                               | otherwise           = printPatch ch+    -- Make any add markers lowercase, to distinguish new-but-unadded files+    -- from those that are unrecorded, but added.+    lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x+    lowercaseA ('A' : x) = 'a' : x+    lowercaseA x = x -status :: DarcsCommand-status = (commandAlias "status" Nothing whatsnew)-           { commandCommand = \fs -> commandCommand whatsnew (Summary : LookForAdds : fs)-           , commandDescription = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."-           }+    -- |Appropriately print changes, according to the passed flags.+    printChanges :: (PatchListFormat p, IsHunk p, Patchy p, PrimDetails p,+                 ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p C(x y)+                 -> IO ()+    printChanges opts' pristine changes+        | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes+        | isUnified opts' = contextualPrintPatch pristine changes+        | otherwise = printPatch changes +    -- |return the unrecorded changes that affect an optional list of paths.+    filteredUnrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree,+                              ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]+                              -> Repository p C(r u t) -> Maybe [SubPath]+                              -> IO (Sealed (FL (PrimOf p) C(t)))+    filteredUnrecordedChanges  opts' repo files =+        let filePaths = map toFilePath <$> files in+        let diffOpts = diffingOpts opts' in+        choosePreTouching filePaths <$> unrecordedChanges diffOpts repo files++-- |status is an alias for whatsnew, with implicit Summary and LookForAdds+-- flags. We override the default description, to include the implicit flags.+status :: DarcsCommand+status = statusAlias { commandCommand = statusCmd+                     , commandDescription = statusDesc+                     }+  where+    statusAlias = commandAlias "status" Nothing whatsnew+    statusCmd fs = commandCommand whatsnew (Summary : LookForAdds : fs)+    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."

@@ -20,87 +20,137 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Diff( treeDiff ) where-import Darcs.Witnesses.Ordered ( FL(..), (+>+) )-import Darcs.Witnesses.Sealed ( Gap(..) )-import Darcs.Repository.Prefs ( FileType(..) )-import Darcs.Patch ( PrimPatch, hunk, canonize, binary-                   , addfile, rmfile, adddir, rmdir, invert)+-- |+-- Module      : Darcs.Diff+-- Copyright   : 2009 Petr Rockai+-- License     : MIT+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable -import Storage.Hashed.Tree( diffTrees, zipTrees, TreeItem(..), Tree-                          , readBlob, emptyBlob )-import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath )+module Darcs.Diff+    (+      treeDiff+    ) where + import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL+ import Data.List ( sortBy )-import ByteStringUtils( isFunky ) +import Storage.Hashed.Tree  ( diffTrees+                            , zipTrees+                            , TreeItem(..)+                            , Tree+                            , readBlob+                            , emptyBlob+                            )+import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath )+++import ByteStringUtils ( isFunky )+import Darcs.Patch  ( PrimPatch+                    , hunk+                    , canonize+                    , binary+                    , addfile+                    , rmfile+                    , adddir+                    , rmdir+                    , invert+                    )+import Darcs.Repository.Prefs ( FileType(..) )+import Darcs.Witnesses.Ordered  ( FL(..)+                                , (+>+)+                                )+import Darcs.Witnesses.Sealed ( Gap(..) )++ #include "gadts.h" #include "impossible.h" -data Diff m = Added (TreeItem m) | Removed (TreeItem m) | Changed (TreeItem m) (TreeItem m) -getDiff :: AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (AnchoredPath, Diff m)+data Diff m = Added (TreeItem m)+            | Removed (TreeItem m)+            | Changed (TreeItem m) (TreeItem m)+++getDiff :: AnchoredPath+        -> Maybe (TreeItem m)+        -> Maybe (TreeItem m)+        -> (AnchoredPath, Diff m) getDiff p Nothing (Just t) = (p, Added t) getDiff p (Just from) (Just to) = (p, Changed from to) getDiff p (Just t) Nothing = (p, Removed t) getDiff _ Nothing Nothing = impossible -- zipTrees should never return this -treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim) => (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))++treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim)+         => (FilePath -> FileType)+         -> Tree m+         -> Tree m+         -> m (w (FL prim)) treeDiff ft t1 t2 = do-  (from, to) <- diffTrees t1 t2-  diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to-  return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs-    where-          -- sort into removes, changes, adds, with removes in reverse-path order-          -- and everything else in forward order-          organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering+    (from, to) <- diffTrees t1 t2+    diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to+    return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs+  where+    -- sort into removes, changes, adds, with removes in reverse-path order+    -- and everything else in forward order+    organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering -          organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2-          organise (p1, Added _)      (p2, Added _)   = compare p1 p2-          organise (p1, Removed _)    (p2, Removed _) = compare p2 p1+    organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2+    organise (p1, Added _)      (p2, Added _)   = compare p1 p2+    organise (p1, Removed _)    (p2, Removed _) = compare p2 p1 -          organise (_, Removed _) _ = LT-          organise _ (_, Removed _) = GT+    organise (_, Removed _) _ = LT+    organise _ (_, Removed _) = GT -          organise (_, Changed _ _) _ = LT-          organise _ (_, Changed _ _) = GT+    organise (_, Changed _ _) _ = LT+    organise _ (_, Changed _ _) = GT -          diff :: AnchoredPath -> Diff m -> m (w (FL prim))-          diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)-          diff p (Removed (SubTree _)) =-              return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)-          diff p (Added (SubTree _)) =-              return $ freeGap (adddir (anchorPath "" p) :>: NilFL)-          diff p (Added b'@(File _)) =-              do diff' <- diff p (Changed (File emptyBlob) b')-                 return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'-          diff p (Removed a'@(File _)) =-              do diff' <- diff p (Changed a' (File emptyBlob))-                 return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))-          diff p (Changed (File a') (File b')) =-              do a <- readBlob a'-                 b <- readBlob b'-                 let path = anchorPath "" p-                 case ft path of-                   TextFile | no_bin a && no_bin b ->-                                return $ text_diff path a b-                   _ -> return $ if a /= b-                                    then freeGap (binary path (strict a) (strict b) :>: NilFL)-                                    else emptyGap NilFL-          diff p _ = fail $ "Missing case at path " ++ show p-          text_diff p a b-              | BL.null a && BL.null b = emptyGap NilFL-              | BL.null a = freeGap (diff_from_empty p b)-              | BL.null b = freeGap (diff_to_empty p a)-              | otherwise = freeGap (line_diff p (linesB a) (linesB b))-          line_diff p a b = canonize (hunk p 1 a b)-          diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []-                            | otherwise = line_diff p (linesB x) [BS.empty]-          diff_from_empty p x = invert (diff_to_empty p x)-          no_bin = not . isFunky . strict . BL.take 4096-          linesB = map strict . BLC.split '\n'-          strict = BS.concat . BL.toChunks+    diff :: AnchoredPath -> Diff m -> m (w (FL prim))+    diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)+    diff p (Removed (SubTree _)) =+        return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)+    diff p (Added (SubTree _)) =+        return $ freeGap (adddir (anchorPath "" p) :>: NilFL)+    diff p (Added b'@(File _)) =+        do diff' <- diff p (Changed (File emptyBlob) b')+           return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'+    diff p (Removed a'@(File _)) =+        do diff' <- diff p (Changed a' (File emptyBlob))+           return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))+    diff p (Changed (File a') (File b')) =+        do a <- readBlob a'+           b <- readBlob b'+           let path = anchorPath "" p+           case ft path of+             TextFile | no_bin a && no_bin b ->+                          return $ text_diff path a b+             _ -> return $ if a /= b+                              then freeGap (binary path (strict a) (strict b) :>: NilFL)+                              else emptyGap NilFL+    diff p _ = fail $ "Missing case at path " ++ show p++    text_diff p a b+        | BL.null a && BL.null b = emptyGap NilFL+        | BL.null a = freeGap (diff_from_empty p b)+        | BL.null b = freeGap (diff_to_empty p a)+        | otherwise = freeGap (line_diff p (linesB a) (linesB b))++    line_diff p a b = canonize (hunk p 1 a b)++    diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []+                      | otherwise = line_diff p (linesB x) [BS.empty]++    diff_from_empty p x = invert (diff_to_empty p x)++    no_bin = not . isFunky . strict . BL.take 4096++    linesB = map strict . BLC.split '\n'++    strict = BS.concat . BL.toChunks 

@@ -47,8 +47,7 @@ import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability ) #endif import System.Posix.Files ( createLink )-import System.Directory ( createDirectoryIfMissing )-import System.FilePath.Posix ( (</>), takeDirectory, normalise )+import System.FilePath.Posix ( (</>), normalise )  import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL,                                 Verify, VerifySSL )@@ -124,8 +123,9 @@ backupBy backup f =            do hasBF <- doesFileExist f               hasBD <- doesDirectoryExist f-              when (hasBF || hasBD) $ helper (0::Int)+              when (hasBF || hasBD) $ helper 0   where+  helper :: Int -> IO ()   helper i = do existsF <- doesFileExist next                 existsD <- doesDirectoryExist next                 if (existsF || existsD)@@ -133,7 +133,7 @@                    else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"                            backup f next              where next = f ++ suffix-                   suffix = "-darcs-backup" ++ show i+                   suffix = ".~" ++ show i ++ "~"  copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a copyAndReadFile readfn fou _ | isFile fou = readfn fou@@ -212,7 +212,7 @@             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+     else if isRegularFile fs then         cloneFile source dest      else fail ("cloneSubTree: Bad source "++ source)     `catch` (\e -> if isDoesNotExistError e@@ -336,7 +336,7 @@   sendEmailDoc f cc s "" scmd mbundle body sendEmailDoc f t s cc scmd mbundle body = do   use_sendmail <- haveSendmail-  if use_sendmail || scmd /= "" then do+  if use_sendmail || scmd /= "" then     withOpenTemp $ \(h,fn) -> do       generateEmail h f t s cc body       hClose h@@ -383,7 +383,7 @@ resendEmail t scmd body = do   use_sendmail <- haveSendmail   if use_sendmail || scmd /= ""-   then do+   then     withOpenTemp $ \(h,fn) -> do      hPutStrLn h $ "To: "++ t      hPutStrLn h $ find_from (linesPS body)

@@ -15,21 +15,42 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Flags ( DarcsFlag( .. ),-                     Compression( .. ), UseIndex(..), ScanKnown(..), RemoteDarcs(..),-                     compression, remoteDarcs, diffingOpts,-                     wantExternalMerge, isInteractive,-                     maxCount, willIgnoreTimes, willRemoveLogFile, isUnified,-                     isNotUnified, doHappyForwarding, includeBoring,-                     doAllowCaseOnly, doAllowWindowsReserved, doReverse,-                     usePacks,-                     showChangesOnlyToFiles, rollbackInWorkingDir, removeFromAmended,-                     defaultFlag-                   ) where-import Data.Maybe( fromMaybe )+module Darcs.Flags+    ( DarcsFlag( .. )+    , Compression( .. )+    , UseIndex(..)+    , ScanKnown(..)+    , RemoteDarcs(..)+    , compression+    , remoteDarcs+    , diffingOpts+    , wantExternalMerge+    , wantGuiPause+    , isInteractive+    , maxCount+    , willIgnoreTimes+    , willRemoveLogFile+    , isUnified+    , isNotUnified+    , doHappyForwarding+    , includeBoring+    , doAllowCaseOnly+    , doAllowWindowsReserved+    , doReverse+    , usePacks+    , showChangesOnlyToFiles+    , rollbackInWorkingDir+    , removeFromAmended+    , defaultFlag+    ) where+++import Data.List ( find )+import Data.Maybe( fromMaybe, isJust ) 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@@ -77,6 +98,7 @@                | Pipe | Interactive                | DiffCmd String                | ExternalMerge String | Summary | NoSummary+               | PauseForGui | NoPauseForGui                | Unified | NonUnified | Reverse | Forward                | Complete | Lazy                | FixFilePath AbsolutePath AbsolutePath | DiffFlags String@@ -120,33 +142,66 @@ -- ADTs for selecting specific behaviour... FIXME These should be eventually -- moved out from this module, closer to where they are actually used -data Compression = NoCompression | GzipCompression-compression :: [DarcsFlag] -> Compression-compression f | NoCompress `elem` f = NoCompression-              | otherwise = GzipCompression+data Compression = NoCompression+                 | GzipCompression -remoteDarcs :: [DarcsFlag] -> RemoteDarcs-remoteDarcs f | (x:_) <- [ c | RemoteDarcsOpt c <- f ] = RemoteDarcs x-              | otherwise = DefaultRemoteDarcs+data UseIndex = UseIndex+              | IgnoreIndex -data UseIndex = UseIndex | IgnoreIndex data ScanKnown = ScanKnown -- ^Just files already known to darcs                | ScanAll -- ^All files, i.e. look for new ones                | ScanBoring -- ^All files, even boring ones-diffingOpts :: [DarcsFlag] -> (UseIndex, ScanKnown)-diffingOpts opts = (if willIgnoreTimes opts then IgnoreIndex else UseIndex,-                    if LookForAdds `elem` opts then -                      if Boring `elem` opts then ScanBoring else ScanAll-                      else ScanKnown) -data RemoteDarcs = RemoteDarcs String | DefaultRemoteDarcs+data RemoteDarcs = RemoteDarcs String+                 | DefaultRemoteDarcs ----------------------- +compression :: [DarcsFlag]+            -> Compression+compression f+    | NoCompress `elem` f = NoCompression+    | otherwise           = GzipCompression+++remoteDarcs :: [DarcsFlag]+            -> RemoteDarcs+remoteDarcs f+    | (x:_) <- [ c | RemoteDarcsOpt c <- f ] = RemoteDarcs x+    | otherwise = DefaultRemoteDarcs+++diffingOpts :: [DarcsFlag]+            -> (UseIndex, ScanKnown)+diffingOpts opts = (index, scan)+  where+    index = if willIgnoreTimes opts+            then IgnoreIndex+            else UseIndex+    scan =+        if LookForAdds `elem` opts+        then+          if Boring `elem` opts+          then ScanBoring+          else ScanAll+        else ScanKnown++ wantExternalMerge :: [DarcsFlag] -> Maybe String wantExternalMerge [] = Nothing wantExternalMerge (ExternalMerge c:_) = Just c wantExternalMerge (_:fs) = wantExternalMerge fs+++wantGuiPause :: [DarcsFlag] -> Bool+wantGuiPause fs = (hasDiffCmd || hasExternalMerge) && hasPause+  where+    hasDiffCmd = any isDiffCmd fs+    hasExternalMerge = isJust $ wantExternalMerge fs+    isDiffCmd (DiffCmd _) = True+    isDiffCmd _ = False+    hasPause = maybe True (==PauseForGui) $ find isPauseFlag $ reverse fs+    isPauseFlag f = (f==PauseForGui) || (f==NoPauseForGui)+  isInteractive :: [DarcsFlag] -> Bool isInteractive = isInteractive_ True

@@ -16,21 +16,47 @@ -- Boston, MA 02110-1301, USA.  {-# LANGUAGE CPP #-}--- | This was originally Tomasz Zielonka's AtExit module, slightly generalised++-- |+-- Module      : Darcs.Global+-- Copyright   : 2005 Tomasz Zielonka+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- 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, withAtexit,-                      SshSettings(..), defaultSsh,-                      timingsMode, setTimingsMode,-                      whenDebugMode, withDebugMode, setDebugMode,-                      debugMessage, debugFail, putTiming,-                      addCRCWarning, getCRCWarnings, resetCRCWarnings,-                      addBadSource, getBadSourcesList, isBadSource, darcsdir,-                      isReachableSource, addReachableSource,-                      windows++module Darcs.Global+    (+      atexit+    , withAtexit+    , SshSettings(..)+    , defaultSsh+    , timingsMode+    , setTimingsMode+    , whenDebugMode+    , withDebugMode+    , setDebugMode+    , debugMessage+    , debugFail+    , putTiming+    , addCRCWarning+    , getCRCWarnings+    , resetCRCWarnings+    , addBadSource+    , getBadSourcesList+    , isBadSource+    , darcsdir+    , isReachableSource+    , addReachableSource+    , windows     ) where + import Control.Applicative ( (<$>), (<*>) ) import Control.Monad ( when ) import Control.Concurrent.MVar@@ -50,27 +76,32 @@ import System.Exit ( ExitCode(..) ) import Prelude hiding (catch) + windows :: Bool windows = "mingw" `isPrefixOf` os -{-# NOINLINE atexitActions #-}+ atexitActions :: MVar (Maybe [IO ()]) atexitActions = unsafePerformIO (newMVar (Just []))+{-# NOINLINE atexitActions #-} --- | Registers an IO action to run just before darcs exits.  Useful--- for removing temporary files and directories, for example.-atexit :: IO () -> IO ()-atexit action = do-    modifyMVar_ atexitActions $ \ml -> do++-- | Registers an IO action to run just before darcs exits. Useful for removing+-- temporary files and directories, for example. Referenced in Issue1914.+atexit :: IO ()+       -> IO ()+atexit action =+    modifyMVar_ atexitActions $ \ml ->         case ml of-            Just l -> do+            Just l ->                 return (Just (action : l))             Nothing -> do                 hPutStrLn stderr "It's too late to use atexit"                 return Nothing + withAtexit :: IO a -> IO a-withAtexit prog = do+withAtexit prog =     bracket_         (return ())         exit@@ -80,27 +111,31 @@         Just actions <- swapMVar atexitActions Nothing         -- from now on atexit will not register new actions         mapM_ runAction actions-    runAction action = do+    runAction action =         catch (unblock action) $ \(exn :: SomeException) -> 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.+-- 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+{-# NOINLINE _debugMode #-} + 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 @@ -108,33 +143,43 @@ 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++": ")+putTiming = when timingsMode $ do+    t <- getClockTime >>= toCalendarTime+    hPutStr stderr (calendarTimeToString t++": ") -{-# NOINLINE _timingsMode #-}+ _timingsMode :: IORef Bool _timingsMode = unsafePerformIO $ newIORef False+{-# NOINLINE _timingsMode #-} + setTimingsMode :: IO () setTimingsMode = writeIORef _timingsMode True -{-# NOINLINE timingsMode #-}+ timingsMode :: Bool timingsMode = unsafePerformIO $ readIORef _timingsMode+{-# NOINLINE timingsMode #-} -data SshSettings = SshSettings { ssh :: String-                               , scp :: String-                               , sftp :: String }-  deriving (Show, Eq) +data SshSettings = SshSettings+    { ssh :: String+    , scp :: String+    , sftp :: String+    } deriving (Show, Eq)++ _defaultSsh :: IORef SshSettings _defaultSsh = unsafePerformIO $ newIORef =<< detectSsh --- expected properties:++-- | Expected properties: -- -- * only ever runs once in the lifetime of the program -- * environment variables override all@@ -142,74 +187,94 @@ -- * falls back to plain old ssh detectSsh :: IO SshSettings detectSsh = do-  whenDebugMode (putStrLn "Detecting SSH settings")-  vanilla <- if windows-                then do-                  plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")-                                `catch` \(e :: SomeException) -> return (show e)-                  whenDebugMode $ putStrLn $ "SSH settings (plink): " ++ (concat . take 1 . lines $ plinkStr)-                  if "PuTTY" `isPrefixOf` plinkStr-                    then return (SshSettings "plink" "pscp -q" "psftp")-                    else return rawVanilla-                else return rawVanilla-  settings <- SshSettings <$> fromEnv (ssh vanilla)  "DARCS_SSH"-                          <*> fromEnv (scp vanilla)  "DARCS_SCP"-                          <*> fromEnv (sftp vanilla) "DARCS_SFTP"-  whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)-  return settings- where-  snd3 (_, x, _) = x-  rawVanilla = SshSettings "ssh" "scp -q" "sftp"-  fromEnv :: String -> String -> IO String-  fromEnv d v = catchJust notFound-                          (getEnv v)-                          (const (return d))-  notFound e = if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing+    whenDebugMode (putStrLn "Detecting SSH settings")+    vanilla <-  if windows+                  then do+                    plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")+                                  `catch` \(e :: SomeException) -> return (show e)+                    whenDebugMode $ putStrLn $+                        "SSH settings (plink): " +++                        (concat . take 1 . lines $ plinkStr)+                    if "PuTTY" `isPrefixOf` plinkStr+                      then return (SshSettings "plink" "pscp -q" "psftp")+                      else return rawVanilla+                  else return rawVanilla+    settings <- SshSettings <$> fromEnv (ssh vanilla)  "DARCS_SSH"+                            <*> fromEnv (scp vanilla)  "DARCS_SCP"+                            <*> fromEnv (sftp vanilla) "DARCS_SFTP"+    whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)+    return settings+  where+    snd3 (_, x, _) = x+    rawVanilla = SshSettings "ssh" "scp -q" "sftp"+    fromEnv :: String -> String -> IO String+    fromEnv d v = catchJust notFound+                            (getEnv v)+                            (const (return d))+    notFound e =  if isDoesNotExistErrorType (ioeGetErrorType e)+                  then Just ()+                  else Nothing + defaultSsh :: SshSettings defaultSsh = unsafePerformIO $ readIORef _defaultSsh + type CRCWarningList = [FilePath]-{-# NOINLINE _crcWarningList #-} _crcWarningList :: IORef CRCWarningList _crcWarningList = unsafePerformIO $ newIORef []+{-# NOINLINE _crcWarningList #-} + addCRCWarning :: FilePath -> IO () addCRCWarning fp = modifyIORef _crcWarningList (fp:) + getCRCWarnings :: IO [FilePath] getCRCWarnings = readIORef _crcWarningList + resetCRCWarnings :: IO () resetCRCWarnings = writeIORef _crcWarningList [] -{- NOINLINE _badSourcesList -}+ _badSourcesList :: IORef [String] _badSourcesList = unsafePerformIO $ newIORef []+{- NOINLINE _badSourcesList -} + addBadSource :: String -> IO () addBadSource cache = modifyIORef _badSourcesList (cache:) + getBadSourcesList :: IO [String] getBadSourcesList = readIORef _badSourcesList + isBadSource :: IO (String -> Bool)-isBadSource = do badSources <- getBadSourcesList-                 return (`elem` badSources)+isBadSource = do+    badSources <- getBadSourcesList+    return (`elem` badSources) -{- NOINLINE _reachableSourcesList -}+ _reachableSourcesList :: IORef [String] _reachableSourcesList = unsafePerformIO $ newIORef []+{- NOINLINE _reachableSourcesList -} + addReachableSource :: String -> IO () addReachableSource src = modifyIORef _reachableSourcesList (src:) + getReachableSources :: IO [String] getReachableSources = readIORef _reachableSourcesList + isReachableSource :: IO (String -> Bool)-isReachableSource =  do reachableSources <- getReachableSources-                        return (`elem` reachableSources)+isReachableSource =  do+    reachableSources <- getReachableSources+    return (`elem` reachableSources)+  darcsdir :: String darcsdir = "_darcs"

@@ -187,7 +187,7 @@ unpullLastN repo n = applyInvRL `unsealFlipped` (safetake n $ newset2RL repo)  checkMatchSyntax :: [DarcsFlag] -> IO ()-checkMatchSyntax opts = do+checkMatchSyntax opts =  case getMatchPattern opts of   Nothing -> return ()   Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun DummyPatch))

@@ -17,42 +17,88 @@  {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7+ #include "gadts.h"-module Darcs.Patch ( RepoPatch,-                     PrimOf, Named, Patchy,-                     joinPatches,-                     fromPrim, fromPrims,-               rmfile, addfile, rmdir, adddir, move,-               hunk, tokreplace, namepatch, anonymous,-               binary,-               description,-               showContextPatch, showPatch, showNicely,-               infopatch, changepref,-               thing, things,-               primIsAddfile, primIsHunk, primIsSetpref,-               merge,-               commute, listTouchedFiles, hunkMatches,-               forceTokReplace,-               PrimPatch,-               -- for PatchTest-               resolveConflicts,-               Effect, effect,-               primIsBinary, gzWritePatch, writePatch, primIsAdddir,-               invert, invertFL, invertRL,-               commuteFLorComplain, commuteRL,-               readPatch, readPatchPartial,-               canonize, sortCoalesceFL,-               tryToShrink,-               patchname, patchcontents,-               applyToFilepaths, apply,-               applyToTree,-               patch2patchinfo,-               summary, summaryFL, plainSummary, xmlSummary, plainSummaryPrims,-               adddeps, getdeps,-               listConflictedFiles,-               isInconsistent,-             ) where++module Darcs.Patch+    ( RepoPatch+    , PrimOf+    , Named+    , Patchy+    , joinPatches+    , fromPrim+    , fromPrims+    , rmfile+    , addfile+    , rmdir+    , adddir+    , move+    , hunk+    , tokreplace+    , namepatch+    , anonymous+    , binary+    , description+    , showContextPatch+    , showPatch+    , showNicely+    , infopatch+    , changepref+    , thing+    , things+    , primIsAddfile+    , primIsHunk+    , primIsSetpref+    , merge+    , commute+    , listTouchedFiles+    , hunkMatches+    , forceTokReplace+    , PrimPatch+      -- * for PatchTest+    , resolveConflicts+    , Effect+    , effect+    , primIsBinary+    , gzWritePatch+    , writePatch+    , primIsAdddir+    , invert+    , invertFL+    , invertRL+    , commuteFLorComplain+    , commuteRL+    , readPatch+    , readPatchPartial+    , canonize+    , sortCoalesceFL+    , tryToShrink+    , patchname+    , patchcontents+    , applyToFilePaths+    , apply+    , applyToTree+    , effectOnFilePaths+    , patch2patchinfo+    , summary+    , summaryFL+    , plainSummary+    , xmlSummary+    , plainSummaryPrims+    , adddeps+    , getdeps+    , listConflictedFiles+    , isInconsistent+    ) where+++import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree )+import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL )+import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts, listConflictedFiles, resolveConflicts )+import Darcs.Patch.Effect ( Effect(effect) )+import Darcs.Patch.FileHunk ( IsHunk )+import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Invert ( invertRL, invertFL ) import Darcs.Patch.Named ( Named,                            adddeps, namepatch,@@ -60,7 +106,6 @@                            getdeps,                            infopatch,                            patch2patchinfo, patchname, patchcontents )-import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Patchy ( Patchy,                             showPatch, showNicely, showContextPatch,                             invert,@@ -69,15 +114,6 @@                             description, summary, summaryFL,                             commute, listTouchedFiles, hunkMatches                           )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.Show ( writePatch, gzWritePatch )-import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims )-import Darcs.Patch.Apply ( applyToFilepaths, applyToTree )-import Darcs.Patch.V1.Commute ( merge )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts, listConflictedFiles, resolveConflicts )-import Darcs.Patch.Effect ( Effect(effect) )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim,                           canonize,                           sortCoalesceFL,@@ -87,10 +123,16 @@                           primIsHunk, primIsBinary, primIsSetpref,                           tryToShrink,                           PrimPatch, PrimPatchBase(..) )-import Darcs.Patch.TokenReplace ( forceTokReplace )+import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Repair ( isInconsistent )-import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Show ( writePatch, gzWritePatch )+import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims )+import Darcs.Patch.TokenReplace ( forceTokReplace )+import Darcs.Patch.V1.Commute ( merge )+ import Storage.Hashed.Tree( Tree )+  instance (CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p,           PrimPatchBase p, Patchy p, ApplyState p ~ Tree) => Patchy (Named p)

@@ -20,24 +20,36 @@  #include "gadts.h" -module Darcs.Patch.Apply ( Apply(..),-                           applyToFilepaths,-                           applyToTree,-                           applyToState,-                         )-    where+-- |+-- Module      : Darcs.Patch.Apply+-- Copyright   : 2002-2005 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable +module Darcs.Patch.Apply+    (+      Apply(..)+    , applyToFilePaths+    , applyToTree+    , applyToState+    , effectOnFilePaths+    ) where+ import Prelude hiding ( catch, pi ) -import Darcs.Witnesses.Ordered ( FL(..), RL(..) )+import Control.Applicative ( (<$>) )+import Control.Arrow ( (***) ) -import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFilePaths, ApplyMonadTrans(..) )-import Darcs.Patch.FileName( fn2fp, fp2fn ) import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeMonad ) -import Control.Monad ( MonadPlus )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )+import Darcs.Patch.FileName( fn2fp, fp2fn )+import Darcs.Witnesses.Ordered ( FL(..), RL(..) ) + class Apply p where     type ApplyState p :: (* -> *) -> *     apply :: ApplyMonad m (ApplyState p) => p C(x y) -> m ()@@ -52,14 +64,37 @@     apply NilRL = return ()     apply (p:<:ps) = apply ps >> apply p -applyToFilepaths :: (Apply p, ApplyState p ~ Tree) => p C(x y) -> [FilePath] -> [FilePath]-applyToFilepaths pa fs = map fn2fp $ withFilePaths (map fp2fn fs) (apply pa) +effectOnFilePaths :: (Apply p, ApplyState p ~ Tree)+                  => p C(x y)+                  -> [FilePath]+                  -> [FilePath]+effectOnFilePaths p fps = fps' where+    (_, fps', _) = applyToFilePaths p Nothing fps+++applyToFilePaths :: (Apply p, ApplyState p ~ Tree)+                 => p C(x y)+                 -> Maybe [(FilePath, FilePath)]+                 -> [FilePath]+                 -> ([FilePath], [FilePath], [(FilePath, FilePath)])+applyToFilePaths pa ofpos fs = toFPs $ withFileNames ofnos fns (apply pa) where+        fns = map fp2fn fs+        ofnos = map (fp2fn *** fp2fn) <$> ofpos+        toFPs (affected, new, renames) =+            (map fn2fp affected, map fn2fp new, map (fn2fp *** fn2fp) renames)++ -- | Apply a patch to a 'Tree', yielding a new 'Tree'. applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree)-            => p C(x y) -> Tree m -> m (Tree m)-applyToTree patch t = snd `fmap` virtualTreeMonad (apply patch) t+            => p C(x y)+            -> Tree m+            -> m (Tree m)+applyToTree patch t = snd <$> virtualTreeMonad (apply patch) t + applyToState :: forall p m C(x y). (Apply p, ApplyMonadTrans m (ApplyState p))-             => p C(x y) -> (ApplyState p) m -> m ((ApplyState p) m)-applyToState patch t = snd `fmap` runApplyMonad (apply patch) t+             => p C(x y)+             -> (ApplyState p) m+             -> m ((ApplyState p) m)+applyToState patch t = snd <$> runApplyMonad (apply patch) t

@@ -20,7 +20,7 @@ -- 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.-module Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFilePaths, withFiles, ToTree(..) ) where+module Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFileNames, withFiles, ToTree(..) ) where  import qualified Data.ByteString      as B import qualified Data.ByteString.Lazy as BL@@ -28,7 +28,7 @@ import qualified Storage.Hashed.Monad as HSM import Storage.Hashed.Tree ( Tree ) import ByteStringUtils( linesPS, unlinesPS )-import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp )+import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp, isParentOrEqOf ) import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath ) import Control.Monad.State.Strict import Control.Monad.Identity( Identity )@@ -111,20 +111,45 @@     mRemoveDirectory = HSM.unlink . fn2ap     mRemoveFile = HSM.unlink . fn2ap -type FilePathMonad = State [FileName]+-- Latest name, current original name.+type OrigFileNameOf = (FileName, FileName)+-- Touched files, new file list (after removes etc.) and rename details+type FilePathMonadState = ([FileName], [FileName], [OrigFileNameOf])+type FilePathMonad = State FilePathMonadState -withFilePaths :: [FileName] -> FilePathMonad a -> [FileName]-withFilePaths fps x = execState x fps+-- |trackOrigRename takes an old and new name and attempts to apply the mapping+-- to the OrigFileNameOf pair. If the old name is the most up-to-date name of+-- the file in question, the first element of the OFNO will match, otherwise if+-- the up-to-date name was originally old, the second element will match.+trackOrigRename :: FileName -> FileName -> OrigFileNameOf -> OrigFileNameOf+trackOrigRename old new pair@(latest, from)+    | old `isParentOrEqOf` latest = (latest, movedirfilename old new latest)+    | old `isParentOrEqOf` from = (latest, movedirfilename old new from)+    | otherwise = pair +-- |withFileNames takes a maybe list of existing rename-pairs, a list of+-- filenames and an action, and returns the resulting triple of affected files,+-- updated filename list and new rename details. If the rename-pairs are not+-- present, a new list is generated from the filesnames.+withFileNames :: (Maybe [OrigFileNameOf]) -> [FileName] -> FilePathMonad a+    -> FilePathMonadState+withFileNames mbofnos fps x = execState x ([], fps, ofnos) where+    ofnos = maybe (map (\x -> (x, x)) fps) id mbofnos+ instance ApplyMonad FilePathMonad Tree where     type ApplyMonadBase FilePathMonad = Identity     -- We can't check it actually is a directory here-    mDoesDirectoryExist d = gets (d `elem`)-    mCreateDirectory _ = return ()-    mRemoveFile f = modify $ filter (/= f)-    mRemoveDirectory f = modify $ filter (/= f)-    mRename a b = modify $ map (movedirfilename a b)-    mModifyFilePS _ _ = return ()+    mDoesDirectoryExist d = gets $ \(_, fs, _) -> d `elem` fs++    mCreateDirectory = mCreateFile+    mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns)+    mRemoveFile f = modify $ \(ms, fs, rns) -> (f : ms, filter (/= f) fs, rns)+    mRemoveDirectory = mRemoveFile+    mRename a b =+        modify $ \(ms, fs, rns) -> ( a : b : ms+                                   , map (movedirfilename a b) fs+                                   , map (trackOrigRename a b) rns)+    mModifyFilePS f _ = mCreateFile f  instance MonadProgress FilePathMonad where   runProgressActions = silentlyRunProgressActions

@@ -25,10 +25,11 @@                               movedirfilename,                               encodeWhite, decodeWhite,                               (///),-                              breakup+                              breakup, isParentOrEqOf                             ) where  import Data.Char ( isSpace, chr, ord )+import Data.List ( stripPrefix ) import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 ) import qualified Data.ByteString.Char8 as BC (unpack, pack) import qualified Data.ByteString       as B  (ByteString)@@ -142,13 +143,19 @@ (FN "")///b = normPath b a///b = normPath $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b +isParentOrEqOf :: FileName -> FileName -> Bool+isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of+    Just ('/' : _) -> True+    Just [] -> True+    _ -> False+ 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 $ normPath old-          new' = fn2fp $ normPath new-          name' = fn2fp $ normPath name+    if name' == old'+        then new+        else case stripPrefix old' name' of+            Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest+            _ -> name+        where old' = fn2fp $ normPath old+              new' = fn2fp $ normPath new+              name' = fn2fp $ normPath name

@@ -5,27 +5,28 @@  #include "gadts.h" --- |Showing and reading lists of patches This class allows us to control how--- lists of patches are formatted on disk. For legacy reasons V1 patches--- have their own special treatment (see 'ListFormat'). Other patch types--- use the default format which just puts them in a sequence without separators--- or any prelude/epilogue.+-- | Showing and reading lists of patches This class allows us to control how+-- lists of patches are formatted on disk. For legacy reasons V1 patches have+-- their own special treatment (see 'ListFormat'). Other patch types use the+-- default format which just puts them in a sequence without separators or any+-- prelude/epilogue. ----- This means that 'FL (FL p)' etc would be ambiguous, so there are--- no instances for 'FL p' or other list types.+-- This means that 'FL (FL p)' etc would be ambiguous, so there are no instances+-- for 'FL p' or other list types. class PatchListFormat p where   patchListFormat :: ListFormat p   patchListFormat = ListFormatDefault --- | This type is used to tweak the way that lists of 'p' are shown for a--- given 'Patch' type 'p'. It is needed to maintain backwards compatibility--- for V1 and V2 patches.+-- | This type is used to tweak the way that lists of 'p' are shown for a given+-- 'Patch' type 'p'. It is needed to maintain backwards compatibility for V1 and+-- V2 patches. data ListFormat (p :: PATCHKIND)-  = ListFormatDefault -- ^Show and read lists without braces.-  | ListFormatV1      -- ^Show lists with a single layer of braces around the outside,+  = ListFormatDefault -- ^ Show and read lists without braces.+  | ListFormatV1      -- ^ Show lists with a single layer of braces around the outside,                       -- except for singletons which have no braces.                       -- Read with arbitrary nested braces and parens and flatten them out.-  | ListFormatV2      -- ^Show lists without braces+  | ListFormatV2      -- ^ Show lists without braces                       -- Read with arbitrary nested parens and flatten them out. -data FileNameFormat = OldFormat | NewFormat+data FileNameFormat = OldFormat+                    | NewFormat

@@ -333,6 +333,7 @@ -- > ] -- -- note that below I assume the name has no newline in it.+-- See 'readPatchInfo' for the inverse operation. showPatchInfo :: PatchInfo -> Doc showPatchInfo pi =     blueText "[" <> packedString (_piName pi)@@ -344,6 +345,16 @@               where mul [] = text "\n"                     mul (s:ss) = text "\n " <> packedString s <> mul ss +-- |Parser for 'PatchInfo' as stored in patch bundles and inventory files,+-- for example:+--+-- > [Document the foo interface+-- > John Doe <john.doe@example.com>**20110615084241+-- >  Ignore-this: 85b94f67d377c4ab671101266ef9c229+-- >  Nobody knows what a 'foo' is, so describe it.+-- > ]+--+-- See 'showPatchInfo' for the inverse operation. readPatchInfo :: ParserM m => m (PatchInfo) readPatchInfo = do   skipSpace

@@ -1,36 +1,53 @@+#include "gadts.h"++-- |+-- Module      : Darcs.Patch.Merge+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+ module Darcs.Patch.Merge-    ( Merge(..), mergeFL )-    where+    (+      Merge(..)+    , mergeFL+    ) where -import Darcs.Patch.Commute ( Commute ) +import Data.Maybe ( fromJust )++import Darcs.Patch.Commute ( Commute ) import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..),                                  FL(..), RL,                                  reverseFL, reverseRL                                ) -import Data.Maybe ( fromJust ) -#include "gadts.h"- -- | Things that can always be merged class Commute p => Merge p where-    merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)+    merge :: (p :\/: p) C(x y)+          -> (p :/\: p) C(x y) + instance Merge p => Merge (FL p) where     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'))+    merge ((x:>:xs) :\/: ys) = fromJust $ do+        ys' :/\: x' <- return $ mergeFL (x :\/: ys)+        xs' :/\: ys'' <- return $ merge (ys' :\/: xs)+        return (ys'' :/\: (x' :>: xs')) -mergeFL :: Merge 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'')  instance Merge p => Merge (RL p) where     merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of                        (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'+++mergeFL :: Merge 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'') 

@@ -107,10 +107,6 @@ instance RepairToFL p => Repair (Named p) where     applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p -infopatch :: Patchy p => PatchInfo -> FL 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] -> FL 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."@@ -120,8 +116,13 @@ anonymous :: Patchy p => FL p C(x y) -> IO (Named p C(x y)) anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p +infopatch :: Patchy p => PatchInfo -> FL p C(x y) -> Named p C(x y) infopatch pi p = NamedP pi [] p++adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y) adddeps (NamedP pi _ p) ds = NamedP pi ds p++getdeps :: Named p C(x y) -> [PatchInfo] getdeps (NamedP _ ds _) = ds  patch2patchinfo :: Named p C(x y) -> PatchInfo

@@ -12,7 +12,6 @@  import Control.Monad.State( StateT, runStateT, gets, lift, put ) import qualified Data.Map as M-import Data.List( (\\), sort )  -- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) 

@@ -30,8 +30,7 @@  import qualified Data.ByteString as BS -import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Witnesses.Eq ( MyEq(..) ) import Darcs.Patch.FileHunk( IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )@@ -47,11 +46,11 @@ invertHunk (Hunk off old new) = Hunk off new old  hunkEdit :: Hunk C(x y) -> BS.ByteString -> BS.ByteString-hunkEdit hunk@(Hunk off old new) bs = case splice bs (off) (off + BS.length old) of+hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of   x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ]     | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " "                         ++ show new ++ " to " ++ show bs-  where splice bs x y = BS.drop x $ BS.take y bs+  where splice bs' x y = BS.drop x $ BS.take y bs'  instance MyEq Hunk where   unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y'@@ -79,9 +78,13 @@ -- TODO: PrimClassify doesn't make sense for V3 prims instance PrimClassify Prim where    primIsAddfile _ = False+   primIsRmfile _ = False    primIsAdddir _ = False+   primIsRmdir _ = False    primIsHunk _ = False+   primIsMove _ = False    primIsBinary _ = False+   primIsTokReplace _ = False    primIsSetpref _ = False    is_filepatch _ = Nothing @@ -107,6 +110,7 @@    invert (TextHunk x h) = TextHunk x $ invertHunk h    invert (Manifest x y) = Demanifest x y    invert (Demanifest x y) = Manifest x y+   invert (Move x y z) = Move x z y    invert Identity = Identity  instance PatchInspect Prim where@@ -115,7 +119,7 @@     listTouchedFiles _ = []      -- TODO (used for --match 'hunk ...', presumably)-    hunkMatches f _ = False+    hunkMatches _ _ = False  instance MyEq Prim where     unsafeCompare (BinaryHunk a b) (BinaryHunk c d) = a == c && b `unsafeCompare` d

@@ -3,14 +3,8 @@     ()     where -import Prelude hiding ( pi ) import Darcs.Patch.Prim.Class ( PrimDetails(..) ) import Darcs.Patch.Prim.V3.Core ( Prim(..) )-import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) )--import qualified Data.ByteString as B ( ByteString, concat )-import qualified Data.ByteString.Char8 as BC ( pack, split )-import Data.Maybe ( catMaybes )  #include "gadts.h" 

@@ -34,8 +34,6 @@ data Object (m :: * -> *) = Directory DirContent                           | Blob (m BS.ByteString) !Hash -data ObjectType = TText | TBinary | TDirectory- data ObjectMap (m :: * -> *) = ObjectMap { getObject :: UUID -> m (Maybe (Object m))                                          , putObject :: UUID -> Object m -> m (ObjectMap m)                                          , listObjects :: m [UUID]

@@ -9,10 +9,10 @@ import Darcs.Witnesses.Sealed( seal )  import Control.Applicative ( (<$>) )-import Control.Monad ( liftM )+import Control.Monad ( liftM, liftM2 ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC-import Data.Char ( isSpace, ord, chr )+import Data.Char ( chr )  instance PrimRead Prim where   readPrim _ = do skipSpace@@ -23,23 +23,19 @@                     manifest "manifest" Manifest,                     manifest "demanifest" Demanifest ] -    where manifest kind ctor = do id <- patch kind-                                  loc <- location-                                  return $ ctor id loc+    where manifest kind ctor = liftM2 ctor (patch kind) location           identity = lexString "identity" >> return Identity           patch x = string x >> uuid           uuid = UUID <$> myLex'           filename = encoded           encoded = decodeWhite <$> myLex'           hunktext = skipSpace >> choice [ string "." >> encoded, string "!" >> return B.empty ]-          location = do id <- uuid-                        name <- filename-                        return (id, name)-          hunk kind ctor = do id <- patch kind+          location = liftM2 (,) uuid filename+          hunk kind ctor = do uid <- patch kind                               offset <- int                               old <- hunktext                               new <- hunktext-                              return $ ctor id (Hunk offset old new)+                              return $ ctor uid (Hunk offset old new)  instance ReadPatch Prim where  readPatch' = readPrim undefined

@@ -6,25 +6,18 @@  import Prelude hiding ( pi ) -import ByteStringUtils ( fromPS2Hex )-import Data.Char ( isSpace, ord, chr )+import Data.Char ( isSpace, ord ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk )-import Darcs.Patch.FileName ( FileName ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) ) import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )-import Darcs.Patch.Viewing ( showContextHunk ) import Darcs.Patch.Prim.Class ( PrimShow(..) ) import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), UUID(..) ) import Darcs.Patch.Prim.V3.Details ()-import Darcs.Witnesses.Show ( appPrec, Show1(..), Show2(..), ShowDict(..) )-import Printer ( Doc, renderString, vcat,-                 text, userchunk, packedString, blueText,-                 ($$), (<+>), (<>),-               )+import Darcs.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )+import Printer ( renderString, text, packedString, blueText, (<+>), (<>), Doc )  #include "gadts.h" @@ -56,21 +49,23 @@   showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p   showPrim _ Identity = blueText "identity" +showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc showManifest txt dir file path = blueText txt <+>                                  formatUUID file <+>                                  formatUUID dir <+>                                  packedString (encodeWhite path) -showHunk txt id (Hunk off old new) = blueText txt <+>-                                     formatUUID id <+>-                                     text (show off) <+>-                                     hunktext old <+>-                                     hunktext new+showHunk :: String -> UUID -> Hunk C(x y) -> Doc+showHunk txt uid (Hunk off old new) = blueText txt <+>+                                      formatUUID uid <+>+                                      text (show off) <+>+                                      hunktext old <+>+                                      hunktext new     where hunktext bit | B.null bit = text "!"                        | otherwise = text "." <> packedString (encodeWhite bit) +formatUUID :: UUID -> Doc formatUUID (UUID x) = packedString x-  -- XXX a bytestring version of encodeWhite from Darcs.FileName encodeWhite :: B.ByteString -> B.ByteString

@@ -34,32 +34,43 @@  type SealedPatchSet p C(start) = Sealed ((PatchSet p) C(start)) -data PatchSet p C(start x) where-    PatchSet :: RL (PatchInfoAnd p) C(y x) -> RL (Tagged p) C(start y) -> PatchSet p C(start x)+-- A PatchSet is a list of patches since the last tag, and a list of tagged+-- patch lists that form a repo's history.+data PatchSet p C(start y) where+    PatchSet :: RL (PatchInfoAnd p) C(x y) -> RL (Tagged p) C(start x) -> PatchSet p C(start y) -data Tagged p C(x2 z) where+-- A Tagged is a Tag, the hash of the 'previous' inventory (if it exists) and+-- the list of patches since that previous inventory.+data Tagged p C(x z) where     Tagged :: PatchInfoAnd p C(y z) -> Maybe String-           -> RL (PatchInfoAnd p) C(x3 y) -> Tagged p C(x3 z)+           -> RL (PatchInfoAnd p) C(x y) -> Tagged p C(x z) -newset2RL :: PatchSet p C(start x4) -> RL (PatchInfoAnd p) C(start x4)+-- |newset2RL takes a PatchSet and returns an equivalent, linear RL of patches.+newset2RL :: PatchSet p C(start x) -> RL (PatchInfoAnd p) C(start x) newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts)-    where ts2rl :: Tagged p C(x5 y) -> RL (PatchInfoAnd p) C(x5 y)+    where ts2rl :: Tagged p C(y z) -> RL (PatchInfoAnd p) C(y z)           ts2rl (Tagged t _ ps2) = t :<: ps2 -newset2FL :: PatchSet p C(start x6) -> FL (PatchInfoAnd p) C(start x6)+-- |newset2FL takes a PatchSet and returns an equivalent, linear FL of patches.+newset2FL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(start x) newset2FL = reverseRL . newset2RL +-- |appendPSFL takes a PatchSet and a FL of patches that 'follow' the PatchSet,+-- and concatenates the patches into the PatchSet. appendPSFL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(x y)            -> PatchSet p C(start y) appendPSFL (PatchSet ps ts) newps = PatchSet (reverseFL newps +<+ ps) ts -progressPatchSet :: String -> PatchSet p C(start x7) -> PatchSet p C(start x7)+-- |Runs a progress action for each tag and patch in a given PatchSet, using+-- the passed progress message. Does not alter the PatchSet.+progressPatchSet :: String -> PatchSet p C(start x) -> PatchSet p C(start x) progressPatchSet k (PatchSet ps0 ts0) = PatchSet (mapRL_RL prog ps0) $ mapRL_RL pts ts0     where prog = progress k-          pts :: Tagged p C(x8 y) -> Tagged p C(x8 y)+          pts :: Tagged p C(y z) -> Tagged p C(y z)           pts (Tagged t h ps) = Tagged (prog t) h (mapRL_RL prog ps) -tags :: PatchSet p C(start x13) -> [PatchInfo]+-- |tags returns the PatchInfos corresponding to the tags of a given PatchSet.+tags :: PatchSet p C(start x) -> [PatchInfo] tags (PatchSet _ ts) = mapRL f ts-    where f :: Tagged p C(x14 y) -> PatchInfo+    where f :: Tagged p C(y z) -> PatchInfo           f (Tagged t _ _) = info t

@@ -59,7 +59,7 @@     -- unified context is not included in patch representation, this     -- requires access to the tree.     showContextPatch :: (Monad m, ApplyMonadTrans m (ApplyState p),-                         ApplyMonad m (ApplyState p), Monad m)+                         ApplyMonad m (ApplyState p))                      => p C(x y) -> m Doc     showContextPatch p = return $ showPatch p     description :: p C(x y) -> Doc

@@ -111,7 +111,7 @@   doPrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y)))-doPrimSplit = doPrimSplit_ explanation+doPrimSplit = doPrimSplit_ True explanation   where     explanation = map BC.pack                    [ "Interactive hunk edit:"@@ -124,7 +124,7 @@                    , ""                    ] -doPrimSplit_ helptext (isHunk -> Just (FileHunk fn n before after))+doPrimSplit_ edit_before_part helptext (isHunk -> Just (FileHunk fn n before after))  = Just (B.concat $ intersperse (BC.pack "\n") $ concat            [ helptext            , [mkSep " BEFORE (reference) =========================="]@@ -136,8 +136,11 @@          \bs -> do let ls = BC.split '\n' bs                    (_, ls2) <- breakSep ls        -- before                    (before', ls3) <- breakSep ls2 -- after 1-                   (after', _) <- breakSep ls3    -- after 2-                   return (hunk before before' +>+ hunk before' after' +>+ hunk after' after))+                   (after', _) <- breakSep ls3    -- after+                   return $+                     if edit_before_part+                     then hunk before before' +>+ hunk before' after' +>+ hunk after' after+                     else hunk before after' +>+ hunk after' after)     where sep = BC.pack "=========================="           hunk :: PrimPatch prim => [B.ByteString] -> [B.ByteString] -> FL prim C(a b)           hunk b a = canonize (primFromHunk (FileHunk fn n b a))@@ -145,7 +148,7 @@           breakSep xs = case break (sep `BC.isPrefixOf`) xs of                            (_, []) -> Nothing                            (ys, _:zs) -> Just (ys, zs)-doPrimSplit_ _ _ = Nothing+doPrimSplit_ _ _ _ = Nothing  -- |Split a primitive hunk patch up -- by allowing the user to edit both the before and after lines, then insert fixup patches@@ -156,7 +159,7 @@  doReversePrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y))) doReversePrimSplit prim = do-  (text, parser) <- doPrimSplit_ reverseExplanation (invert prim)+  (text, parser) <- doPrimSplit_ False reverseExplanation (invert prim)   let parser' p = do         patch <- parser  p         return . reverseRL $ invertFL patch@@ -167,6 +170,7 @@                   , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)"                   , " - Arbitrary editing is supported"                   , " - Your working copy will be returned to the 'AFTER' state"+                  , " - Do not touch the 'BEFORE' section"                   , " - Hints:"                   , "   - To revert only a part of a text addition, delete the part you want to get rid of"                   , "   - To revert only a part of a removal, copy back the part you want to retain"

@@ -1,6 +1,9 @@-module Darcs.Patch.TokenReplace -    ( tryTokInternal, forceTokReplace ) -    where +module Darcs.Patch.TokenReplace+    (+      tryTokInternal+    , forceTokReplace+    )+    where  import Darcs.Patch.RegChars ( regChars ) 

@@ -24,14 +24,14 @@                       deselectNotTouching, selectNotTouching,                     ) where import Control.Applicative ( (<$>) )-import Data.List ( sort, isSuffixOf )+import Data.List ( isSuffixOf, nub )  import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,                              patchChoices, tag, getChoices,                       forceFirsts, forceLasts, tpPatch,                     )-import Darcs.Patch ( Patchy, listTouchedFiles, invert )-import Darcs.Patch.Apply ( ApplyState, applyToFilepaths )+import Darcs.Patch ( Patchy, invert )+import Darcs.Patch.Apply ( ApplyState, applyToFilePaths, effectOnFilePaths ) import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) ) import Darcs.Witnesses.Sealed ( Sealed, seal ) import Storage.Hashed.Tree( Tree )@@ -42,7 +42,7 @@ selectTouching (Just files) pc = forceFirsts xs pc     where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of+          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of                              (True, fs') -> tag tp:ct fs' tps                              (False, fs') -> ct fs' tps           xs = case getChoices pc of@@ -54,7 +54,7 @@ deselectNotTouching (Just files) pc = forceLasts xs pc     where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of+          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of                              (True, fs') -> ct fs' tps                              (False, fs') -> tag tp:ct fs' tps           xs = case getChoices pc of@@ -66,7 +66,7 @@ selectNotTouching (Just files) pc = forceFirsts xs pc     where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]           ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouch fs (tpPatch tp) of+          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of                              (True, fs') -> ct fs' tps                              (False, fs') -> tag tp:ct fs' tps           xs = case getChoices pc of@@ -86,18 +86,29 @@  choosePreTouching :: (Patchy p, ApplyState p ~ Tree)                   => Maybe [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))-choosePreTouching files patch = chooseTouching (applyToFilepaths-    (invert patch) <$> files) patch+choosePreTouching files patch = chooseTouching filesBeforePatch patch where+    filesBeforePatch = effectOnFilePaths (invert patch) <$> files -lookTouch :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> p C(x y) -> (Bool, [FilePath])-lookTouch fs p = (any (\tf -> any (affects tf) fs) (listTouchedFiles p)-                   || fs' /= fs, fs')-    where affects :: FilePath -> FilePath -> Bool-          affects touched f =  touched == f-                            || touched `isSubPathOf` f-                            || f `isSubPathOf` touched+lookTouchOnlyEffect :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> p C(x y)+    -> (Bool, [FilePath])+lookTouchOnlyEffect fs p = (wasTouched, fs') where+    (wasTouched, _, fs', _) = lookTouch Nothing fs p+++lookTouch :: (Patchy p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)]+    -> [FilePath] -> p C(x y)+    -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)])+lookTouch renames fs p = (anyTouched, touchedFs, fs', renames')+    where+          touchedFs = nub . concatMap fsAffectedBy $ affected+          fsAffectedBy af = filter (affectedBy af) fs+          anyTouched = length touchedFs > 0+          affectedBy :: FilePath -> FilePath -> Bool+          touched `affectedBy` f =  touched == f+                                 || touched `isSubPathOf` f+                                 || f `isSubPathOf` touched           isSubPathOf :: FilePath -> FilePath -> Bool-          isSubPathOf sub path = case splitAt (length sub) path of-                                 (path', '/':_) -> path' == sub+          path `isSubPathOf` parent = case splitAt (length parent) path of+                                 (path', '/':_) -> path' == parent                                  _ -> False-          fs' = sort $ applyToFilepaths p fs+          (affected, fs', renames') = applyToFilePaths p renames fs

@@ -20,19 +20,30 @@  #include "gadts.h" --- |'NonPatch' and 'Non' patches are patches that store a context as a--- sequence of patches.  See "Darcs.Patch.Real" for example usage. module Darcs.Patch.V2.Non-       ( Non(..), Nonable(..), unNon,-         showNon, readNon, showNons, readNons,-         add, addP, remP, addPs, remPs, remNons,-         (*>), (>*), (*>>), (>>*),-         propAdjustTwice ) where+    ( Non(..)+    , Nonable(..)+    , unNon+    , showNon+    , showNons+    , readNon+    , readNons+    , commutePrimsOrAddToCtx+    , commuteOrAddToCtx+    , commuteOrRemFromCtx+    , commuteOrAddToCtxRL+    , commuteOrRemFromCtxFL+    , remNons+    , (*>)+    , (>*)+    , (*>>)+    , (>>*)+    ) where  import Prelude hiding ( rem ) import Data.List ( delete ) import Control.Monad ( liftM, mzero )-import Darcs.Patch.Commute ( commuteFLorComplain )+import Darcs.Patch.Commute ( commuteFL ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) import Darcs.Patch.Invert ( Invert, invertFL, invertRL )@@ -56,41 +67,57 @@ import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) ) import qualified Data.ByteString.Char8 as BC ( pack, singleton, ByteString ) ---import Darcs.ColorPrinter ( traceDoc )---import Printer ( greenText )+-- |A 'Non' stores a context with a 'Prim' patch. It is a patch whose effect+-- isn't visible - a Non-affecting patch.+data Non p C(x) where+    Non :: FL p C(x y) -> PrimOf p C(y z) -> Non p C(x) -showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => [Non p C(x)] -> Doc-showNons [] = empty-showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}"+-- |unNon converts a Non into a FL of its context followed by the primitive+-- patch.+unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))+unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL) -oBracket :: BC.ByteString-oBracket = BC.pack "{{"+instance (Show2 p, Show2 (PrimOf p)) => Show (Non p C(x)) where+    showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " .+                             showsPrec2 (appPrec + 1) cs . showString " " .+                             showsPrec2 (appPrec + 1) p -cBracket :: BC.ByteString-cBracket = BC.pack "}}"+instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p) where+    showDict1 = ShowDictClass -showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p C(x) -> Doc+-- |showNons creates a Doc representing a list of Nons.+showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p)+         => [Non p C(x)] -> Doc+showNons [] = empty+showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}"++-- |showNon creates a Doc representing a Non.+showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p C(x)+        -> Doc showNon (Non c p) = hiddenPrefix "|" (showPatch c)                     $$ hiddenPrefix "|" (blueText ":")                     $$ showPrim NewFormat p -readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m [Non p C(x)]-readNons = peekfor oBracket rns (return [])-    where rns = peekfor cBracket (return []) $-                do Sealed ps <- readPatch'-                   lexChar ':'-                   Sealed p <- readPrim NewFormat-                   (Non ps p :) `liftM` rns+-- |readNons is a parser that attempts to read a list of Nons.+readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)+         => m [Non p C(x)]+readNons = peekfor (BC.pack "{{") rns (return [])+  where rns = peekfor (BC.pack "}}") (return []) $+              do Sealed ps <- readPatch'+                 lexChar ':'+                 Sealed p <- readPrim NewFormat+                 (Non ps p :) `liftM` rns -readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m (Non p C(x))+-- |readNon is a parser that attempts to read a single Non.+readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)+        => m (Non p C(x)) readNon = do Sealed ps <- readPatch'-             peekfor colon (do Sealed p <- readPrim NewFormat-                               return $ Non ps p)-                           mzero--colon :: BC.ByteString-colon = BC.singleton ':'+             let doReadPrim = do Sealed p <- readPrim NewFormat+                                 return $ Non ps p+             peekfor (BC.singleton ':') doReadPrim mzero +-- |Nons are equal if their context patches are equal, and they have an equal+-- prim patch. instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p C(x)) where     Non (cx :: FL p C(x y1)) (x :: PrimOf p C(y1 z1))      == Non (cy :: FL p C(x y2)) (y :: PrimOf p C(y2 z2)) =@@ -100,51 +127,35 @@                   NotEq -> False         NotEq -> False --- | 'Non' stores a context with a 'Prim' patch.-data Non p C(x) where-    Non :: FL p C(a x) -> PrimOf p C(x y) -> Non p C(a)---- | Return as a list the context followed by the primitive patch.-unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))-unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL)-+-- |Nonable represents the class of patches that can be turned into a Non. class Nonable p where     non :: p C(x y) -> Non p C(x) --- | 'addP' @x cy@ tries to commute @x@ past @cy@ and always returns some--- variant @cy'@.  -- commutation suceeds, the variant is just--- straightforwardly the commuted versian.  If commutation fails, the variant+-- |'commuteOrAddToCtx' @x cy@ tries to commute @x@ past @cy@ and always+-- returns some variant @cy'@. If commutation suceeds, the variant is just+-- straightforwardly the commuted version. If commutation fails, the variant -- consists of @x@ prepended to the context of @cy@.-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+commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)+                  -> Non p C(x)+commuteOrAddToCtx p n | Just n' <- p >* n = n'+commuteOrAddToCtx p (Non c x) = Non (p:>:c) x --- | 'addPs' @xs cy@ commutes as many patches of @xs@ past @cy@ as---   possible, stopping at the first patch that fails to commute.---   Note the fact @xs@ is a 'RL'------   Suppose we have+-- | 'commuteOrAddToCtxRL' @xs cy@ commutes as many patches of @xs@ past @cy@+-- as possible, adding any that don't commute to the context of cy.  Suppose we+-- have -----   > x1 x2 x3 [c1 c2 y]+-- > x1 x2 x3 [c1 c2 y] -----   and that in our example @c1@ fails to commute past @x1@, this---   function would commute down to+-- and that in our example @x1@ fails to commute past @c1@, this function+-- would commute down to -----   > x1 [c1'' c2'' y''] x2' x3'+-- > x1 [c1'' c2'' y''] x2' x3' -----   and return @[x1 c1'' c2'' y'']@-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 :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y) -> Non p C(y) -> Non p C(x)-add q = addPs (mapRL_RL fromPrim $ toRL q)---- remNons really only works right if the relevant nons are conflicting...-remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf 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+-- and return @[x1 c1'' c2'' y'']@+commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y)+                    -> Non p C(x)+commuteOrAddToCtxRL NilRL n = n+commuteOrAddToCtxRL (p:<:ps) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n  -- |abstract over 'FL'/'RL' class WL l where@@ -162,66 +173,94 @@    toRL = id    invertWL = reverseFL . invertRL -remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf p)) => [Non p C(x)] -> FL p C(x y)-             -> (FL (PrimOf p) :> 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 -> sortCoalesceFL (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)+-- |commutePrimsOrAddToCtx takes a WL of prims and attempts to commute them+-- past a Non.+commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y)+         -> Non p C(y) -> Non p C(x)+commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q) -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+-- TODO: Figure out what remNons is for; it's is only used in one place - when+-- commuting two Conflictors:+--+-- > commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)+-- > ...+-- >   a1' = map (commutePrimsOrAddToCtx n2) a1+-- >   p2ooo = remNons a1' p2+-- >   n2n1 = n2 +>+ n1+-- > n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1+--+-- which appears to be munging the not-yet-undone FLs in the Conflictors. a1'+-- will be the list of Nons with n2 commuted in/past them. So we then want to+-- modify p2, so that it doesn't have any of a1' in its context. -(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y) -> Maybe (Non p C(y))-n *> p = invert p >* n+-- remNons really only works right if the relevant nons are conflicting...+remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p,+        MyEq (PrimOf p)) => [Non p C(x)] -> Non p C(x) -> Non p C(x)+remNons ns n@(Non c x) = case remNonHelper ns c of+                             NilFL :> c' -> Non c' x+                             _ -> n+  where+    remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p,+                 PrimPatchBase p, MyEq (PrimOf p)) => [Non p C(x)]+                 -> FL p C(x y) -> (FL (PrimOf p) :> FL p) C(x y)+    remNonHelper [] x = NilFL :> x+    remNonHelper _ NilFL = NilFL :> NilFL+    remNonHelper ns (c:>:cs)+        | non c `elem` ns =+          let nsWithoutC = delete (non c) ns in+          let commuteOrAddInvC = commuteOrAddToCtx $ invert c in+          case remNonHelper (map commuteOrAddInvC $ nsWithoutC) cs of+              a :> z -> sortCoalesceFL (effect c +>+ a) :> z+        | otherwise = case commuteWhatWeCanFL (c :> cs) of+                          b :> c' :> d -> case remNonHelper ns b of+                              a :> b' -> a :> (b' +>+ c' :>: d) -(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe (Non p C(x))-y >* (Non c x) = case commuteFLorComplain (y :> c) of-                    Right (c' :> y') -> do-                      px' :> _ <- commute (y' :> fromPrim x)-                      x' <- toPrim px'-                      return (Non c' x')-                    _ -> Nothing+-- |commuteOrRemFromCtx attempts to remove a given patch from a Non. If the+-- patch was not in the Non, then the commute will succeed and the modified Non+-- will be returned. If the commute fails then the patch is either in the Non+-- context, or the Non patch itself; we attempt to remove the patch from the+-- context and then return the non with the updated context.+--+-- TODO: understand if there is any case where p is equal to the prim patch of+-- the Non, in which case, we return the original Non, is that right?+commuteOrRemFromCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x)+     -> Maybe (Non p C(y))+commuteOrRemFromCtx p n | n'@(Just _) <- n *> p = n'+commuteOrRemFromCtx p (Non pc x) = removeFL p pc >>= \c -> return (Non c x) -(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p C(x) -> l (PrimOf p) C(x y) -> Maybe (Non p C(y))-n *>> p = invertWL p >>* n+-- |commuteOrRemFromCtxFL attempts to remove a FL of patches from a Non,+-- returning Nothing if any of the individual removes fail.+commuteOrRemFromCtxFL :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x)+                      -> Maybe (Non p C(y))+commuteOrRemFromCtxFL NilFL n = Just n+commuteOrRemFromCtxFL (p:>:ps) n = do n' <- commuteOrRemFromCtx p n+                                      commuteOrRemFromCtxFL ps n' -(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y) -> Non p C(y) -> Maybe (Non p C(x))-q >>* nn = adj (toRL q) nn-    where adj :: (Patchy p, ToFromPrim p) => RL (PrimOf p) 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+-- |(*>) attemts to modify a Non by commuting it past a given patch.+(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y)+     -> Maybe (Non p C(y))+n *> p = invert p >* n --- TODO why don't any tests run this?-propAdjustTwice :: (Patchy p, ToFromPrim p, MyEq (PrimOf p)) => p C(x y) -> Non p C(y) -> Maybe Doc-propAdjustTwice 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+-- |(>*) attempts to modify a Non, by commuting a given patch past it.+(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)+     -> Maybe (Non p C(x))+y >* (Non c x) = do+    c' :> y' <- commuteFL (y :> c)+    px' :> _ <- commute (y' :> fromPrim x)+    x' <- toPrim px'+    return (Non c' x') -instance (Show2 p, Show2 (PrimOf p)) => Show (Non p C(x)) where-    showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " .-                             showsPrec2 (appPrec + 1) cs . showString " " .-                             showsPrec2 (appPrec + 1) p+-- |(*>>) attempts to modify a Non by commuting it past a given WL of patches.+(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p C(x)+      -> l (PrimOf p) C(x y) -> Maybe (Non p C(y))+n *>> p = invertWL p >>* n -instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p) where-    showDict1 = ShowDictClass+-- |(>>*) attempts to modify a Non by commuting a given WL of patches past it.+(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y) -> Non p C(y)+      -> Maybe (Non p C(x))+ps >>* n = commuteRLPastNon (toRL ps) n+  where+    commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) C(x y)+                     -> Non p C(y) -> Maybe (Non p C(x))+    commuteRLPastNon NilRL n = Just n+    commuteRLPastNon (x:<:xs) n = fromPrim x >* n >>= commuteRLPastNon xs

@@ -20,788 +20,881 @@  #include "gadts.h" --- | Conflictor patches-module Darcs.Patch.V2.Real-       ( RealPatch(..), prim2real, isConsistent, isForward, isDuplicate,-         mergeUnravelled ) where--import Control.Monad ( mplus, liftM )-import Data.List ( partition, nub )-import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL, commuteRLFL )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..), IsConflictedPrim(..), ConflictState(..) )-import Darcs.Patch.ConflictMarking ( mangleUnravelled )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(NewFormat) )-import Darcs.Patch.Invert ( invertFL, invertRL )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..),-                          showPrim, showPrimFL,-                          readPrim,-                          PrimOf, PrimPatchBase, PrimPatch-                        )-import Darcs.Patch.Read ( bracketedFL )-import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) )-import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..)-                          , PatchInspect(..)-                          , ReadPatch(..), ShowPatch(..)-                          , Invert(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Patch.Summary ( plainSummary )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+)-                               , (+<+), mapFL_FL, reverseFL, (:\/:)(..)-                               , (:/\:)(..), reverseRL, lengthFL-                               , lengthRL )-import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon,-                            showNons, showNon, readNons, readNon,-                            add, addP, addPs, remP, remPs, remNons,-                            (*>), (>*), (*>>), (>>*) )-import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL,-                                  genCommuteWhatWeCanRL,-                                  removeRL, removeFL, removeSubsequenceFL )-import Darcs.Patch.RepoPatch ()-import qualified Data.ByteString.Char8 as BC ( ByteString, pack )-import Darcs.Patch.ReadMonads ( skipSpace, string, choice )-import Darcs.Utils ( nubsort )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal )-import Darcs.Witnesses.Show ( Show2(..), ShowDict(..) )-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 prim C(x y) where-    Duplicate :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)-    Etacilpud :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)-    Normal :: prim C(x y) -> RealPatch prim C(x y)-    Conflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> Non (RealPatch prim) C(x) -> RealPatch prim C(y x)-    InvConflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> Non (RealPatch prim) C(x) -> RealPatch prim C(x y)--instance PrimPatch prim => PrimPatchBase (RealPatch prim) where-   type PrimOf (RealPatch prim) = prim---- | 'isDuplicate' @p@ is ' @True@ if @p@ is either a  'Duplicate' or 'Etacilpud' patch-isDuplicate :: RealPatch prim C(s y) -> Bool-isDuplicate (Duplicate _) = True-isDuplicate (Etacilpud _) = True-isDuplicate _ = False---- | This is only used for unit testing-isForward :: PrimPatch prim => RealPatch prim C(s y) -> Maybe Doc-isForward p@(InvConflictor _ _ _) =-    Just $ redText "An inverse conflictor" $$ showPatch p-isForward p@(Etacilpud _) =-    Just $ redText "An inverse duplicate" $$ showPatch p-isForward _ = Nothing--mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) C(x))] -> Maybe (FlippedSeal (RealPatch prim) 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 :: PrimPatch prim => Sealed ((FL prim) C(x)) -> Bool-          notNullS (Sealed NilFL) = False-          notNullS _ = True-          mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim C(x))] -> Maybe (RL (RealPatch prim) C(x x))-          mergeUnravelled_private xs = reverseFL `fmap` mergeConflictingNons-                                                        (map sealed2non $ filter notNullS xs)---- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.---   @xs@ must be non-empty since we split this list at the last patch-sealed2non :: Sealed ((FL prim) C(x)) -> Non (RealPatch prim) 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 :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> Maybe (FL (RealPatch prim) C(x x))-mergeConflictingNons ns = mcn $ map unNon ns-    where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))] -> Maybe (FL (RealPatch prim) C(x x))-          mcn [] = Just NilFL-          mcn [Sealed p] = case joinEffects 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)--joinEffects :: forall p C(x y)-             . (Effect p, Invert (PrimOf p), Commute (PrimOf p), MyEq (PrimOf p))-            => p C(x y) -> FL (PrimOf p) C(x y)-joinEffects = joinInverses . effect-    where joinInverses :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a b)-          joinInverses NilFL = NilFL-          joinInverses (p:>:ps) = case removeFL (invert p) ps' of-                                   Just ps'' -> ps''-                                   Nothing -> p :>: ps'-              where ps' = joinInverses ps--assertConsistent :: PrimPatch prim => RealPatch prim C(x y) -> RealPatch prim C(x y)-assertConsistent x = assertDoc (do e <- isConsistent 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 :: PrimPatch prim-                      => FL (RealPatch prim) C(x x) -> FL prim C(x y)-                      -> Maybe (FL (RealPatch prim) C(x x), FL (RealPatch prim) C(x y))-mergeAfterConflicting xxx yyy = --traceDoc (greenText "mergeAfterConflicting xxx" $$ showPatch xxx $$-                                --          greenText "and yyy" $$ showPatch yyy) $-                                mac (reverseFL xxx) yyy NilFL-    where mac :: PrimPatch prim-              => RL (RealPatch prim) C(x y) -> FL prim C(y z) -> FL (RealPatch prim) C(z a)-              -> Maybe (FL (RealPatch prim) C(x x), FL (RealPatch prim) C(x a))-          mac NilRL xs goneby = case joinEffects 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 commuteFLorComplain (p :> mapFL_FL Normal xs) of-                                   Left _  -> case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of-                                              a:>p':>b ->-                                                  do (b',xs') <- mac b xs goneby-                                                     let pa = joinEffects $ p':<:a-                                                     --traceDoc (greenText "foo1" $$-                                                     --          showPatch pa) $ Just ()-                                                     NilFL <- return pa-                                                     return (reverseRL (p':<:a)+>+b', xs')-                                                   `mplus` do NilFL <- return goneby-                                                              NilFL <- return $ joinEffects (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 commuteNoConflicts (ps :> p) of-                                              a:>p':>b ->-                                                  do (b',xs') <- mac b xs goneby-                                                     let pa = joinEffects $ p':<:a-                                                     --traceDoc (greenText "foo2" $$-                                                     --          showPatch pa) $ Just ()-                                                     NilFL <- return pa-                                                     return $ (reverseRL (p':<:a)+>+b', xs')--geteff :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> ([Non (RealPatch prim) C(x)], FL (RealPatch prim) 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 :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> [Non (RealPatch prim) C(x)]-xx2nons ix xx = fst $ geteff ix xx--xx2patches :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> FL (RealPatch prim) C(x y)-xx2patches ix xx = snd $ geteff ix xx---- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns---   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).---   Otherwise, it returns 'Nothing'.-allNormal :: FL (RealPatch prim) C(x y) -> Maybe (FL prim C(x y))-allNormal (Normal x:>:xs) = (x :>:) `fmap` allNormal xs-allNormal NilFL = Just NilFL-allNormal _ = Nothing---- | This is used for unit-testing and for internal sanity checks-isConsistent :: PrimPatch prim => RealPatch prim C(x y) -> Maybe Doc-isConsistent (Normal _) = Nothing-isConsistent (Duplicate _) = Nothing-isConsistent (Etacilpud _) = Nothing-isConsistent (Conflictor im mm m@(Non deps _))-    | not $ everyoneConflicts im = Just $ redText "Someone doesn't conflict in im in isConsistent"-    | Just _ <- remPs rmm m, _:>:_ <- mm = Just $ redText "m doesn't conflict with mm in isConsistent"-    | any (\x -> any (x `conflictsWith`) nmm) im-        = Just $ redText "mm conflicts with im in isConsistent 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 allConflictsWith m im of-                  (im1,[]) | im1 `eqSet` im -> Nothing-                  (_,imnc) -> Just $ redText "m doesn't conflict with im in isConsistent.  unconflicting:"-                              $$ showNons imnc-    where (nmm, rmm) = geteff im mm-isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c)--everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> Bool-everyoneConflicts [] = True-everyoneConflicts (x:xs) = case allConflictsWith x xs of-                            ([],_) -> False-                            (_,xs') -> everyoneConflicts xs'--prim2real :: prim C(x y) -> RealPatch prim C(x y)-prim2real = Normal--instance PrimPatch prim => Patchy (RealPatch prim)--mergeWith :: PrimPatch prim => Non (RealPatch prim) C(x) -> [Non (RealPatch prim) C(x)] -> Sealed (FL prim C(x))-mergeWith p [] = effect `mapSeal` unNon p-mergeWith p xs = mergeall $ map unNon $ (p:) $ unconflicting_of $-                  filter (\x -> not (p `dependsUpon` x) && not (p `conflictsWith` x)) xs-    where mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) 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 allConflictsWith q qs of-                                    ([],_) -> q:qs-                                    (_,nc) -> unconflicting_of nc--instance PrimPatch prim => Conflict (RealPatch prim) 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]-    resolveConflicts (Conflictor ix xx x) = [mangleUnravelled unravelled : unravelled]-            where unravelled = nub $ filter isn $ map (`mergeWith` (x:ix++nonxx)) (x:ix++nonxx)-                  nonxx = nonxx_ (nonxx_aux ix xx)-                  nonxx_aux :: [Non (RealPatch prim) C(x)] -> FL prim C(x y) -> RL (RealPatch prim) C(x y)-                  nonxx_aux a b = reverseFL $ xx2patches a b-                  nonxx_ :: RL (RealPatch prim) C(x y) -> [Non (RealPatch prim) C(x)]-                  nonxx_ NilRL = []-                  nonxx_ ((Normal q) :<: qs) = [Non (reverseRL qs) q]-                  nonxx_ _ = []-                  isn :: Sealed (FL p C(x)) -> Bool-                  isn (Sealed NilFL) = False-                  isn _ = True-    resolveConflicts _ = []--instance PrimPatch prim => CommuteNoConflicts (RealPatch prim) where-    -- cA-    commuteNoConflicts (Duplicate x :> Duplicate y) = Just (Duplicate y :> Duplicate x)-    commuteNoConflicts (Etacilpud x :> Duplicate y) = Just (Duplicate y :> Etacilpud x)-    commuteNoConflicts (Duplicate x :> Etacilpud y) = Just (Etacilpud y :> Duplicate x)-    commuteNoConflicts (Etacilpud x :> Etacilpud y) = Just (Etacilpud y :> Etacilpud x)-    -- cB-    commuteNoConflicts (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)-    commuteNoConflicts (Duplicate d' :> x) = Just (x :> Duplicate (addP (invert x) d'))-    commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c-    commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c-    -- cE-    commuteNoConflicts (Normal x :> Normal y) =   do y' :> x' <- commute (x :> y)-                                                     return (Normal y' :> Normal x')-    -- cF -- involves a conflict-    -- cG-    commuteNoConflicts (Normal x :> Conflictor iy yy y) =-        case commuteFLorComplain (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-    commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c-    -- icG FIXME: where is icF?-    commuteNoConflicts (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-    commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c-    -- cH -- this involves a conflict commute-    -- cI-    commuteNoConflicts (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 (conflictsWith y) (x':ix')-           False <- return $ any (conflictsWith x') iy-           return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')-    -- cHi+cIi            uses previous two matches-    commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommuteNC c-    -- cJ-    commuteNoConflicts (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 (conflictsWith y') (x':ix')-           False <- return $ any (conflictsWith x') iy'-           return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')-    -- icJ-    commuteNoConflicts (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 (conflictsWith y') (x':ix')-           False <- return $ any (conflictsWith x') iy'-           return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)--instance PrimPatch prim => Check (RealPatch prim) where-    isInconsistent = isConsistent--instance FromPrim (RealPatch prim) where-    fromPrim = prim2real-instance ToFromPrim (RealPatch prim) where-    toPrim (Normal p) = Just p-    toPrim _ = Nothing--instance PrimPatch prim => MyEq (RealPatch prim) 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 :: PrimPatch prim => Non (RealPatch prim) C(x) -> Non (RealPatch prim) 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 :: PatchInspect prim => Non (RealPatch prim) C(x) -> [FilePath]-nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)--nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool) -> Non (RealPatch prim) C(x) -> Bool-nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x--toNons :: forall p C(x y)-        . (Conflict p, Patchy p, PatchListFormat p, ToFromPrim p,-           Nonable p, ShowPatchBasic (PrimOf p))-       => FL p C(x y) -> [Non p C(x)]-toNons xs = map lastNon $ initsFL xs-    where lastNon :: 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 z) -> (RL p :> p) C(x z)-          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 :: (p :> FL p) C(x z) -> (RL p :> p :> RL p) C(x z)-          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)--filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) 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 prim => Invert (RealPatch prim) 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--instance PrimPatch prim => Commute (RealPatch prim) where---    commute (x :> y) | traceDoc (greenText "commuting x" $$ showPatch x $$---                                 greenText "with y" $$ showPatch y) False = undefined-    commute (x :> y) | Just (y' :> x') <- commuteNoConflicts (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 <- joinEffects 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 `dependsUpon` 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 $ allConflictsWith 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 $ allConflictsWith 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 <- joinEffects 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--instance PrimPatch prim => Merge (RealPatch prim) where-    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---    merge _ = error "haven't finished fixing merge"--instance PatchInspect prim => PatchInspect (RealPatch prim) where-    listTouchedFiles (Duplicate p) = nonTouches p-    listTouchedFiles (Etacilpud p) = nonTouches p-    listTouchedFiles (Normal p) = listTouchedFiles p-    listTouchedFiles (Conflictor x c p) =-        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p-    listTouchedFiles (InvConflictor x c p) =-        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p--    hunkMatches f (Duplicate p) = nonHunkMatches f p-    hunkMatches f (Etacilpud p) = nonHunkMatches f p-    hunkMatches f (Normal p) = hunkMatches f p-    hunkMatches f (Conflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]-    hunkMatches f (InvConflictor x c p) = or [or $ map (nonHunkMatches f) x, hunkMatches f c, nonHunkMatches f p]--{--allConflictsWithFL :: FL prim C(x y) -> [Non (RealPatch prim) C(x)]-                     -> ([Non (RealPatch prim) C(x)], [Non (RealPatch prim) C(x)])-allConflictsWithFL 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 allConflictsWith 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 commuteFLorComplain (Normal (invert p) :> xx') of-                                           Nothing -> True-                                           Just _ -> False--}-allConflictsWith :: PrimPatch prim-                   => Non (RealPatch prim) C(x) -> [Non (RealPatch prim) C(x)]-                   -> ([Non (RealPatch prim) C(x)], [Non (RealPatch prim) C(x)])-allConflictsWith x ys = acw $ partition (conflictsWith x) ys-    where acw ([],nc) = ([],nc)-          acw (c:cs, nc) = case allConflictsWith c nc of-                           (c1,nc1) -> case acw (cs, nc1) of-                                       (xs',nc') -> (c:c1++xs',nc')--conflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x) -> Non (RealPatch prim) C(x) -> Bool-conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False-conflictsWith x (Non cy y) =-    case remPs cy x of-    Just (Non cx' x') -> case commuteFLorComplain (fromPrim (invert y) :> cx' +>+ fromPrim x' :>: NilFL) of-                         Right _ -> False-                         Left _ -> True-    Nothing -> True--dependsUpon :: PrimPatch prim => Non (RealPatch prim) C(x) -> Non (RealPatch prim) C(x) -> Bool-dependsUpon (Non xs _) (Non ys y) =-    case removeSubsequenceFL (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 :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y) -> (RealPatch prim :/\: RealPatch prim) C(x y)-swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'--invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)-                            return (invert iy' :> invert ix')--invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-invertCommuteNC (x :> y) = do ix' :> iy' <- commuteNoConflicts (invert y :> invert x)-                              return (invert iy' :> invert ix')---- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted---   out of both @xs@ and @ys@ along with the remnants of both lists-pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)-pullCommon NilFL ys = Common NilFL NilFL ys-pullCommon xs NilFL = Common NilFL xs NilFL-pullCommon (x:>:xs) xys | Just ys <- removeFL x xys = case pullCommon xs ys of-                                                      Common c xs' ys' -> Common (x:>:c) xs' ys'-pullCommon (x:>:xs) ys = case commuteWhatWeCanFL (x :> xs) of-                         xs1:>x':>xs2 -> case pullCommon xs1 ys of-                                         Common c xs1' ys' -> Common c (xs1'+>+x':>:xs2) ys'---- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in common,---   in other words @cs +>+ xs@ and @cs +>+ ys@-data Common p C(o x y) where-    Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)---- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted---   out of both @xs@ and @ys@ along with the remnants of both lists-pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)-pullCommonRL NilRL ys = CommonRL NilRL ys NilRL-pullCommonRL xs NilRL = CommonRL xs NilRL NilRL-pullCommonRL (x:<:xs) xys-    | Just ys <- removeRL x xys = case pullCommonRL xs ys of-                                  CommonRL xs' ys' c -> CommonRL xs' ys' (x:<:c)-pullCommonRL (x:<:xs) ys =-    case commuteWhatWeCanRL (xs :> x) of-    xs1:>x':>xs2 -> case pullCommonRL xs2 ys of-                    CommonRL xs2' ys' c -> CommonRL (xs2'+<+x':<:xs1) ys' c---- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ in common,---   in other words @xs +<+ cs@ and @ys +<+ cs@-data CommonRL p C(x y f) where-    CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)--instance PrimPatch prim => Apply (RealPatch prim) where-    type ApplyState (RealPatch prim) = ApplyState prim-    apply p = apply (effect p)--instance PrimPatch prim => RepairToFL (RealPatch prim) where-    applyAndTryToFixFL (Normal p) = mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p-    applyAndTryToFixFL x = do apply x; return Nothing--instance PatchListFormat (RealPatch prim) where-   -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,-   -- as those are the only case where we need to support a legacy on-disk-   -- format. In practice we don't expect RealPatch to be used with any other argument-   -- anyway, so it doesn't matter.-    patchListFormat = ListFormatV2--instance PrimPatch prim => ShowPatchBasic (RealPatch prim) 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 "[" $$-        showPrimFL NewFormat 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 "[" $$-        showPrimFL NewFormat cs $$-        blueText "]" $$-        showNon p--instance PrimPatch prim => ShowPatch (RealPatch prim) where-    showContextPatch (Normal p) = showContextPatch p-    showContextPatch c = return $ showPatch c-    summary = plainSummary-    summaryFL = plainSummary-    thing _ = "change"--instance PrimPatch prim => ReadPatch (RealPatch prim) where- readPatch' = skipSpace >> choice-      [ do string duplicate-           p <- readNon-           return $ Sealed $ Duplicate p-      , do string etacilpud-           p <- readNon-           return $ Sealed $ Etacilpud p-      , do string conflictor-           i <- readNons-           Sealed ps <- bracketedFL (readPrim NewFormat) '[' ']'-           p <- readNon-           return $ Sealed $ Conflictor i (unsafeCoerceP ps) p-      , do string rotcilfnoc-           i <- readNons-           Sealed ps <- bracketedFL (readPrim NewFormat) '[' ']'-           p <- readNon-           return $ Sealed $ InvConflictor i ps p-      , do Sealed p <- readPrim NewFormat-           return $ Sealed $ Normal p-      ]--duplicate :: BC.ByteString-duplicate = BC.pack "duplicate"--etacilpud :: BC.ByteString-etacilpud = BC.pack "etacilpud"--conflictor :: BC.ByteString-conflictor = BC.pack "conflictor"--rotcilfnoc :: BC.ByteString-rotcilfnoc = BC.pack "rotcilfnoc"--instance PrimPatch prim => Show (RealPatch prim C(x y)) where-    show p = renderString $ showPatch p--instance PrimPatch prim => Show2 (RealPatch prim) where-    showDict2 = ShowDictClass--instance PrimPatch prim => Nonable (RealPatch prim) 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+module Darcs.Patch.V2.Real+    ( RealPatch(..)+    , prim2real+    , isConsistent+    , isForward+    , isDuplicate+    , mergeUnravelled+    ) where++import Control.Monad ( mplus, liftM )+import qualified Data.ByteString.Char8 as BC ( ByteString, pack )+import Data.Maybe ( fromMaybe )+import Data.List ( partition, nub )++import Darcs.ColorPrinter ( errorDoc, assertDoc )+import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL+                           , commuteRLFL )+import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..)+                            , IsConflictedPrim(..), ConflictState(..) )+import Darcs.Patch.ConflictMarking ( mangleUnravelled )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..)+                          , FileNameFormat(NewFormat) )+import Darcs.Patch.Invert ( invertFL, invertRL )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL+                        , readPrim, PrimOf, PrimPatchBase, PrimPatch )+import Darcs.Patch.Read ( bracketedFL )+import Darcs.Patch.ReadMonads ( skipSpace, string, choice )+import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) )+import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..)+                          , ReadPatch(..), ShowPatch(..), Invert(..) )+import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL+                                , genCommuteWhatWeCanRL, removeRL, removeFL+                                , removeSubsequenceFL )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon+                          , readNons, readNon, commutePrimsOrAddToCtx+                          , commuteOrAddToCtx, commuteOrAddToCtxRL+                          , commuteOrRemFromCtx, commuteOrRemFromCtxFL+                          , remNons, (*>), (>*), (*>>), (>>*) )+import Darcs.Utils ( nubsort )+import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), (+<+)+                               , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)+                               , reverseRL, lengthFL, lengthRL, nullFL )+import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal+                              , unseal )+import Darcs.Witnesses.Show ( Show2(..), ShowDict(..) )++import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )++#include "impossible.h"++-- |'RealPatch' is used to represents prim patches that are duplicates of, or+-- conflict with, another prim patch in the repository.+--+-- @Normal prim@: A primitive patch+--+-- @Duplicate x@: This patch has no effect since @x@ is already present in the+-- repository.+--+-- @Etacilpud x: invert (Duplicate x)@+--+-- @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 original, conflicting patch.+--+-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary+--  context to uniquely define the patch that is referred to.+--+-- The intuition is that a Conflictor should have the effect of inverting any+-- patches that 'x' conflicts with, that haven't already been undone by another+-- Conflictor in the repository.+-- Therefore, the effect of a Conflictor is @invert xx@.+--+-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@+data RealPatch prim C(x y) where+    Duplicate :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)+    Etacilpud :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)+    Normal :: prim C(x y) -> RealPatch prim C(x y)+    Conflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)+               -> Non (RealPatch prim) C(x) -> RealPatch prim C(y x)+    InvConflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)+                  -> Non (RealPatch prim) C(x) -> RealPatch prim C(x y)++instance PrimPatch prim => PrimPatchBase (RealPatch prim) where+   type PrimOf (RealPatch prim) = prim++-- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud'+-- patch.+isDuplicate :: RealPatch prim C(s y) -> Bool+isDuplicate (Duplicate _) = True+isDuplicate (Etacilpud _) = True+isDuplicate _ = False++-- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or+-- 'Etacilpud'.+isForward :: PrimPatch prim => RealPatch prim C(s y) -> Maybe Doc+isForward = isForward'+  where+    isForward' p@(InvConflictor _ _ _) = justRedP "An inverse conflictor" p+    isForward' p@(Etacilpud _) = justRedP "An inverse duplicate" p+    isForward' _ = Nothing+    justRedP msg p = Just $ redText msg $$ showPatch p++-- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers)+-- to Darcs V2 patches (Conflictors).+mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) C(x))]+                -> Maybe (FlippedSeal (RealPatch prim) 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 :: PrimPatch prim => Sealed ((FL prim) C(x)) -> Bool+    notNullS (Sealed NilFL) = False+    notNullS _ = True++    mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim C(x))]+                            -> Maybe (RL (RealPatch prim) C(x x))+    mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in+        reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs)++    -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.+    -- @xs@ must be non-empty since we split this list at the last patch,+    -- taking @init xs@ as the context of @last xs@.+    sealed2non :: Sealed ((FL prim) C(x)) -> Non (RealPatch prim) 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 :: PrimPatch prim => [Non (RealPatch prim) C(x)]+                     -> Maybe (FL (RealPatch prim) C(x x))+mergeConflictingNons ns = mcn $ map unNon ns+    where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))]+              -> Maybe (FL (RealPatch prim) C(x x))+          mcn [] = Just NilFL+          -- Apparently, the joinEffects call is a safety check "and could be+          -- removed when we're sure of the code"!+          mcn [Sealed p] = case joinEffects p of+                               NilFL -> Just p+                               _ -> 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)++joinEffects :: forall p C(x y) . (Effect p, Invert (PrimOf p),+            Commute (PrimOf p), MyEq (PrimOf p)) => p C(x y)+            -> FL (PrimOf p) C(x y)+joinEffects = joinInverses . effect+    where joinInverses :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a b)+          joinInverses NilFL = NilFL+          joinInverses (p :>: ps) =+              let ps' = joinInverses ps in+              fromMaybe (p :>: ps') $ removeFL (invert p) ps'++assertConsistent :: PrimPatch prim => RealPatch prim C(x y)+                 -> RealPatch prim C(x y)+assertConsistent x = flip assertDoc x $ do+    e <- isConsistent x+    Just (redText "Inconsistent patch:" $$ showPatch x $$ e)++-- | @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 :: PrimPatch prim => FL (RealPatch prim) C(x x)+                      -> FL prim C(x y) -> Maybe ( FL (RealPatch prim) C(x x)+                                                 , FL (RealPatch prim) C(x y))+mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL+  where+    mac :: PrimPatch prim+        => RL (RealPatch prim) C(x y) -> FL prim C(y z)+        -> FL (RealPatch prim) C(z a)+        -> Maybe (FL (RealPatch prim) C(x x), FL (RealPatch prim) C(x a))+    mac NilRL xs goneby = case joinEffects goneby of+                              NilFL -> Just (NilFL, mapFL_FL Normal xs)+                              _ -> Nothing+    mac (p :<: ps) xs goneby =+        case commuteFLorComplain (p :> mapFL_FL Normal xs) of+            Left _ ->+                case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of+                    a :> p' :> b ->+                        do (b', xs') <- mac b xs goneby+                           let pa = joinEffects $ p' :<: a+                           NilFL <- return pa+                           return (reverseRL (p' :<: a) +>+ b', xs')+                        `mplus`+                        do NilFL <- return goneby+                           NilFL <- return $ joinEffects (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 commuteNoConflicts (ps :> p) of+                            a :> p' :> b ->+                                do (b', xs') <- mac b xs goneby+                                   let pa = joinEffects $ p' :<: a+                                   NilFL <- return pa+                                   return (reverseRL (p' :<: a) +>+ b', xs')++geteff :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)+       -> ([Non (RealPatch prim) C(x)], FL (RealPatch prim) C(x y))+geteff _ NilFL = ([], NilFL)+geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix =+    case geteff ix' xs of+        (ns, xs') -> ( non (Normal x) : map (commuteOrAddToCtx (Normal x)) ns+                     , Normal x :>: xs')+geteff ix xx =+    case mergeConflictingNons ix of+        Nothing -> errorDoc $+            redText "mergeConflictingNons failed in geteff: ix" $$+            showNons ix $$ redText "xx" $$ showPatch xx+        Just rix ->+            case mergeAfterConflicting rix xx of+                Just (a, x) ->+                    ( map (commuteOrAddToCtxRL (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 :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)+        -> [Non (RealPatch prim) C(x)]+xx2nons ix xx = fst $ geteff ix xx++xx2patches :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)+           -> FL (RealPatch prim) C(x y)+xx2patches ix xx = snd $ geteff ix xx++-- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns+--   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).+--   Otherwise, it returns 'Nothing'.+allNormal :: FL (RealPatch prim) C(x y) -> Maybe (FL prim C(x y))+allNormal (Normal x :>: xs) = (x  :>: ) `fmap` allNormal xs+allNormal NilFL = Just NilFL+allNormal _ = Nothing++-- | This is used for unit-testing and for internal sanity checks+isConsistent :: PrimPatch prim => RealPatch prim C(x y) -> Maybe Doc+isConsistent (Normal _) = Nothing+isConsistent (Duplicate _) = Nothing+isConsistent (Etacilpud _) = Nothing+isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c)+isConsistent (Conflictor im mm m@(Non deps _))+    | not $ everyoneConflicts im =+        Just $ redText "Someone doesn't conflict in im in isConsistent"+    | Just _ <- commuteOrRemFromCtxFL rmm m, _ :>: _ <- mm =+        Just $ redText "m doesn't conflict with mm in isConsistent"+    | any (\x -> any (x `conflictsWith`) nmm) im =+        Just $ redText "mm conflicts with im in isConsistent 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 allConflictsWith m im of+            (im1, []) | im1 `eqSet` im -> Nothing+            (_, imnc) -> Just $ redText ("m doesn't conflict with im in "+                                         ++ "isConsistent. unconflicting:") $$+                                showNons imnc+    where (nmm, rmm) = geteff im mm++everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> Bool+everyoneConflicts [] = True+everyoneConflicts (x : xs) = case allConflictsWith x xs of+                                 ([], _) -> False+                                 (_, xs') -> everyoneConflicts xs'++prim2real :: prim C(x y) -> RealPatch prim C(x y)+prim2real = Normal++instance PrimPatch prim => Patchy (RealPatch prim)++mergeWith :: PrimPatch prim => Non (RealPatch prim) C(x)+          -> [Non (RealPatch prim) C(x)] -> Sealed (FL prim C(x))+mergeWith p [] = effect `mapSeal` unNon p+mergeWith p xs =+    mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs+  where+    nonDependsOrConflictsP =+        filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x)))+    mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) 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 allConflictsWith q qs of+                                    ([], _) -> q : qs+                                    (_, nc) -> unconflicting_of nc++instance PrimPatch prim => Conflict (RealPatch prim) 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]+    resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled]+      where+        mangledUnravelled = mangleUnravelled unravelled+        unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX+        xIxNonXX = x : ix ++ nonxx+        nonxx = nonxx_ (reverseFL $ xx2patches ix xx)+        -- |nonxx_ takes an RL of patches, and returns a singleton list+        -- containing a Non, in the case where we have a Normal patch at the+        -- end of the list (using the rest of the RL as context), and an empty+        -- list otherwise.+        nonxx_ :: RL (RealPatch prim) C(x y) -> [Non (RealPatch prim) C(x)]+        nonxx_ (Normal q :<: qs) = [Non (reverseRL qs) q]+        nonxx_ _ = []+        isCons = unseal (not . nullFL)+    resolveConflicts _ = []++instance PrimPatch prim => CommuteNoConflicts (RealPatch prim) where+    commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1)+    commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e)+    commuteNoConflicts (d@(Duplicate _) :> e@(Etacilpud _)) = Just (e :> d)+    commuteNoConflicts (e1@(Etacilpud _) :> e2@(Etacilpud _)) = Just (e2 :> e1)++    -- If the duplicate is @x@, as a 'Non', with @invert x@ as the context,+    -- then it is the patch the duplicate @d@ represents, so commuting results+    -- in the same two patches (since we'd make one a duplicate, and the other+    -- would become @x@ as it would no longer be duplicated).+    -- Otherwise, we commute past, or remove @invert x@ from the context of @d@+    -- to obtain a new Duplicate.+    commuteNoConflicts orig@(x :> Duplicate d) =+        if d == commuteOrAddToCtx (invert x) (non x)+            then Just orig+            else do d' <- commuteOrRemFromCtx (invert x) d+                    return (Duplicate d' :> x)++    -- Commuting a Duplicate and any other patch simply places @invert x@ into+    -- the context of the non @d@, by commuting past, or adding to the context.+    commuteNoConflicts (Duplicate d :> x) =+        Just (x :> Duplicate (commuteOrAddToCtx (invert x) d))++    -- handle Etacilpud cases by first inverting, then using the previous+    -- definitions.+    commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c+    commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c++    -- Two normal patches should be simply commuted (assuming the can).+    commuteNoConflicts (Normal x :> Normal y) = do+        y' :> x' <- commute (x :> y)+        return (Normal y' :> Normal x')++    -- Commuting a Normal patch past a Conflictor first commutes @x@ past the+    -- effect of the Conflictor, then commutes the resulting @x'@ past the+    -- conflicting patch and the already-undone patches. The commuting must be+    -- done in this order to make the contexts match up (@iy@ and @y@ are made+    -- in the context before @yy@ have their effect, so we need to commute past+    -- the effect of @yy@ first).+    commuteNoConflicts (Normal x :> Conflictor iy yy y) = do+        iyy' :> x' <- commuteFL (x :> invert yy)+        y' : iy' <- mapM (Normal x' >*) (y : iy)+        return (Conflictor iy' (invert iyy') y' :> Normal x')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c++    -- Commuting a Conflictor past a Normal patch is the dual operation to+    -- commuting a Normal patch past a Conflictor.+    commuteNoConflicts (Conflictor iy yy y :> Normal x) = do+        y' : iy' <- mapM (*> Normal x) (y : iy)+        x' :> iyy' <- commuteRL (invertFL yy :> x)+        return (Normal x' :> Conflictor iy' (invertRL iyy') y')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c++    -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors'+    -- effects, then commutes the effect of c1 and c2 and the other's+    -- already-undone, and conflicting patch, to bring the already-undone and+    -- conflicting patch into the context of the commuted effects.+    commuteNoConflicts (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 (conflictsWith y) (x':ix')+        False <- return $ any (conflictsWith x') iy+        return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) =+        invertCommuteNC c++    commuteNoConflicts (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 (conflictsWith y') (x':ix')+        False <- return $ any (conflictsWith x') iy'+        return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')++    commuteNoConflicts (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 (conflictsWith y') (x':ix')+        False <- return $ any (conflictsWith x') iy'+        return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)++instance PrimPatch prim => Check (RealPatch prim) where+    isInconsistent = isConsistent++instance FromPrim (RealPatch prim) where+    fromPrim = prim2real++instance ToFromPrim (RealPatch prim) where+    toPrim (Normal p) = Just p+    toPrim _ = Nothing++instance PrimPatch prim => MyEq (RealPatch prim) 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 commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy+          && commuteOrAddIXX x == commuteOrAddIYY y = xx =/\= yy+      where+          commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx)+          commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL 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) = if x == y then Just ys else (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 :: PrimPatch prim => Non (RealPatch prim) C(x)+          -> Non (RealPatch prim) C(x)+invertNon (Non c x)+    | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)+    | otherwise = commuteOrAddToCtxRL (Normal x :<: reverseFL c) $ non nix+  where+    nix = Normal $ invert x++nonTouches :: PatchInspect prim => Non (RealPatch prim) C(x) -> [FilePath]+nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)++nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool)+               -> Non (RealPatch prim) C(x) -> Bool+nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x++toNons :: forall p C(x y) . (Conflict p, Patchy p, PatchListFormat p,+       ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p)) => FL p C(x y)+       -> [Non p C(x)]+toNons xs = map lastNon $ initsFL xs+    where lastNon :: 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 z) -> (RL p :> p) C(x z)+          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 :: (p :> FL p) C(x z) -> (RL p :> p :> RL p) C(x z)+          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)++filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) C(x)+                  -> FL prim C(x y) -> (FL prim :> FL prim) C(x y)+filterConflictsFL _ NilFL = NilFL :> NilFL+filterConflictsFL n (p :>: ps)+    | Just n' <- commuteOrRemFromCtx (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 prim => Invert (RealPatch prim) 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++instance PrimPatch prim => Commute (RealPatch prim) where+    commute (x :> y) | Just (y' :> x') <-+        commuteNoConflicts (assertConsistent x :> assertConsistent y) =+        Just (y' :> x')++    -- These patches conflicted, since we failed to commuteNoConflicts in the+    -- case above.+    commute (Normal x :> Conflictor a1'nop2 n1'x p1')+        | 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 <- joinEffects c ->+                    Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2)+                (a1, n1, _) ->+                    Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)++    -- Handle using the inverting commuter, and the previous case.  N.b. this+    -- is innefficient, since we'll have to also try commuteNoConflicts again+    -- (which we know will fail, since we got here).+    commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c++    commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)+        | Just a2_minus_p1 <- remove1 p1' a2+        , not (p2 `dependsUpon` p1') = do+            let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1+                n2nons = xx2nons a2 n2+                Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons+                n2n1 = n2 +>+ n1+                a1' = map (commutePrimsOrAddToCtx 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 =+                    fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons)+                    `minus` n2'nons+                Just a2' =+                    mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o+                Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2+            case (a2', n2', p2') of+                ([], NilFL, Non c x) ->+                    case joinEffects c of+                        NilFL -> let n1'x = n1' +>+ x :>: NilFL in+                                 Just (Normal x :> Conflictor a1'nop2 n1'x p1')+                        _ -> impossible+                _ -> Just (c1 :> c2)+                  where+                    c1 = Conflictor a2' n2' p2'+                    c2 = Conflictor (p2 : a1'nop2) n1' p1'++        where (_, rpn2) = geteff a2 n2+              p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1++    -- Handle using the inverting commuter, and the previous case. This is also+    -- innefficient, since we'll have to also try commuteNoConflicts again+    -- (which we know will fail, since we got here).+    commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c++    commute _ = Nothing++instance PrimPatch prim => Merge (RealPatch prim) where+    merge (InvConflictor _ _ _ :\/: _) = impossible+    merge (_ :\/: InvConflictor _ _ _) = impossible+    merge (Etacilpud _ :\/: _) = impossible+    merge (_ :\/: Etacilpud _) = impossible+++    merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a+    -- We had a FIXME comment on this case, why?+    merge (Duplicate a :\/: b) =+        b :/\: Duplicate (commuteOrAddToCtx (invert b) a)++    -- Handle using the swap merge and the previous case.+    merge m@(_ :\/: Duplicate _) = swapMerge m++    -- When merging x and y, we do a bunch of what look like "consistency"+    -- check merges. If the resulting y'' and y are equal, then we succeed.+    -- If the first case fails, we check for equal patches (which wouldn't+    -- commute) and return a Duplicate on both sides of the merge, in that+    -- case.+    merge (x :\/: y)+        | Just (y' :> ix') <-+            commute (invert (assertConsistent x) :> assertConsistent y)+        , Just (y'' :> _) <- commute (x :> y')+        , IsEq <- y'' =\/= y =+            assertConsistent y' :/\: invert (assertConsistent ix')+        -- If we detect equal patches, we have a duplicate.+        | IsEq <- x =\/= y+        , n <- commuteOrAddToCtx (invert x) $ non x =+            Duplicate n :/\: Duplicate n++    -- We know that these two patches conflict, and aren't Duplicates, since we+    -- failed the previous case. We therefore create basic Conflictors, which+    -- undo the other patch.+    merge (nx@(Normal x) :\/: ny@(Normal y)) = cy :/\: cx+      where+        cy = Conflictor [] (x :>: NilFL) (non ny)+        cx = Conflictor [] (y :>: NilFL) (non nx)++    -- If a Normal patch @x@ and a Conflictor @cy@ conflict, we add @x@ to the+    -- effect of @cy@ on one side, and create a Conflictor that has no effect,+    -- but has the already-undone and conflicted patch of @cy@ and some foos as+    -- the already-undone on the other side.+    --+    -- TODO: what is foo?+    -- Why do we need nyy? I think @x'@ is @x@ in the context of @yy@.+    merge (Normal x :\/: 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++    -- Handle using the swap merge and the previous case.+    merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m++    -- 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 (commutePrimsOrAddToCtx xx') (y : iy)+                            x' : ix' =+                                map (commutePrimsOrAddToCtx ryy') (x : ix)+                            nyy' = xx2nons iy' yy'+                            nxx' = xx2nons ix' xx'+                            icx = drop (lengthRL rxx1) $+                                xx2nons ix (reverseRL $ c +<+ rxx1)+                            ic' = map (commutePrimsOrAddToCtx ryy') icx+                            -- +++ is a more efficient version of nub (iy' +++                            -- ix') given that we know each element shows up+                            -- only once in either list.+                            ixy' = ic' ++ (iy' +++ ix')+                            c1 = Conflictor (x' : ixy' ++ nxx') yy' y'+                            c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in+                            c1 :/\: c2+                    Nothing -> impossible++instance PatchInspect prim => PatchInspect (RealPatch prim) where+    listTouchedFiles (Duplicate p) = nonTouches p+    listTouchedFiles (Etacilpud p) = nonTouches p+    listTouchedFiles (Normal p) = listTouchedFiles p+    listTouchedFiles (Conflictor x c p) =+        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p+    listTouchedFiles (InvConflictor x c p) =+        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p++    hunkMatches f (Duplicate p) = nonHunkMatches f p+    hunkMatches f (Etacilpud p) = nonHunkMatches f p+    hunkMatches f (Normal p) = hunkMatches f p+    hunkMatches f (Conflictor x c p) =+        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p+    hunkMatches f (InvConflictor x c p) =+        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p++allConflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)+                 -> [Non (RealPatch prim) C(x)]+                 -> ([Non (RealPatch prim) C(x)], [Non (RealPatch prim) C(x)])+allConflictsWith x ys = acw $ partition (conflictsWith x) ys+  where+    acw ([], nc) = ([], nc)+    acw (c:cs, nc) = case allConflictsWith c nc of+                         (c1, nc1) -> case acw (cs, nc1) of+                                          (xs', nc') -> (c : c1 ++ xs', nc')++conflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)+              -> Non (RealPatch prim) C(x) -> Bool+conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False+conflictsWith x (Non cy y) =+    case commuteOrRemFromCtxFL cy x of+        Just (Non cx' x') ->+            let iy = fromPrim $ invert y in+            case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of+                Right _ -> False+                Left _ -> True+        Nothing -> True++dependsUpon :: PrimPatch prim => Non (RealPatch prim) C(x)+            -> Non (RealPatch prim) C(x) -> Bool+dependsUpon (Non xs _) (Non ys y) =+    case removeSubsequenceFL (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 :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y)+          -> (RealPatch prim :/\: RealPatch prim) C(x y)+swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'++invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)+              -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))+invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)+                            return (invert iy' :> invert ix')++invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)+                -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))+invertCommuteNC (x :> y) = do+    ix' :> iy' <- commuteNoConflicts (invert y :> invert x)+    return (invert iy' :> invert ix')++-- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out+-- of both @xs@ and @ys@ along with the remnants of both lists+pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)+pullCommon NilFL ys = Common NilFL NilFL ys+pullCommon xs NilFL = Common NilFL xs NilFL+pullCommon (x :>: xs) xys | Just ys <- removeFL x xys =+    case pullCommon xs ys of+        Common c xs' ys' -> Common (x :>: c) xs' ys'+pullCommon (x :>: xs) ys =+    case commuteWhatWeCanFL (x :> xs) of+        xs1 :> x' :> xs2 -> case pullCommon xs1 ys of+            Common c xs1' ys' -> Common c (xs1' +>+ x' :>: xs2) ys'++-- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in+-- common, in other words @cs +>+ xs@ and @cs +>+ ys@+data Common p C(o x y) where+    Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)++-- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted+--   out of both @xs@ and @ys@ along with the remnants of both lists+pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)+pullCommonRL NilRL ys = CommonRL NilRL ys NilRL+pullCommonRL xs NilRL = CommonRL xs NilRL NilRL+pullCommonRL (x :<: xs) xys | Just ys <- removeRL x xys =+    case pullCommonRL xs ys of+        CommonRL xs' ys' c -> CommonRL xs' ys' (x :<: c)+pullCommonRL (x :<: xs) ys =+    case commuteWhatWeCanRL (xs :> x) of+        xs1 :> x' :> xs2 ->+            case pullCommonRL xs2 ys of+                CommonRL xs2' ys' c -> CommonRL (xs2' +<+ x' :<: xs1) ys' c++-- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@+-- in common, in other words @xs +<+ cs@ and @ys +<+ cs@+data CommonRL p C(x y f) where+    CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)++instance PrimPatch prim => Apply (RealPatch prim) where+    type ApplyState (RealPatch prim) = ApplyState prim+    apply p = apply (effect p)++instance PrimPatch prim => RepairToFL (RealPatch prim) where+    applyAndTryToFixFL (Normal p) =+        mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p+    applyAndTryToFixFL x = do apply x; return Nothing++instance PatchListFormat (RealPatch prim) where+   -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,+   -- as those are the only case where we need to support a legacy on-disk+   -- format. In practice we don't expect RealPatch to be used with any other+   -- argument anyway, so it doesn't matter.+    patchListFormat = ListFormatV2++duplicate, etacilpud, conflictor, rotcilfnoc :: String+duplicate = "duplicate"+etacilpud = "etacilpud"+conflictor = "conflictor"+rotcilfnoc = "rotcilfnoc"++instance PrimPatch prim => ShowPatchBasic (RealPatch prim) 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 "[" $$+        showPrimFL NewFormat 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 "[" $$+        showPrimFL NewFormat cs $$+        blueText "]" $$+        showNon p++instance PrimPatch prim => ShowPatch (RealPatch prim) where+    showContextPatch (Normal p) = showContextPatch p+    showContextPatch c = return $ showPatch c+    summary = plainSummary+    summaryFL = plainSummary+    thing _ = "change"++instance PrimPatch prim => ReadPatch (RealPatch prim) where+    readPatch' = do+        skipSpace+        let str = string . BC.pack+            readConflictorPs = do+               i <- readNons+               ps <- bracketedFL (readPrim NewFormat) '[' ']'+               p <- readNon+               return (i, ps, p)+        choice [ do str duplicate+                    p <- readNon+                    return $ Sealed $ Duplicate p+               , do str etacilpud+                    p <- readNon+                    return $ Sealed $ Etacilpud p+               , do str conflictor+                    (i, Sealed ps, p) <- readConflictorPs+                    return $ Sealed $ Conflictor i (unsafeCoerceP ps) p+               , do str rotcilfnoc+                    (i, Sealed ps, p) <- readConflictorPs+                    return $ Sealed $ InvConflictor i ps p+               , do Sealed p <- readPrim NewFormat+                    return $ Sealed $ Normal p+               ]++instance PrimPatch prim => Show (RealPatch prim C(x y)) where+    show p = renderString $ showPatch p++instance PrimPatch prim => Show2 (RealPatch prim) where+    showDict2 = ShowDictClass++instance PrimPatch prim => Nonable (RealPatch prim) where+    non (Duplicate d) = d+    non (Etacilpud d) = invertNon d -- FIXME !!! ???+    non (Normal p) = Non NilFL p+    non (Conflictor _ xx x) = commutePrimsOrAddToCtx (invertFL xx) x     non (InvConflictor _ _ n) = invertNon n  instance PrimPatch prim => Effect (RealPatch prim) where

@@ -27,6 +27,7 @@ import Storage.Hashed.Tree( Tree ) import Storage.Hashed.Monad( virtualTreeIO ) import Darcs.Arguments ( DarcsFlag, showFriendly )+import Darcs.Flags ( isUnified ) import Printer ( putDocLnWith ) import Darcs.ColorPrinter ( fancyPrinters ) import Darcs.External ( viewDocWith )@@ -34,8 +35,10 @@ -- | @'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+printFriendly :: (Patchy p, ApplyState p ~ Tree)  => (Maybe (Tree IO)) -> [DarcsFlag] -> p C(x y) -> IO ()+printFriendly (Just pristine) opts p+ | isUnified opts = virtualTreeIO (showContextPatch p) pristine >>= putDocLnWith fancyPrinters . fst+printFriendly _ opts p = putDocLnWith fancyPrinters $ showFriendly opts p  -- | 'printPatch' prints a patch on standard output. printPatch :: Patchy p => p C(x y) -> IO ()

@@ -46,8 +46,8 @@     ) where  import System.Exit ( ExitCode(..), exitWith )-import Data.List ( isPrefixOf )-import Data.Maybe( catMaybes, isJust )+import Data.List ( isPrefixOf)+import Data.Maybe( catMaybes, isJust, listToMaybe )  import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges                              , readPending, readIndex, invalidateIndex@@ -369,13 +369,9 @@   return ()  cacheDir :: Cache -> Maybe String-cacheDir (Ca cs) = safeHead . catMaybes .flip map cs $ \x -> case x of+cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of   Cache Directory Writable x' -> Just x'   _ -> Nothing--safeHead :: [a] -> Maybe a-safeHead [] = Nothing-safeHead (x:_) = Just x  hashedPatchFileName :: PatchInfoAnd p C(a b) -> String hashedPatchFileName x = case extractHash x of

@@ -233,7 +233,7 @@  copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO () copyFilesUsingCache oos cache subdir hs =-    do forM_ hs $ copyFileUsingCache oos cache subdir+    forM_ hs $ copyFileUsingCache oos cache subdir   data FromWhere = LocalOnly | Anywhere deriving ( Eq )@@ -411,7 +411,7 @@ reportBadSources = do   sources <- getBadSourcesList   let size = length sources-  unless (null sources) $ do+  unless (null sources) $    hPutStrLn stderr $     concat [ "\nHINT: I could not reach the following ", englishNum size  (Noun "repository") ":"            , "\n", (intercalate "\n" (map ("        " ++) sources))

@@ -413,6 +413,10 @@     x <- fst <$> readInventoryPrivate (Ca []) (darcsdir </> "inventories") i     (i :) <$> maybe (return []) f x +-- | 'readPatchIds inventory' parses the content of a hashed_inventory file+-- after the "pristine:" and "Starting with inventory:" header lines have+-- been removed.  The second value in the resulting tuples is the file hash+-- of the associated patch (the "hash:" line). readPatchIds :: B.ByteString -> [(PatchInfo, String)] readPatchIds inv | B.null inv = [] readPatchIds inv = case parseStrictly readPatchInfo inv of

@@ -49,7 +49,7 @@                     makeNewPending, seekRepo                   ) where -import Printer ( putDocLn, (<+>), text, ($$), redText, putDocWith, (<>), ($$))+import Printer ( putDocLn, (<+>), text, ($$), redText, putDocLnWith, (<>), ($$)) import Darcs.ColorPrinter (fancyPrinters)  import Darcs.Repository.Prefs ( getPrefval )@@ -473,10 +473,10 @@     [] -> return False     cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts               || wantExternalMerge opts /= Nothing-           then do putDocWith fancyPrinters $ +           then do putDocLnWith fancyPrinters $                       redText "We have conflicts in the following files:" $$ text (unwords cfs)                    return True-           else do putDocWith fancyPrinters $+           else do putDocLnWith fancyPrinters $                      redText "There are conflicts in the following files:" $$ text (unwords cfs)                    fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++                           "If you would rather apply the patch and mark the conflicts,\n"++

@@ -80,7 +80,7 @@                                   then seal NilFL                                   else seal standard_resolved_pw           (_,False) -> return $ seal standard_resolved_pw-          (Just c, True) -> externalResolution working c+          (Just c, True) -> externalResolution working c opts                                                     (effect us +>+ pend)                                                     (effect them) pwprim      debugMessage "Applying patches to the local directories..."

@@ -45,7 +45,7 @@ import qualified Data.ByteString.Char8 as BSC  import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, effect )-import Darcs.Patch.Apply ( ApplyState, applyToTree, applyToFilepaths )+import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths ) import Darcs.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL ) import Darcs.Witnesses.Eq ( EqCheck(IsEq, NotEq) ) import Darcs.Witnesses.Unsafe ( unsafeCoerceP )@@ -93,7 +93,7 @@ restrictSubpaths repo subpaths = do   Sealed pending <- readPendingLL repo   let paths = map (fn2fp . sp2fn) subpaths-      paths' = paths `union` applyToFilepaths pending paths+      paths' = paths `union` (effectOnFilePaths pending paths)       anchored = map floatPath paths'       restrictPaths :: FilterTree tree m => tree m -> tree m       restrictPaths = filter (filterPaths anchored)

@@ -32,7 +32,7 @@  import Darcs.Diff( treeDiff ) import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, joinPatches, resolveConflicts,-                     applyToFilepaths, patchcontents,+                     effectOnFilePaths, patchcontents,                      invert, listConflictedFiles, commute, applyToTree, fromPrim ) import Darcs.Patch.Apply( ApplyState ) import Darcs.RepoPath ( toFilePath )@@ -41,7 +41,7 @@  import CommandLine ( parseCmd ) import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Utils ( askUser, filterFilePaths )+import Darcs.Utils ( askEnter, filterFilePaths ) import Darcs.Patch.Set ( PatchSet(..) ) #ifdef GADT_WITNESSES import Darcs.Patch.Set ( Origin )@@ -51,6 +51,7 @@ import Exec ( exec, Redirect(..) ) import Darcs.Lock ( withTempDir ) import Darcs.External ( cloneTree )+import Darcs.Flags ( DarcsFlag, wantGuiPause )  import qualified Storage.Hashed.Tree as Tree import Storage.Hashed ( writePlainTree, readPlainTree )@@ -72,20 +73,25 @@           doml mp [] = Sealed mp  externalResolution :: forall p C(x y z a). (RepoPatch p, ApplyState p ~ Tree.Tree)-                   => Tree.Tree IO -> String -> FL (PrimOf p) C(x y) -> FL (PrimOf p) C(x z)-                    -> FL p C(y a)-                    -> IO (Sealed (FL (PrimOf p) C(a)))-externalResolution s1 c p1_prim p2_prim pmerged = do+                   => Tree.Tree IO+                   -> String  -- ^ external merge tool command+                   -> [DarcsFlag] -- ^ command line arguments+                   -> FL (PrimOf p) C(x y)+                   -> FL (PrimOf p) C(x z)+                   -> FL p C(y a)+                   -> IO (Sealed (FL (PrimOf p) C(a)))+externalResolution s1 c opts p1_prim p2_prim pmerged = do  -- TODO: remove the following two once we can rely on GHC 7.2 / superclass equality  let p1 :: FL p C(x y) = mapFL_FL fromPrim p1_prim      p2 :: FL p C(x z) = mapFL_FL fromPrim p2_prim  sa <- applyToTree (invert p1) s1  sm <- applyToTree pmerged s1  s2 <- applyToTree p2 sa- let nms = listConflictedFiles pmerged-     nas = applyToFilepaths (invert pmerged) nms-     n1s = applyToFilepaths p1 nas-     n2s = applyToFilepaths p2 nas+ let effectOnFPs ps fps = effectOnFilePaths ps fps+     nms = listConflictedFiles pmerged+     nas = effectOnFPs (invert pmerged) nms+     n1s = effectOnFPs p1 nas+     n2s = effectOnFPs p2 nas      ns = zip4 nas n1s n2s nms      write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."   in do@@ -109,23 +115,27 @@            withTempDir "version2" $ \absd2 -> do              let d2 = toFilePath absd2              write_files s2 n2s-             mapM_ (externallyResolveFile c da d1 d2 dm) ns+             mapM_ (externallyResolveFile c opts da d1 d2 dm) ns              sc <- readPlainTree dc              sfixed <- readPlainTree dm              ftf <- filetypeFunction              unFreeLeft `fmap` treeDiff ftf sc sfixed -externallyResolveFile :: String -> String -> String -> String -> String-                        -> (FilePath, FilePath, FilePath, FilePath)-                        -> IO ()-externallyResolveFile c da d1 d2 dm (fa, f1, f2, fm) = do+externallyResolveFile :: String -- ^ external merge tool command+                      -> [DarcsFlag] -- ^ command line arguments+                      -> String -- ^ path to merge base+                      -> String -- ^ path to side 1 of the merge+                      -> String -- ^ path to side 2 of the merge+                      -> String -- ^ path where resolved content should go+                      -> (FilePath, FilePath, FilePath, FilePath)+                      -> IO ()+externallyResolveFile c opts 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--- Warning:  A do-notation statement discarded a result of type String.-    _ <- askUser "Hit return to move on, ^C to abort the whole operation..."-    return ()+    when (wantGuiPause opts) $+        askEnter "Hit return to move on, ^C to abort the whole operation..."  run :: String -> [(Char,String)] -> IO ExitCode run c replacements =

@@ -91,7 +91,7 @@            file_args <- commandGetArgPossibilities cmd            putStrLn $ unlines $ getOptionsOptions (opts1++opts2) : file_args       | otherwise -> considerRunning msuper cmd (addVerboseIfDebug opts) extra-    (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs)+    (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)     where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts                                  | otherwise = opts @@ -109,21 +109,10 @@     extra <- (commandArgdefaults cmd) specops cwd old_extra     when (Disable `elem` specops) $       fail $ "Command "++commandName cmd++" disabled with --disable option!"-    if commandExtraArgs cmd < 0-      then runWithHooks specops extra-      else if length extra > commandExtraArgs cmd-           then fail $ "Bad argument: `"++unwords extra++"'\n"++-                       getCommandMiniHelp msuper cmd-           else if length extra < commandExtraArgs cmd-                then fail $ "Missing argument:  " ++-                            nth_arg (length extra + 1) ++-                            "\n" ++ getCommandMiniHelp msuper cmd-                else runWithHooks specops extra+    case extraArgumentsError extra cmd msuper of+        Nothing     -> runWithHooks specops extra+        Just msg    -> fail msg        where nubopts = nubOptions (uncurry (++) $ commandAlloptions cmd)-             nth_arg n = nth_of n (commandExtraArgHelp 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@@ -144,6 +133,31 @@                           postHookExitCode <- runPosthook os here                           exitWith postHookExitCode +-- Checks if the number of extra arguments matches the number of extra+-- arguments supported by the command as specified in `commandExtraArgs`.+-- Extra arguments are arguments that follow the command but aren't+-- considered a flag. In `darcs push xyz`, xyz would be an extra argument.+extraArgumentsError :: [String]             -- extra commands provided by user+                    -> DarcsCommand+                    -> Maybe DarcsCommand+                    -> Maybe String+extraArgumentsError extra cmd msuper+    | extraArgsCmd < 0 = Nothing+    | extraArgsInput > extraArgsCmd = Just badArg+    | extraArgsInput < extraArgsCmd = Just missingArg+    | otherwise = Nothing+        where+            extraArgsInput = length extra+            extraArgsCmd = commandExtraArgs cmd+            badArg     = "Bad argument: `" ++ unwords extra +++                         "'\n" ++ getCommandMiniHelp msuper cmd+            missingArg = "Missing argument:  " ++ nthArg (length extra + 1) +++                         "\n" ++ getCommandMiniHelp msuper cmd+            nthArg n       = nthOf n (commandExtraArgHelp cmd)+            nthOf 1 (h:_)  = h+            nthOf n (_:hs) = nthOf (n-1) hs+            nthOf _ []     = "UNDOCUMENTED"+ addCommandDefaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag] addCommandDefaults cmd already = do   let (opts1, opts2) = commandAlloptions cmd@@ -175,4 +189,4 @@             then fail $ "Command " ++ (commandName super) ++                       " disabled with --disable option!"             else fail $ "Invalid subcommand!\n\n" ++ subusage super-    (_,_,ermsgs) -> do fail $ chompNewline(unlines ermsgs)+    (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)

@@ -48,7 +48,7 @@                        (+>+), lengthFL, mapFL_FL,                        spanFL, spanFL_M, reverseFL, (+<+), mapFL, filterFL ) import Darcs.Witnesses.WZipper( FZipper(..), left, right-                              , rightmost+                              , rightmost, nullFZ                               , toEnd, toStart) import Darcs.Patch.Choices ( PatchChoices, patchChoices,                              patchChoicesTpsSub,@@ -112,17 +112,19 @@                                    , splitter :: Maybe (Splitter p)                                    , files :: Maybe [FilePath]                                    , matchCriterion :: MatchCriterion p-                                   , jobname :: String }+                                   , jobname :: String+                                   , pristine :: Maybe (Tree IO)}  -- | A 'PatchSelectionContext' for selecting 'Prim' patches. selectionContextPrim ::  PrimPatch prim => String -> [DarcsFlag] -> Maybe (Splitter prim)-                 -> Maybe [FilePath] -> PatchSelectionContext prim-selectionContextPrim jn o spl fs =+                 -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim+selectionContextPrim jn o spl fs p =  PSC { opts = o      , splitter = spl      , files = fs      , matchCriterion = triv-     , jobname = jn }+     , jobname = jn+     , pristine = p }  -- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches) selectionContext :: (RepoPatch p) => String -> [DarcsFlag] -> Maybe (Splitter (PatchInfoAnd p))@@ -132,7 +134,8 @@      , splitter = spl      , files = fs      , matchCriterion = iswanted-     , jobname = jn }+     , jobname = jn+     , pristine = Nothing }  -- | The dynamic parameters for interactive selection of patches. data InteractiveSelectionContext p C(x y) = ISC { total :: Int@@ -215,7 +218,7 @@ repr FirstReversed (Sealed2 p) = Sealed2 (invert p)  -- | The equivalent of 'selectChanges' for the @darcs changes@ command-viewChanges :: Patchy p => [DarcsFlag] -> [Sealed2 p] -> IO ()+viewChanges :: (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> [Sealed2 p] -> IO () viewChanges opts' ps = textView opts' Nothing 0 [] ps  -- | The type of the answers to a "shall I [wiggle] that [foo]?" question@@ -242,67 +245,77 @@ keysFor = concatMap (map kp)  -- | The function for selecting a patch to amend record. Read at your own risks.-withSelectedPatchFromRepo :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)-                          => String -> Repository p C(r u t) -> [DarcsFlag]-                          -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ()) -> IO ()+withSelectedPatchFromRepo ::+       forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)+    => String   -- name of calling command (always "amend" as of now)+    -> Repository p C(r u t)+    -> [DarcsFlag]+    -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ())+    -> IO () withSelectedPatchFromRepo jn repository o job = do-    p_s <- readRepo repository-    sp <- wspfr jn (matchAPatchread o)-                              (newset2RL p_s) NilFL+    patchSet <- readRepo repository+    sp <- wspfr jn (matchAPatchread o) (newset2RL patchSet) NilFL     case sp of-     Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')-     Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected."+        Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')+        Nothing ->+            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.+-- | 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, ApplyState p ~ Tree)-      => String -> (FORALL(a b) (PatchInfoAnd p) C(a b) -> Bool)-      -> RL (PatchInfoAnd p) C(x y) -> FL (PatchInfoAnd p) C(y u)+      => 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+wspfr jn matches remaining@(p:<:pps) skipped     | not $ matches p = wspfr jn matches pps (p:>:skipped)     | otherwise =     case commuteFLorComplain (p :> skipped) of     Left _  -> do putStrLn "\nSkipping depended-upon patch:"-                  printFriendly [] p+                  printFriendly Nothing [] p                   wspfr jn matches pps (p:>:skipped)     Right (skipped' :> p') -> do-      printFriendly [] p-      let repeat_this  = wspfr jn matches (p:<:pps) skipped-          basic_options =-                    [[ KeyPress 'y' (jn++" this patch")-                     , KeyPress 'n' ("don't "++jn++" it")+        printFriendly Nothing [] p+        yorn <- promptChar $+                    PromptConfig { pPrompt = prompt'+                                 , pBasicCharacters = keysFor basicOptions+                                 , pAdvancedCharacters = keysFor advancedOptions+                                 , pDefault = Just 'n'+                                 , pHelp = "?h" }+        case yorn of+            'y' -> return $ Just $ flipSeal $ skipped' :> p'+            'n' -> nextPatch+            'j' -> nextPatch+            'k' -> case skipped of+                     NilFL -> repeatThis+                     (prev :>: skipped') -> wspfr jn matches (prev :<: remaining) skipped'+            'v' -> printPatch p >> repeatThis+            'p' -> printPatchPager p >> repeatThis+            'x' -> do putDocLn $ prefix "    " $ summary p+                      repeatThis+            'q' -> do putStrLn $ jnCapital ++ " cancelled."+                      exitWith $ ExitSuccess+            _   -> do putStrLn $ helpFor jn basicOptions advancedOptions+                      repeatThis+  where jnCapital = (toUpper $ head jn) : tail jn+        repeatThis = wspfr jn matches (p:<:pps) skipped+        prompt' = "Shall I " ++ jn ++ " this patch?"+        nextPatch = wspfr jn matches pps (p:>:skipped)+        basicOptions =+                    [[ KeyPress 'y' (jn ++ " this patch")+                     , KeyPress 'n' ("don't " ++ jn ++ " it")+                     , KeyPress 'j' "skip to next patch"                      , KeyPress 'k' "back up to previous patch"                     ]]-          advanced_options =+        advancedOptions =                     [[ 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)+                     , KeyPress 'q' ("cancel " ++ jn)                     ]]-      let prompt'  = "Shall I "++jn++" this patch?"-      yorn <- promptChar $ PromptConfig { pPrompt = prompt'-                                        , pBasicCharacters = keysFor basic_options-                                        , pAdvancedCharacters = keysFor advanced_options-                                        , pDefault = Just 'n'-                                        , pHelp = "?h" }-      case yorn of-        'y' -> return $ Just $ flipSeal $ skipped' :> p'-        'n' -> wspfr jn matches pps (p:>:skipped)-        'k' -> case skipped of-                  NilFL -> repeat_this-                  (prev :>: skipped') -> wspfr jn matches (prev :<: p :<: pps) 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 basic_options advanced_options-                  repeat_this-  where jn_cap = (toUpper $ head jn) : tail jn  -- After selecting with a splitter, the results may not be canonical canonizeAfterSplitter :: (FL p :> FL p) C(x y) -> Reader (PatchSelectionContext p) ((FL p :> FL p) C(x y))@@ -311,7 +324,7 @@        let canonizeIfNeeded = maybe id canonizeSplit mspl        return $ canonizeIfNeeded x :> canonizeIfNeeded y -realSelectChanges :: forall p C(x y). Patchy p+realSelectChanges :: forall p C(x y). (Patchy p, ApplyState p ~ Tree)                                 => WhichChanges                                 -> PatchChoices p C(x y)                                 -> PatchSelectionM p IO (PatchChoices p C(x y))@@ -410,20 +423,25 @@ justDone n = modify $ \isc -> isc{ current = current isc + n}  -- | The actual interactive selection process.-textSelect :: forall p C(x y) . Patchy p => WhichChanges ->+textSelect :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges ->              FL (TaggedPatch p) C(x y) -> PatchChoices p C(x y)              -> PatchSelectionM p IO (PatchChoices p C(x y)) textSelect whch tps' pcs = do     userSelection <- execStateT (skipMundane whch >>                                  showCur whch >>-                                 textSelect' whch) $+                                 textSelectIfAny) $                      ISC { total = lengthFL tps'                          , current = 0                          , tps = FZipper NilRL tps'                          , choices = pcs }     return $ choices userSelection+    where textSelectIfAny = do+            z <- gets tps+            if rightmost z+              then return ()+              else textSelect' whch -textSelect' :: Patchy p => WhichChanges ->+textSelect' :: (Patchy p, ApplyState p ~ Tree) => WhichChanges ->               InteractiveSelectionM p C(x y) () textSelect' whch = do   z <- gets tps@@ -461,9 +479,9 @@  optionsNav :: String -> [KeyPress] optionsNav aThing =-    [ KeyPress 'j' ("skip to next "++ aThing)-    , KeyPress 'k' ("back up to previous "++ aThing)-    , KeyPress 'o' ("start over from first " ++ aThing)]+  [ KeyPress 'j' ("skip to next "++ aThing)+  ,  KeyPress 'k' ("back up to previous "++ aThing)+  , KeyPress 'g' ("start over from the first "++aThing)]  optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress] optionsSplit split aThing@@ -686,7 +704,7 @@                                      }  -- | Ask the user what to do with the next patch.-textSelectOne :: forall p C(x y). Patchy p => WhichChanges+textSelectOne :: forall p C(x y). (Patchy p, ApplyState p ~ Tree) => WhichChanges             -> InteractiveSelectionM p C(x y) () textSelectOne whichch = do  c <- currentPatch@@ -702,7 +720,7 @@          theSlot <- liftChoices $ patchSlot' tp          let              the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot-             jn_cap = (toUpper $ head jn) : tail jn+             jnCapital = (toUpper $ head jn) : tail jn          yorn <- promptUser singleFile the_default          let nextPatch = skipMundane whichch >> showCur whichch          case yorn of@@ -721,44 +739,46 @@                'l' -> printSelected whichch >> showCur whichch                'x' -> liftIO $ unseal2 printSummary reprCur                'd' -> skipAll-               'o' -> backAll >> showCur whichch+               'g' -> backAll >> showCur whichch                'a' ->                    do                      askConfirmation                      modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed)                      skipAll                'q' -> liftIO $-                      do putStrLn $ jn_cap++" cancelled."+                      do putStrLn $ jnCapital++" cancelled."                          exitWith $ ExitSuccess                'j' -> skipOne >> showCur whichch                'k' -> backOne >> showCur whichch-               _   -> do liftIO . putStrLn $ helpFor jn basicOptions advancedOptions+               _   -> do+                 liftIO . putStrLn $ helpFor jn basicOptions advancedOptions  -- | Shows the current patch as it should be seen by the user.-showCur :: forall p C(x y) . Patchy p => WhichChanges+showCur :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges            -> InteractiveSelectionM p C(x y) () showCur whichch = do   o <- asks opts+  p <- asks pristine   c <- currentPatch   case c of       Nothing -> return ()       Just (Sealed2 tp) -> do              let reprCur = repr whichch (Sealed2 (tpPatch tp))-             liftIO . (unseal2 (printFriendly o)) $ reprCur+             liftIO . (unseal2 (printFriendly p o)) $ reprCur  -- | The interactive part of @darcs changes@-textView :: forall p . Patchy p => [DarcsFlag] -> Maybe Int -> Int+textView :: forall p . (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe Int -> Int             -> [Sealed2 p] -> [Sealed2 p]             -> IO () textView _ _ _ _ [] = return () textView o n_max n             ps_done ps_todo@(p:ps_todo') = do-      unseal2 (printFriendly o) p-      repeat_this -- prompt the user+      unseal2 (printFriendly Nothing o) p+      repeatThis -- prompt the user     where         prev_patch :: IO ()         prev_patch = case ps_done of-                       [] -> repeat_this+                       [] -> repeatThis                        (p':ps_done') ->                          textView o                             n_max (n-1) ps_done' (p':ps_todo)@@ -783,7 +803,7 @@           [ KeyPress 'q' "quit view changes"           , KeyPress 'k' "back up to previous patch"           , KeyPress 'j' "skip to next patch"-          , KeyPress 'o' "start over from the first patch"+          , KeyPress 'g' "start over from the first patch"           , KeyPress 'c' "count total patch number" ]         basicOptions = [ options_yn ]         advancedOptions =@@ -792,24 +812,24 @@                   ++ [ optionsNav' ]         prompt' = "Shall I view this patch? "                ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"-        repeat_this :: IO ()-        repeat_this = do+        repeatThis :: IO ()+        repeatThis = do           yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")           case yorn of             'y' -> unseal2 printPatch p >> next_patch             'n' -> next_patch-            'v' -> unseal2 printPatch p >> repeat_this-            'p' -> unseal2 printPatchPager p >> repeat_this+            'v' -> unseal2 printPatch p >> repeatThis+            'p' -> unseal2 printPatchPager p >> repeatThis             'x' -> do putDocLn $ prefix "    " $ unseal2 summary p-                      repeat_this+                      repeatThis             'q' -> exitWith ExitSuccess             'k' -> prev_patch             'j' -> next_patch-            'o' -> first_patch+            'g' -> first_patch             'c' -> textView o                        count_n_max n ps_done ps_todo             _   -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions-                      repeat_this+                      repeatThis         count_n_max | isJust n_max = n_max                     | otherwise    = Just $ length ps_done + length ps_todo 

@@ -1,56 +1,79 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -module Darcs.Ssh (-  copySSH, SSHCmd(..), getSSH,-  environmentHelpSsh, environmentHelpScp, environmentHelpSshPort,-  remoteDarcs+-- |+-- Module      : Darcs.Ssh+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Ssh+    (+      copySSH+    , SSHCmd(..)+    , getSSH+    , environmentHelpSsh+    , environmentHelpScp+    , environmentHelpSshPort+    , remoteDarcs   ) where + import Prelude hiding ( lookup, catch )-import qualified Ratified( hGetContents ) -import System.Exit ( ExitCode(..) )+import qualified Ratified ( hGetContents )+ import System.Environment ( getEnv )-#ifndef WIN32-import System.Posix.Process ( getProcessID )-#else-import Darcs.Utils ( showHexLen )+import System.Exit ( ExitCode(..) )++#ifdef WIN32 import Data.Bits ( (.&.) ) import System.Random ( randomIO )+import Darcs.Utils ( showHexLen ) #endif-import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )-import System.IO.Unsafe ( unsafePerformIO )-import System.Directory ( doesFileExist, createDirectoryIfMissing )+ import Control.Monad ( when )-import System.Process ( runInteractiveProcess ) +import qualified Data.ByteString as B (ByteString, hGet, writeFile )+ import Data.Map ( Map, empty, insert, lookup ) import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) +import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )+import System.IO.Unsafe ( unsafePerformIO )+import System.Process ( runInteractiveProcess )+ import Darcs.SignalHandler ( catchNonSignal )-import Darcs.Utils ( breakCommand, prettyException, catchall )-import Darcs.Global ( atexit, withDebugMode-                    , defaultSsh, SshSettings-                    )-import Darcs.Lock ( tempdirLoc, removeFileMayNotExist )+import Darcs.Flags( RemoteDarcs(..) )+import Darcs.Global ( defaultSsh, SshSettings) import Darcs.URL (SshFilePath(..), urlOf)-import Exec ( exec, Redirects, Redirect(..), )+import Darcs.Utils ( breakCommand, prettyException, catchall )+import Exec ( exec, Redirect(..), ) import Progress ( withoutProgress, debugMessage, debugFail )-import Darcs.Flags( RemoteDarcs(..) ) -import qualified Data.ByteString as B (ByteString, hGet, writeFile ) import qualified Darcs.Global as Settings -{-# NOINLINE sshConnections #-}+ sshConnections :: IORef (Map String (Maybe Connection)) sshConnections = unsafePerformIO $ newIORef empty+{-# NOINLINE sshConnections #-} -data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () } --- | @withSSHConnection rdarcs destination withconnection withoutconnection@--- performs an action on a remote host. If we are already connected to @destination@,+data Connection = C+    { inp :: !Handle+    , out :: !Handle+    , err :: !Handle+    , deb :: String -> IO ()+    }+++-- | @withSSHConnection rdarcs repoid  withconnection withoutconnection@+-- performs an action on a remote host. If we are already connected to @repoid @, -- then it does @withconnection@, else @withoutconnection@.-withSSHConnection :: String -> SshFilePath -> (Connection -> IO a) -> IO a -> IO a+withSSHConnection :: String                 -- ^ rdarcs+                  -> SshFilePath            -- ^ Destination repo id+                  -> (Connection -> IO a)   -- ^ withconnection+                  -> IO a                   -- ^ withoutconnection+                  -> IO a withSSHConnection rdarcs repoid withconnection withoutconnection =     withoutProgress $     do cs <- readIORef sshConnections@@ -85,10 +108,13 @@                                      return Nothing               maybe withoutconnection withconnection mc -severSSHConnection :: SshFilePath -> IO ()-severSSHConnection x = do debugMessage $ "Severing ssh failed connection to "++(sshUhost x)-                          modifyIORef sshConnections (insert (urlOf x) Nothing)+severSSHConnection :: SshFilePath+                   -> IO ()+severSSHConnection x = do+    debugMessage $ "Severing ssh failed connection to " ++ (sshUhost x)+    modifyIORef sshConnections (insert (urlOf x) Nothing) + grabSSH :: SshFilePath -> Connection -> IO B.ByteString grabSSH dest c = do   debugMessage $ "grabSSH dest=" ++ urlOf dest@@ -116,80 +142,96 @@                    [] -> failwith "An error occurred"          else failwith "Error" -remoteDarcs :: RemoteDarcs -> String+remoteDarcs :: RemoteDarcs+            -> String remoteDarcs DefaultRemoteDarcs = "darcs" remoteDarcs (RemoteDarcs x) = x -copySSH :: RemoteDarcs -> SshFilePath -> FilePath -> IO ()++copySSH :: RemoteDarcs+        -> SshFilePath+        -> FilePath+        -> IO () copySSH remote dest to | rdarcs <- remoteDarcs remote = do-  debugMessage $ "copySSH file: " ++ urlOf dest-  withSSHConnection rdarcs dest (\c -> grabSSH dest c >>= B.writeFile to) $-              do let u = escape_dollar $ urlOf dest-                 (scp, args) <- getSSH SCP-                 r <- exec scp (args ++ [u, to]) (AsIs,AsIs,AsIs)-                 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]+    debugMessage $ "copySSH file: " ++ urlOf dest+    withSSHConnection rdarcs dest (\c -> grabSSH dest c >>= B.writeFile to) $ do+        let u = escape_dollar $ urlOf dest+        (scp, args) <- getSSH SCP+        r <- exec scp (args ++ [u, to]) (AsIs,AsIs,AsIs)+        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] + -- --------------------------------------------------------------------- -- older ssh helper functions -- --------------------------------------------------------------------- -data SSHCmd = SSH | SCP | SFTP+data SSHCmd = SSH+            | SCP+            | SFTP -fromSshCmd :: SshSettings -> SSHCmd -> String++fromSshCmd :: SshSettings+           -> SSHCmd+           -> String fromSshCmd s SSH  = Settings.ssh s fromSshCmd s SCP  = Settings.scp s fromSshCmd s SFTP = Settings.sftp s + -- | 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.-getSSH :: SSHCmd -> IO (String, [String])-getSSH cmd =- do -- port+getSSH :: SSHCmd+       -> IO (String, [String])+getSSH cmd = do     port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []     let (ssh, ssh_args) = breakCommand command-    --     return (ssh, ssh_args ++ port)-    where-     command = fromSshCmd defaultSsh cmd-     portFlag SSH  x = ["-p", x]-     portFlag SCP  x = ["-P", x]-     portFlag SFTP x = ["-oPort="++x]+  where+    command = fromSshCmd defaultSsh cmd+    portFlag SSH  x = ["-p", x]+    portFlag SCP  x = ["-P", x]+    portFlag SFTP x = ["-oPort=" ++ x] + environmentHelpSsh :: ([String], [String]) environmentHelpSsh = (["DARCS_SSH"], [- "Repositories of the form [user@]host:[dir] are taken to be remote",- "repositories, which Darcs accesses with the external program ssh(1).",- "",- "The environment variable $DARCS_SSH can be used to specify an",- "alternative SSH client.  Arguments may be included, separated by",- "whitespace.  The value is not interpreted by a shell, so shell",- "constructs cannot be used; in particular, it is not possible for the",- "program name to contain whitespace by using quoting or escaping."])+    "Repositories of the form [user@]host:[dir] are taken to be remote",+    "repositories, which Darcs accesses with the external program ssh(1).",+    "",+    "The environment variable $DARCS_SSH can be used to specify an",+    "alternative SSH client.  Arguments may be included, separated by",+    "whitespace.  The value is not interpreted by a shell, so shell",+    "constructs cannot be used; in particular, it is not possible for the",+    "program name to contain whitespace by using quoting or escaping."]) + environmentHelpScp :: ([String], [String]) environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [- "When reading from a remote repository, Darcs will attempt to run",- "`darcs transfer-mode' on the remote host.  This will fail if the",- "remote host only has Darcs 1 installed, doesn't have Darcs installed",- "at all, or only allows SFTP.",- "",- "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",- "The commands invoked can be customized with the environment variables",- "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",- "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])+    "When reading from a remote repository, Darcs will attempt to run",+    "`darcs transfer-mode' on the remote host.  This will fail if the",+    "remote host only has Darcs 1 installed, doesn't have Darcs installed",+    "at all, or only allows SFTP.",+    "",+    "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",+    "The commands invoked can be customized with the environment variables",+    "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",+    "If the remote end allows only sftp, try setting DARCS_SCP=sftp."]) + environmentHelpSshPort :: ([String], [String]) environmentHelpSshPort = (["SSH_PORT"], [- "If this environment variable is set, it will be used as the port",- "number for all SSH calls made by Darcs (when accessing remote",- "repositories over SSH).  This is useful if your SSH server does not",- "run on the default port, and your SSH client does not support",- "ssh_config(5).  OpenSSH users will probably prefer to put something",- "like `Host *.example.net Port 443' into their ~/.ssh/config file."])+    "If this environment variable is set, it will be used as the port",+    "number for all SSH calls made by Darcs (when accessing remote",+    "repositories over SSH).  This is useful if your SSH server does not",+    "run on the default port, and your SSH client does not support",+    "ssh_config(5).  OpenSSH users will probably prefer to put something",+    "like `Host *.example.net Port 443' into their ~/.ssh/config file."])