diff --git a/contrib/darcs_completion b/contrib/darcs_completion --- a/contrib/darcs_completion +++ b/contrib/darcs_completion @@ -2,8 +2,8 @@ # darcs command line completion. # Copyright 2002 "David Roundy" -# -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 diff --git a/darcs-beta.cabal b/darcs-beta.cabal --- a/darcs-beta.cabal +++ b/darcs-beta.cabal @@ -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 , @@ -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 diff --git a/doc/src/darcs.tex b/doc/src/darcs.tex --- a/doc/src/darcs.tex +++ b/doc/src/darcs.tex @@ -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 diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n[TAG 2.7.98.3\nGanesh Sittampalam **20120119060551\n Ignore-this: bc156878e2f54804226a43035ea5da28\n] \n" +Just "\nContext:\n\n[TAG 2.7.99.1\nFlorent Becker **20120401092449\n Ignore-this: 23fef1226d1278f70993402dc13ea30d\n] \n" diff --git a/src/CommandLine.hs b/src/CommandLine.hs --- a/src/CommandLine.hs +++ b/src/CommandLine.hs @@ -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",""], 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 diff --git a/src/Darcs/Annotate.hs b/src/Darcs/Annotate.hs --- a/src/Darcs/Annotate.hs +++ b/src/Darcs/Annotate.hs @@ -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 diff --git a/src/Darcs/Arguments.hs b/src/Darcs/Arguments.hs --- a/src/Darcs/Arguments.hs +++ b/src/Darcs/Arguments.hs @@ -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" ] diff --git a/src/Darcs/ColorPrinter.hs b/src/Darcs/ColorPrinter.hs --- a/src/Darcs/ColorPrinter.hs +++ b/src/Darcs/ColorPrinter.hs @@ -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 ) diff --git a/src/Darcs/Commands/Add.hs b/src/Darcs/Commands/Add.hs --- a/src/Darcs/Commands/Add.hs +++ b/src/Darcs/Commands/Add.hs @@ -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 = [" ..."], - 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 = [ " ..." ] + , 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 diff --git a/src/Darcs/Commands/AmendRecord.hs b/src/Darcs/Commands/AmendRecord.hs --- a/src/Darcs/Commands/AmendRecord.hs +++ b/src/Darcs/Commands/AmendRecord.hs @@ -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 diff --git a/src/Darcs/Commands/Annotate.hs b/src/Darcs/Commands/Annotate.hs --- a/src/Darcs/Commands/Annotate.hs +++ b/src/Darcs/Commands/Annotate.hs @@ -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) diff --git a/src/Darcs/Commands/Apply.hs b/src/Darcs/Commands/Apply.hs --- a/src/Darcs/Commands/Apply.hs +++ b/src/Darcs/Commands/Apply.hs @@ -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" ++ diff --git a/src/Darcs/Commands/Changes.hs b/src/Darcs/Commands/Changes.hs --- a/src/Darcs/Commands/Changes.hs +++ b/src/Darcs/Commands/Changes.hs @@ -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 "" - $$ vcat xml_file_names + $$ vcat created_as_xml $$ vcat actual_xml_changes $$ text "" | 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 "" - $$ toXml pinfo - $$ text "" +createdAsXml :: PatchInfo -> (String, String) -> Doc +createdAsXml pinfo (current, createdAs) = + text "" + $$ toXml pinfo + $$ text "" diff --git a/src/Darcs/Commands/Diff.hs b/src/Darcs/Commands/Diff.hs --- a/src/Darcs/Commands/Diff.hs +++ b/src/Darcs/Commands/Diff.hs @@ -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 diff --git a/src/Darcs/Commands/Dist.hs b/src/Darcs/Commands/Dist.hs --- a/src/Darcs/Commands/Dist.hs +++ b/src/Darcs/Commands/Dist.hs @@ -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 diff --git a/src/Darcs/Commands/Help.hs b/src/Darcs/Commands/Help.hs --- a/src/Darcs/Commands/Help.hs +++ b/src/Darcs/Commands/Help.hs @@ -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 ) diff --git a/src/Darcs/Commands/Move.hs b/src/Darcs/Commands/Move.hs --- a/src/Darcs/Commands/Move.hs +++ b/src/Darcs/Commands/Move.hs @@ -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 diff --git a/src/Darcs/Commands/Pull.hs b/src/Darcs/Commands/Pull.hs --- a/src/Darcs/Commands/Pull.hs +++ b/src/Darcs/Commands/Pull.hs @@ -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, diff --git a/src/Darcs/Commands/Record.hs b/src/Darcs/Commands/Record.hs --- a/src/Darcs/Commands/Record.hs +++ b/src/Darcs/Commands/Record.hs @@ -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" diff --git a/src/Darcs/Commands/Replace.hs b/src/Darcs/Commands/Replace.hs --- a/src/Darcs/Commands/Replace.hs +++ b/src/Darcs/Commands/Replace.hs @@ -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 diff --git a/src/Darcs/Commands/Revert.hs b/src/Darcs/Commands/Revert.hs --- a/src/Darcs/Commands/Revert.hs +++ b/src/Darcs/Commands/Revert.hs @@ -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," ++ diff --git a/src/Darcs/Commands/Rollback.hs b/src/Darcs/Commands/Rollback.hs --- a/src/Darcs/Commands/Rollback.hs +++ b/src/Darcs/Commands/Rollback.hs @@ -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) diff --git a/src/Darcs/Commands/Test.hs b/src/Darcs/Commands/Test.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Commands/Test.hs @@ -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 diff --git a/src/Darcs/Commands/Unrevert.hs b/src/Darcs/Commands/Unrevert.hs --- a/src/Darcs/Commands/Unrevert.hs +++ b/src/Darcs/Commands/Unrevert.hs @@ -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 $ diff --git a/src/Darcs/Commands/WhatsNew.hs b/src/Darcs/Commands/WhatsNew.hs --- a/src/Darcs/Commands/WhatsNew.hs +++ b/src/Darcs/Commands/WhatsNew.hs @@ -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 '." diff --git a/src/Darcs/Diff.hs b/src/Darcs/Diff.hs --- a/src/Darcs/Diff.hs +++ b/src/Darcs/Diff.hs @@ -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 diff --git a/src/Darcs/External.hs b/src/Darcs/External.hs --- a/src/Darcs/External.hs +++ b/src/Darcs/External.hs @@ -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) diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -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 diff --git a/src/Darcs/Global.hs b/src/Darcs/Global.hs --- a/src/Darcs/Global.hs +++ b/src/Darcs/Global.hs @@ -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" diff --git a/src/Darcs/Match.hs b/src/Darcs/Match.hs --- a/src/Darcs/Match.hs +++ b/src/Darcs/Match.hs @@ -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)) diff --git a/src/Darcs/Patch.hs b/src/Darcs/Patch.hs --- a/src/Darcs/Patch.hs +++ b/src/Darcs/Patch.hs @@ -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) diff --git a/src/Darcs/Patch/Apply.hs b/src/Darcs/Patch/Apply.hs --- a/src/Darcs/Patch/Apply.hs +++ b/src/Darcs/Patch/Apply.hs @@ -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 diff --git a/src/Darcs/Patch/ApplyMonad.hs b/src/Darcs/Patch/ApplyMonad.hs --- a/src/Darcs/Patch/ApplyMonad.hs +++ b/src/Darcs/Patch/ApplyMonad.hs @@ -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 diff --git a/src/Darcs/Patch/FileName.hs b/src/Darcs/Patch/FileName.hs --- a/src/Darcs/Patch/FileName.hs +++ b/src/Darcs/Patch/FileName.hs @@ -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 diff --git a/src/Darcs/Patch/Format.hs b/src/Darcs/Patch/Format.hs --- a/src/Darcs/Patch/Format.hs +++ b/src/Darcs/Patch/Format.hs @@ -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 diff --git a/src/Darcs/Patch/Info.hs b/src/Darcs/Patch/Info.hs --- a/src/Darcs/Patch/Info.hs +++ b/src/Darcs/Patch/Info.hs @@ -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 **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 diff --git a/src/Darcs/Patch/Merge.hs b/src/Darcs/Patch/Merge.hs --- a/src/Darcs/Patch/Merge.hs +++ b/src/Darcs/Patch/Merge.hs @@ -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'') diff --git a/src/Darcs/Patch/Named.hs b/src/Darcs/Patch/Named.hs --- a/src/Darcs/Patch/Named.hs +++ b/src/Darcs/Patch/Named.hs @@ -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 diff --git a/src/Darcs/Patch/Prim/V3/Apply.hs b/src/Darcs/Patch/Prim/V3/Apply.hs --- a/src/Darcs/Patch/Prim/V3/Apply.hs +++ b/src/Darcs/Patch/Prim/V3/Apply.hs @@ -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(..) ) diff --git a/src/Darcs/Patch/Prim/V3/Core.hs b/src/Darcs/Patch/Prim/V3/Core.hs --- a/src/Darcs/Patch/Prim/V3/Core.hs +++ b/src/Darcs/Patch/Prim/V3/Core.hs @@ -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 diff --git a/src/Darcs/Patch/Prim/V3/Details.hs b/src/Darcs/Patch/Prim/V3/Details.hs --- a/src/Darcs/Patch/Prim/V3/Details.hs +++ b/src/Darcs/Patch/Prim/V3/Details.hs @@ -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" diff --git a/src/Darcs/Patch/Prim/V3/ObjectMap.hs b/src/Darcs/Patch/Prim/V3/ObjectMap.hs --- a/src/Darcs/Patch/Prim/V3/ObjectMap.hs +++ b/src/Darcs/Patch/Prim/V3/ObjectMap.hs @@ -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] diff --git a/src/Darcs/Patch/Prim/V3/Read.hs b/src/Darcs/Patch/Prim/V3/Read.hs --- a/src/Darcs/Patch/Prim/V3/Read.hs +++ b/src/Darcs/Patch/Prim/V3/Read.hs @@ -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 diff --git a/src/Darcs/Patch/Prim/V3/Show.hs b/src/Darcs/Patch/Prim/V3/Show.hs --- a/src/Darcs/Patch/Prim/V3/Show.hs +++ b/src/Darcs/Patch/Prim/V3/Show.hs @@ -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 diff --git a/src/Darcs/Patch/Set.hs b/src/Darcs/Patch/Set.hs --- a/src/Darcs/Patch/Set.hs +++ b/src/Darcs/Patch/Set.hs @@ -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 diff --git a/src/Darcs/Patch/Show.hs b/src/Darcs/Patch/Show.hs --- a/src/Darcs/Patch/Show.hs +++ b/src/Darcs/Patch/Show.hs @@ -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 diff --git a/src/Darcs/Patch/Split.hs b/src/Darcs/Patch/Split.hs --- a/src/Darcs/Patch/Split.hs +++ b/src/Darcs/Patch/Split.hs @@ -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" diff --git a/src/Darcs/Patch/TokenReplace.hs b/src/Darcs/Patch/TokenReplace.hs --- a/src/Darcs/Patch/TokenReplace.hs +++ b/src/Darcs/Patch/TokenReplace.hs @@ -1,6 +1,9 @@ -module Darcs.Patch.TokenReplace - ( tryTokInternal, forceTokReplace ) - where +module Darcs.Patch.TokenReplace + ( + tryTokInternal + , forceTokReplace + ) + where import Darcs.Patch.RegChars ( regChars ) diff --git a/src/Darcs/Patch/TouchesFiles.hs b/src/Darcs/Patch/TouchesFiles.hs --- a/src/Darcs/Patch/TouchesFiles.hs +++ b/src/Darcs/Patch/TouchesFiles.hs @@ -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 diff --git a/src/Darcs/Patch/V2/Non.hs b/src/Darcs/Patch/V2/Non.hs --- a/src/Darcs/Patch/V2/Non.hs +++ b/src/Darcs/Patch/V2/Non.hs @@ -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 diff --git a/src/Darcs/Patch/V2/Real.hs b/src/Darcs/Patch/V2/Real.hs --- a/src/Darcs/Patch/V2/Real.hs +++ b/src/Darcs/Patch/V2/Real.hs @@ -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 diff --git a/src/Darcs/PrintPatch.hs b/src/Darcs/PrintPatch.hs --- a/src/Darcs/PrintPatch.hs +++ b/src/Darcs/PrintPatch.hs @@ -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 () diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -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 diff --git a/src/Darcs/Repository/Cache.hs b/src/Darcs/Repository/Cache.hs --- a/src/Darcs/Repository/Cache.hs +++ b/src/Darcs/Repository/Cache.hs @@ -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)) diff --git a/src/Darcs/Repository/HashedRepo.hs b/src/Darcs/Repository/HashedRepo.hs --- a/src/Darcs/Repository/HashedRepo.hs +++ b/src/Darcs/Repository/HashedRepo.hs @@ -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 diff --git a/src/Darcs/Repository/Internal.hs b/src/Darcs/Repository/Internal.hs --- a/src/Darcs/Repository/Internal.hs +++ b/src/Darcs/Repository/Internal.hs @@ -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"++ diff --git a/src/Darcs/Repository/Merge.hs b/src/Darcs/Repository/Merge.hs --- a/src/Darcs/Repository/Merge.hs +++ b/src/Darcs/Repository/Merge.hs @@ -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..." diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs --- a/src/Darcs/Repository/State.hs +++ b/src/Darcs/Repository/State.hs @@ -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) diff --git a/src/Darcs/Resolution.hs b/src/Darcs/Resolution.hs --- a/src/Darcs/Resolution.hs +++ b/src/Darcs/Resolution.hs @@ -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', d1f1), ('2', d2f2), ('a', dafa), ('o', dmfm), ('%', "%")] 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 = diff --git a/src/Darcs/RunCommand.hs b/src/Darcs/RunCommand.hs --- a/src/Darcs/RunCommand.hs +++ b/src/Darcs/RunCommand.hs @@ -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) diff --git a/src/Darcs/SelectChanges.hs b/src/Darcs/SelectChanges.hs --- a/src/Darcs/SelectChanges.hs +++ b/src/Darcs/SelectChanges.hs @@ -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 diff --git a/src/Darcs/Ssh.hs b/src/Darcs/Ssh.hs --- a/src/Darcs/Ssh.hs +++ b/src/Darcs/Ssh.hs @@ -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."]) diff --git a/src/Darcs/TheCommands.hs b/src/Darcs/TheCommands.hs --- a/src/Darcs/TheCommands.hs +++ b/src/Darcs/TheCommands.hs @@ -20,7 +20,7 @@ import Prelude () import Darcs.Commands.Add ( add ) -import Darcs.Commands.AmendRecord ( amendrecord ) +import Darcs.Commands.AmendRecord ( amendrecord, amendunrecord ) import Darcs.Commands.Annotate ( annotate ) import Darcs.Commands.Apply ( apply ) import Darcs.Commands.Changes ( changes, log ) @@ -46,6 +46,7 @@ import Darcs.Commands.Send ( send ) import Darcs.Commands.SetPref ( setpref ) import Darcs.Commands.Tag ( tag ) +import Darcs.Commands.Test ( test ) import Darcs.Commands.TrackDown ( trackdown ) import Darcs.Commands.TransferMode ( transferMode ) import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate ) @@ -69,6 +70,7 @@ CommandData record, HiddenCommand commit, CommandData unrecord, CommandData amendrecord, + HiddenCommand amendunrecord, CommandData markconflicts, GroupName "Direct modification of the repository:", CommandData tag, @@ -78,6 +80,7 @@ CommandData changes, HiddenCommand log, CommandData annotate, CommandData dist, + CommandData test, CommandData trackdown, CommandData showCommand, HiddenCommand list, HiddenCommand query, HiddenCommand transferMode, diff --git a/src/Darcs/Utils.hs b/src/Darcs/Utils.hs --- a/src/Darcs/Utils.hs +++ b/src/Darcs/Utils.hs @@ -1,114 +1,168 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- | +-- Module : Exec +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable +-- -- Various utility functions that do not belong anywhere else. -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Darcs.Utils + ( + ortryrunning + , nubsort + , breakCommand + , showHexLen + , maybeGetEnv + , formatPath + -- * Monads + , firstJustIO + -- * User prompts + , askEnter + , askUser + , askUserListItem + , PromptConfig(..) + , promptYorn + , promptChar + -- * Text + , getViewer + , editFile + , runEditor + , stripCr + -- * Help + , environmentHelpEditor + , environmentHelpPager + -- * Errors and exceptions + , catchall + , clarifyErrors + , prettyException + , prettyError + , addToErrorLoc + -- * Files and directories + , getFileStatus + , withCurrentDirectory + , withUMask + -- * Locales + , setDarcsEncodings + , getSystemEncoding + , isUTF8Locale + -- * Tree filtering. + , filterFilePaths + , filterPaths + -- * Tree lookup. + , treeHas + , treeHasDir + , treeHasFile + , treeHasAnycase + ) where -module Darcs.Utils ( ortryrunning, nubsort, breakCommand - , showHexLen - , maybeGetEnv - , formatPath - -- * Monads - , firstJustIO - -- * User prompts - , askUser, askUserListItem - , PromptConfig(..), promptYorn, promptChar - -- * Text - , getViewer, editFile, runEditor - , stripCr - -- * Help - , environmentHelpEditor, environmentHelpPager - -- * Errors and exceptions - , catchall - , clarifyErrors, prettyException, prettyError - , addToErrorLoc - -- * Files and directories - , getFileStatus - , withCurrentDirectory - , withUMask - -- * Locales - , getSystemEncoding - , isUTF8Locale - -- * Tree filtering. - , filterFilePaths, filterPaths - -- * Tree lookup. - , treeHas, treeHasDir, treeHasFile, treeHasAnycase - ) where import Prelude hiding ( catch ) + import Control.Exception.Extensible ( bracket, bracket_, catch, try, IOException, SomeException, Exception(fromException) ) -import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString - , isDoesNotExistError, ioeGetFileName ) - -import Darcs.SignalHandler ( catchNonSignal ) -import Numeric ( showHex ) -import System.Directory ( doesFileExist ) -import System.Exit ( ExitCode(..) ) -import System.Environment ( getEnv ) -import Data.Char ( toUpper, toLower, isSpace ) -import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath ) -import Data.Maybe ( isJust ) -import Data.List ( group, sort ) import Control.Monad ( when, forM ) import Control.Monad.Error( MonadError ) -import Exec ( execInteractive ) -import Foreign.C.String ( CString, withCString, peekCString ) -import Foreign.C.Error ( throwErrno ) -import Foreign.C.Types ( CInt ) -import Text.Regex +import Control.Monad.State.Strict( gets ) +import qualified Data.ByteString as B ( readFile ) import qualified Data.ByteString.Char8 as BSC -import System.Posix.Files( getSymbolicLinkStatus, FileStatus ) +import Data.Char ( toUpper, toLower, isSpace ) +import Data.List ( group, sort ) +import Data.Maybe ( isJust ) -import Progress ( withoutProgress ) +import Foreign.C.String ( CString, withCString, peekCString ) +import Foreign.C.Error ( throwErrno ) +import Foreign.C.Types ( CInt ) -import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine, - getInputChar, outputStr, outputStrLn ) -import qualified Data.ByteString as B ( readFile ) +#ifdef FORCE_CHAR8_ENCODING +import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 ) +#endif -import Control.Monad.State.Strict( gets ) import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath ) import Storage.Hashed.Monad( withDirectory, fileExists, directoryExists , virtualTreeMonad, currentDirectory , TreeMonad ) import qualified Storage.Hashed.Monad as HS ( exists, tree ) + import Storage.Hashed.Tree( Tree, listImmediate, findTree ) -showHexLen :: (Integral a, Show a) => Int -> a -> String +import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine, + getInputChar, outputStr, outputStrLn ) +import System.Directory ( doesFileExist ) +import System.Environment ( getEnv ) +import System.Exit ( ExitCode(..) ) +import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString + , isDoesNotExistError, ioeGetFileName ) +import System.Posix.Files( getSymbolicLinkStatus, FileStatus ) + +import Text.Regex + +import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath ) +import Darcs.SignalHandler ( catchNonSignal ) + +import Exec ( execInteractive ) +import Numeric ( showHex ) +import Progress ( withoutProgress ) + + +showHexLen :: (Integral a, Show a) + => Int + -> a + -> String showHexLen n x = let s = showHex x "" in replicate (n - length s) ' ' ++ s -addToErrorLoc :: IOException -> String -> IOException + +addToErrorLoc :: IOException + -> String + -> IOException addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing -catchall :: IO a -> IO a -> IO a + +catchall :: IO a + -> IO a + -> IO a a `catchall` b = a `catchNonSignal` (\_ -> b) -maybeGetEnv :: String -> IO (Maybe String) + +maybeGetEnv :: String + -> IO (Maybe String) maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist --- |The firstJustM returns the first Just entry in a list of monadic operations. This is close to --- `listToMaybe `fmap` sequence`, but the sequence operator evaluates all monadic members of the --- list before passing it along (i.e. sequence is strict). The firstJustM is lazy in that list --- member monads are only evaluated up to the point where the first Just entry is obtained. -firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) +-- | The firstJustM returns the first Just entry in a list of monadic +-- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence +-- operator evaluates all monadic members of the list before passing it along +-- (i.e. sequence is strict). The firstJustM is lazy in that list member monads +-- are only evaluated up to the point where the first Just entry is obtained. +firstJustM :: Monad m + => [m (Maybe a)] + -> m (Maybe a) firstJustM [] = return Nothing firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es) --- |The firstJustIO is a slight modification to firstJustM: the --- entries in the list must be IO monad operations and the --- firstJustIO will silently turn any monad call that throws an --- exception into Nothing, basically causing it to be ignored. -firstJustIO :: [IO (Maybe a)] -> IO (Maybe a) + +-- | The firstJustIO is a slight modification to firstJustM: the entries in the +-- list must be IO monad operations and the firstJustIO will silently turn any +-- monad call that throws an exception into Nothing, basically causing it to be +-- ignored. +firstJustIO :: [IO (Maybe a)] + -> IO (Maybe a) firstJustIO = firstJustM . map (`catchall` return Nothing) -clarifyErrors :: IO a -> String -> IO a +clarifyErrors :: IO a + -> String + -> IO a clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e]) -prettyException :: SomeException -> String + +prettyException :: SomeException + -> String prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe = case ioeGetFileName ioe of @@ -116,25 +170,36 @@ Nothing -> show e prettyException e = show e + prettyError :: IOError -> String prettyError e | isUserError e = ioeGetErrorString e | otherwise = show e + -- | Given two shell commands as arguments, execute the former. The -- latter is then executed if the former failed because the executable -- wasn't found (code 127), wasn't executable (code 126) or some other -- exception occurred. Other failures (such as the user holding ^C) -- do not cause the second command to be tried. -ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode +ortryrunning :: IO ExitCode + -> IO ExitCode + -> IO ExitCode a `ortryrunning` b = do ret <- try a case ret of (Right (ExitFailure 126)) -> b -- command not executable (Right (ExitFailure 127)) -> b -- command not found +#ifdef WIN32 + (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows +#endif (Right x) -> return x -- legitimate success/failure (Left (_ :: SomeException)) -> b -- an exception -withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a + +withCurrentDirectory :: FilePathLike p + => p + -> IO a + -> IO a withCurrentDirectory name m = bracket (do cwd <- getCurrentDirectory @@ -143,12 +208,16 @@ (\oldwd -> setCurrentDirectory oldwd `catchall` return ()) (const m) + foreign import ccall unsafe "umask.h set_umask" set_umask :: CString -> IO CInt foreign import ccall unsafe "umask.h reset_umask" reset_umask :: CInt -> IO CInt -withUMask :: String -> IO a -> IO a + +withUMask :: String + -> IO a + -> IO a withUMask umask job = do rc <- withCString umask set_umask when (rc < 0) (throwErrno "Couldn't set umask") @@ -157,6 +226,7 @@ (reset_umask rc) job + -- | Ask the user for a line of input. askUser :: String -- ^ The prompt to display -> IO String -- ^ The string the user entered. @@ -164,83 +234,106 @@ getInputLine prompt >>= maybe (error "askUser: unexpected end of input") return +-- | Ask the user to press Enter +askEnter :: String -- ^ The prompt to display + -> IO () +askEnter prompt = askUser prompt >> return () + -- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing -- the user to choose one of the items -askUserListItem :: String -> [String] -> IO String +askUserListItem :: String + -> [String] + -> IO String askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do - outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs - loop - where - loop = do - answer <- getInputLine prompt - >>= maybe (error "askUser: unexpected end of input") return - case maybeRead answer of - Just n | n > 0 && n <= length xs -> return (xs !! (n-1)) - _ -> outputStrLn "Invalid response, try again!" >> loop + outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs + loop + where + loop = do + answer <- getInputLine prompt + >>= maybe (error "askUser: unexpected end of input") return + case maybeRead answer of + Just n | n > 0 && n <= length xs -> return (xs !! (n-1)) + _ -> outputStrLn "Invalid response, try again!" >> loop -maybeRead :: Read a => String -> Maybe a + +maybeRead :: Read a + => String + -> Maybe a maybeRead s = case reads s of - [(x, rest)] | all isSpace rest -> Just x - _ -> Nothing + [(x, rest)] | all isSpace rest -> Just x + _ -> Nothing -stripCr :: String -> String + +stripCr :: String + -> String stripCr "" = "" stripCr "\r" = "" stripCr (c:cs) = c : stripCr cs --- Format a path for screen output, --- so that the user sees where the path begins and ends. --- Could (should?) also warn about unprintable characters here. -formatPath :: String -> String +-- | Format a path for screen output, so that the user sees where the path +-- begins and ends. Could (should?) also warn about unprintable characters here. +formatPath :: String + -> String formatPath path = "\"" ++ quote path ++ "\"" where quote "" = "" quote (c:cs) = if c `elem` ['\\', '"'] then '\\':c:quote cs else c:quote cs + breakCommand :: String -> (String, [String]) breakCommand s = case words s of (arg0:args) -> (arg0,args) [] -> (s,[]) -nubsort :: Ord a => [a] -> [a] + +nubsort :: Ord a + => [a] + -> [a] nubsort = map head . group . sort --- | @editFile f@ lets the user edit a file which could but does not need --- to already exist. This function returns the exit code from the text --- editor and a flag indicating if the user made any changes. -editFile :: FilePathLike p => p -> IO (ExitCode, Bool) +-- | @editFile f@ lets the user edit a file which could but does not need to +-- already exist. This function returns the exit code from the text editor and a +-- flag indicating if the user made any changes. +editFile :: FilePathLike p + => p + -> IO (ExitCode, Bool) editFile ff = do - old_content <- file_content - ec <- runEditor f - new_content <- file_content - return (ec, new_content /= old_content) - where f = toFilePath ff - file_content = do - exists <- doesFileExist f - if exists then do content <- B.readFile f - return $ Just content - else return Nothing + old_content <- file_content + ec <- runEditor f + new_content <- file_content + return (ec, new_content /= old_content) + where + f = toFilePath ff + file_content = do + exists <- doesFileExist f + if exists then do content <- B.readFile f + return $ Just content + else return Nothing -runEditor :: FilePath -> IO ExitCode + +runEditor :: FilePath + -> IO ExitCode runEditor f = do - ed <- getEditor - execInteractive ed f - `ortryrunning` execInteractive "emacs" f - `ortryrunning` execInteractive "emacs -nw" f - `ortryrunning` execInteractive "nano" f + ed <- getEditor + execInteractive ed f + `ortryrunning` execInteractive "emacs" f + `ortryrunning` execInteractive "emacs -nw" f + `ortryrunning` execInteractive "nano" f #ifdef WIN32 - `ortryrunning` execInteractive "edit" f + `ortryrunning` execInteractive "edit" f #endif + getEditor :: IO String getEditor = getEnv "DARCS_EDITOR" `catchall` getEnv "DARCSEDITOR" `catchall` getEnv "VISUAL" `catchall` getEnv "EDITOR" `catchall` return "vi" + environmentHelpEditor :: ([String], [String]) environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[ "To edit a patch description of email comment, Darcs will invoke an", @@ -250,6 +343,7 @@ "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are", "each tried in turn."]) + getViewer :: IO String getViewer = getEnv "DARCS_PAGER" `catchall` getEnv "PAGER" `catchall` return "less" @@ -267,10 +361,12 @@ , pHelp :: [Char] } + -- | Prompt the user for a yes or no promptYorn :: [Char] -> IO Bool promptYorn p = (== 'y') `fmap` promptChar (PromptConfig p "yn" [] Nothing []) + promptChar :: PromptConfig -> IO Char promptChar (PromptConfig p basic_chs adv_chs md help_chs) = withoutProgress $ runInputT defaultSettings loopChar @@ -296,27 +392,45 @@ Just d -> map (setUpper d) s setUpper d c = if d == c then toUpper c else c + -- | Construct a filter from a list of AnchoredPaths, that will accept any path -- that is either a parent or a child of any of the listed paths, and discard -- everything else. -filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool +filterPaths :: [AnchoredPath] + -> AnchoredPath + -> t + -> Bool filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files + -- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to -- AnchoredPath). -filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool +filterFilePaths :: [FilePath] + -> AnchoredPath + -> t + -> Bool filterFilePaths = filterPaths . map floatPath -getFileStatus :: FilePath -> IO (Maybe FileStatus) + +getFileStatus :: FilePath + -> IO (Maybe FileStatus) getFileStatus f = Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing -treeHasAnycase :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool -treeHasAnycase tree path = fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree -existsAnycase :: (MonadError e m, Functor m, Monad m) => AnchoredPath -> TreeMonad m Bool +treeHasAnycase :: (MonadError e m, Functor m, Monad m) + => Tree m + -> FilePath + -> m Bool +treeHasAnycase tree path = + fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree + + +existsAnycase :: (MonadError e m, Functor m, Monad m) + => AnchoredPath + -> TreeMonad m Bool existsAnycase (AnchoredPath []) = return True -existsAnycase (AnchoredPath (Name x:xs)) = +existsAnycase (AnchoredPath (Name x:xs)) = do do wd <- currentDirectory Just tree <- gets (flip findTree wd . HS.tree) let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree, @@ -326,6 +440,7 @@ if file then return True else withDirectory path (existsAnycase $ AnchoredPath xs)) + treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree @@ -335,6 +450,38 @@ treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree +-- | In some environments, darcs requires that certain global GHC library variables that +-- control the encoding used in internal translations are set to specific values. +-- +-- @setDarcsEncoding@ enforces those settings, and should be called before the +-- first time any darcs operation is run, and again if anything else might have +-- set those encodings to different values. +-- +-- Note that it isn't thread-safe and has a global effect on your program. +-- +-- The current behaviour of this function is as follows, though this may +-- change in future: +-- +-- Encodings are only set on GHC 7.4 and up, on any non-Windows platform. +-- +-- Two encodings are set, both to @GHC.IO.Encoding.char8@: +-- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@. +-- +setDarcsEncodings :: IO () +setDarcsEncodings = do +#ifdef FORCE_CHAR8_ENCODING + +-- This is needed for appropriate behaviour from getArgs and from general +-- filesystem calls (e.g. getDirectoryContents, readFile, ...) + setFileSystemEncoding char8 + +-- This ensures that foreign calls made by hashed-storage to stat +-- filenames returned from getDirectoryContents are translated appropriately + setForeignEncoding char8 + +#endif + return () + -- The following functions are copied from the encoding package (BSD3 -- licence, by Henning Günther). @@ -342,10 +489,12 @@ foreign import ccall "system_encoding.h get_system_encoding" get_system_encoding :: IO CString + getSystemEncoding :: IO String getSystemEncoding = do enc <- get_system_encoding peekCString enc + -- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a -- subset of UTF-8). diff --git a/src/DateMatcher.hs b/src/DateMatcher.hs --- a/src/DateMatcher.hs +++ b/src/DateMatcher.hs @@ -15,24 +15,36 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. - {-# LANGUAGE ExistentialQuantification #-} -module DateMatcher ( parseDateMatcher - -- for debugging only - , DateMatcher(..), getMatchers ) where +-- | +-- Module : DateMatcher +-- Copyright : 2004 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable -import Prelude hiding ( catch ) +module DateMatcher ( + parseDateMatcher + -- for debugging only + , DateMatcher(..) + , getMatchers + ) where + import Control.Exception.Extensible ( catch, throw ) -import System.IO.Error ( isUserError, ioeGetErrorString ) import Data.Maybe ( isJust ) +import Prelude hiding ( catch ) + +import System.IO.Error ( isUserError, ioeGetErrorString ) import System.Time -import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601Interval, - resetCalendar, subtractFromMCal, getLocalTz, +import Text.ParserCombinators.Parsec ( eof, parse, ParseError ) + +import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, + iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz, MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime, - unsetTime, + unsetTime ) -import Text.ParserCombinators.Parsec ( eof, parse, ParseError ) -- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@ -- Note that this converts the two dates to @ClockTime@ to avoid @@ -41,14 +53,15 @@ withinDay a b = within (Just $ toClockTime a) (Just (addToClockTime day $ toClockTime a)) (toClockTime b) - where day = TimeDiff 0 0 1 0 0 0 0 + where + day = TimeDiff 0 0 1 0 0 0 0 -- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@ -- Since @x1@ and @x2@ can be underspecified, we simply assume the -- first date that they could stand for. dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool -dateRange a b c = cDateRange (fmap unsafeToCalendarTime a) - (fmap unsafeToCalendarTime b) c +dateRange a b = cDateRange (fmap unsafeToCalendarTime a) + (fmap unsafeToCalendarTime b) -- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@ cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool @@ -72,99 +85,104 @@ -- second. samePartialDate :: MCalendarTime -> CalendarTime -> Bool samePartialDate a b_ = - within (Just clockA) - (Just $ addToClockTime interval clockA) - (toClockTime calB) - where interval - | isJust (mctSec a) = second - | isJust (mctMin a) = minute - | isJust (mctHour a) = hour - | isJust (mctYDay a) = day - | mctWeek a = maybe week (const day) (mctWDay a) - | isJust (mctDay a) = day - | isJust (mctMonth a) = month - | otherwise = year - year = TimeDiff 1 0 0 0 0 0 0 - month = TimeDiff 0 1 0 0 0 0 0 - week = TimeDiff 0 0 7 0 0 0 0 - day = TimeDiff 0 0 1 0 0 0 0 - hour = TimeDiff 0 0 0 1 0 0 0 - minute = TimeDiff 0 0 0 0 1 0 0 - second = TimeDiff 0 0 0 0 0 1 0 - -- - clockA = toClockTime $ unsafeToCalendarTime a - calB = resetCalendar b_ + within (Just clockA) + (Just $ addToClockTime interval clockA) + (toClockTime calB) + where + interval + | isJust (mctSec a) = second + | isJust (mctMin a) = minute + | isJust (mctHour a) = hour + | isJust (mctYDay a) = day + | mctWeek a = maybe week (const day) (mctWDay a) + | isJust (mctDay a) = day + | isJust (mctMonth a) = month + | otherwise = year + year = TimeDiff 1 0 0 0 0 0 0 + month = TimeDiff 0 1 0 0 0 0 0 + week = TimeDiff 0 0 7 0 0 0 0 + day = TimeDiff 0 0 1 0 0 0 0 + hour = TimeDiff 0 0 0 1 0 0 0 + minute = TimeDiff 0 0 0 0 1 0 0 + second = TimeDiff 0 0 0 0 0 1 0 + clockA = toClockTime $ unsafeToCalendarTime a + calB = resetCalendar b_ -- | A 'DateMatcher' combines a potential parse for a date string -- with a "matcher" function that operates on a given date. -- We use an existential type on the matcher to allow -- the date string to either be interpreted as a point in time -- or as an interval. -data DateMatcher = forall d . (Show d) => - DM String -- name - (Either ParseError d) -- parser - (d -> CalendarTime -> Bool) -- matcher +data DateMatcher = forall d . (Show d) => DM + String -- name + (Either ParseError d) -- parser + (d -> CalendarTime -> Bool) -- matcher -- | 'parseDateMatcher' @s@ return the first matcher in -- 'getMatchers' that can parse 's' parseDateMatcher :: String -> IO (CalendarTime -> Bool) -parseDateMatcher d = - do matcher <- tryMatchers `fmap` getMatchers d - -- Hack: test the matcher against the current date and discard the results. - -- We just want to make sure it won't throw any exceptions when we use it for real. - matcher `fmap` now >>= (`seq` return matcher) - `catchUserError` +parseDateMatcher d = testDateMatcher `catchUserError` handleError + where + catchUserError comp handler = catch comp $ \e -> + if isUserError e then handler (ioeGetErrorString e) else throw e + -- If the user enters a date > maxint seconds ago, the toClockTime -- function cannot work. - \e -> if e == "Time.toClockTime: invalid input" - then error "Can't handle dates that far back!" - else error e - where - catchUserError comp handler - = catch comp (\e -> if isUserError e then handler (ioeGetErrorString e) else throw e) + handleError e = if e == "Time.toClockTime: invalid input" + then error "Can't handle dates that far back!" + else error e + -- Hack: test the matcher against the current date and discard the results. + -- We just want to make sure it won't throw any exceptions when we use it + -- for real. + testDateMatcher = do + matcher <- tryMatchers `fmap` getMatchers d + matcher `fmap` now >>= (`seq` return matcher) + -- | 'getMatchers' @d@ returns the list of matchers that will be -- applied on @d@. If you wish to extend the date parsing code, -- this will likely be the function that you modify to do so. getMatchers :: String -> IO [DateMatcher] -getMatchers d = - do rightNow <- now +getMatchers d = do + rightNow <- now let midnightToday = unsetTime rightNow mRightNow = toMCalendarTime rightNow - matchIsoInterval (Left dur) = dateRange (Just $ dur `subtractFromMCal` mRightNow) (Just mRightNow) + matchIsoInterval (Left dur) = + let durAgo = dur `subtractFromMCal` mRightNow in + dateRange (Just durAgo) (Just mRightNow) matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b) tzNow <- getLocalTz - return -- note that the order of these is quite important as some matchers - -- can match the same date. - [ DM "from English date" - (parseDateWith $ englishLast midnightToday) - (\(a,_) -> cDateRange (Just a) Nothing) - , DM "specific English date" - (parseDateWith $ englishDateTime midnightToday) - withinDay - , DM "English interval" - (parseDateWith $ englishInterval rightNow) - (uncurry cDateRange) - , DM "ISO 8601 interval" - (parseDateWith $ iso8601Interval tzNow) - matchIsoInterval - , DM "CVS, ISO 8601, or old style date" - (parseDate tzNow d) - samePartialDate ] - where - tillEof p = do { x <- p; eof; return x } - parseDateWith p = parse (tillEof p) "" d + return + -- note that the order of these is quite important as some matchers can + -- match the same date. + [ DM "from English date" + (parseDateWith $ englishLast midnightToday) + (\(a,_) -> cDateRange (Just a) Nothing) + , DM "specific English date" + (parseDateWith $ englishDateTime midnightToday) + withinDay + , DM "English interval" + (parseDateWith $ englishInterval rightNow) + (uncurry cDateRange) + , DM "ISO 8601 interval" + (parseDateWith $ iso8601Interval tzNow) + matchIsoInterval + , DM "CVS, ISO 8601, or old style date" + (parseDate tzNow d) + samePartialDate + ] + where + tillEof p = do { x <- p; eof; return x } + parseDateWith p = parse (tillEof p) "" d -- | 'tryMatchers' @ms@ returns the first successful match in @ms@ -- It is an error if there are no matches -tryMatchers :: [DateMatcher] -> (CalendarTime -> Bool) +tryMatchers :: [DateMatcher] -> CalendarTime -> Bool tryMatchers (DM _ parsed matcher : ms) = - case parsed of - Left _ -> tryMatchers ms - Right d -> matcher d + case parsed of + Left _ -> tryMatchers ms + Right d -> matcher d tryMatchers [] = error "Can't support fancy dates." --- darcs-doc: self-explanatory now :: IO CalendarTime now = getClockTime >>= toCalendarTime - diff --git a/src/English.hs b/src/English.hs --- a/src/English.hs +++ b/src/English.hs @@ -15,13 +15,22 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. --- | This modules provides rudimentary natural language generation +-- | +-- Module : English +-- Copyright : 2008 Eric Kow +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable +-- +-- This modules provides rudimentary natural language generation -- (NLG) utilities. That is, generating natural language from a -- machine representation. Initially, only English is supported at -- all. Representations are implemented for: -- -- * countable nouns (plurality); and -- * lists of clauses (foo, bar and/or baz). + module English where import Data.List (isSuffixOf, intercalate) @@ -34,8 +43,8 @@ -- | Things that have a plural and singular spelling class Countable a where - plural :: a -> ShowS - singular :: a -> ShowS + plural :: a -> ShowS + singular :: a -> ShowS -- | This only distinguishes between nouns with a final -ch, -- and nouns which do not. @@ -48,32 +57,33 @@ data Pronoun = It instance Countable Noun where - -- more irregular nouns will just need to have their own type - plural (Noun s) | "ch" `isSuffixOf` s = showString s . showString "es" - plural (Noun s) | "y" `isSuffixOf` s - && length s > 1 - && last (init s) `notElem` "aeiou" = showString (init s) . showString "ies" - plural (Noun s) = showString s . showChar 's' - singular (Noun s) = showString s + -- more irregular nouns will just need to have their own type + plural (Noun s) | "ch" `isSuffixOf` s = showString s . showString "es" + plural (Noun s) | "y" `isSuffixOf` s + && length s > 1 + && last (init s) `notElem` "aeiou" = + showString (init s) . showString "ies" + plural (Noun s) = showString s . showChar 's' + singular (Noun s) = showString s instance Countable Pronoun where - plural It = showString "them" - singular It = showString "it" + plural It = showString "them" + singular It = showString "it" -- | > singular This (Noun "batch") "" == "this batch" -- > plural This (Noun "batch") "" == "these batches" data This = This Noun instance Countable This where - plural (This s) = showString "these " . plural s - singular (This s) = showString "this " . singular s + plural (This s) = showString "these " . plural s + singular (This s) = showString "this " . singular s -- | Given a list of things, combine them thusly: -- -- > orClauses ["foo", "bar", "baz"] == "foo, bar or baz" andClauses, orClauses :: [String] -> String andClauses = intersperseLast ", " " and " -orClauses = intersperseLast ", " " or " +orClauses = intersperseLast ", " " or " -- | As 'intersperse', with a different separator for the last -- | interspersal. diff --git a/src/Exec.hs b/src/Exec.hs --- a/src/Exec.hs +++ b/src/Exec.hs @@ -15,16 +15,24 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. - {-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable #-} -module Exec ( exec, execInteractive, - withoutNonBlock, - Redirects, Redirect(..), - ExecException(..) - ) where +-- | +-- Module : Exec +-- Copyright : 2003 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable -import Data.Typeable ( Typeable, cast ) +module Exec ( + exec + , execInteractive + , withoutNonBlock + , Redirects + , Redirect(..) + , ExecException(..) + ) where #ifndef WIN32 import Control.Exception.Extensible ( bracket ) @@ -36,17 +44,20 @@ import Data.List ( isInfixOf ) #endif -import System.Exit ( ExitCode (..) ) -import System.Cmd ( system ) -import System.IO ( IOMode(..), openBinaryFile, stdout ) -import System.Process ( runProcess, terminateProcess, waitForProcess ) #if __GLASGOW_HASKELL__ >= 612 import GHC.IO.Handle ( hDuplicate ) #else import GHC.Handle ( hDuplicate ) #endif -import Control.Exception.Extensible ( bracketOnError, Exception(..), SomeException(..) ) +import Control.Exception.Extensible ( bracketOnError, Exception(..), + SomeException(..) ) +import Data.Typeable ( Typeable, cast ) +import System.Cmd ( system ) +import System.Exit ( ExitCode (..) ) +import System.IO ( IOMode(..), openBinaryFile, stdout ) +import System.Process ( runProcess, terminateProcess, waitForProcess ) + import Darcs.Global ( whenDebugMode ) import Progress ( withoutProgress ) @@ -69,7 +80,10 @@ -} type Redirects = (Redirect, Redirect, Redirect) -data Redirect = AsIs | Null | File FilePath + +data Redirect = AsIs + | Null + | File FilePath | Stdout deriving Show @@ -79,12 +93,16 @@ doesn't exist. -} -- ExecException cmd args redirecs errorDesc -data ExecException = ExecException String [String] Redirects String +data ExecException = ExecException + String -- cmd + [String] -- args + Redirects -- redirects + String -- errorDesc deriving (Typeable,Show) instance Exception ExecException where - toException e = SomeException e - fromException (SomeException e) = cast e + toException e = SomeException e + fromException (SomeException e) = cast e _devNull :: FilePath #ifdef WIN32 @@ -97,29 +115,28 @@ We use System.Process, which does the necessary quoting and redirection for us behind the scenes. -} - exec :: String -> [String] -> Redirects -> IO ExitCode exec cmd args (inp,out,err) = withoutProgress $ do - h_stdin <- redirect inp ReadMode - h_stdout <- redirect out WriteMode - h_stderr <- redirect err WriteMode --- putStrLn (unwords (cmd:args ++ map show [inp,out,err])) - withExit127 $ bracketOnError - (do whenDebugMode $ putStrLn $ unwords $ cmd:args ++ ["; #"] ++ map show [inp,out,err] - runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr) - (terminateProcess) - (waitForProcess) + h_stdin <- redirect inp ReadMode + h_stdout <- redirect out WriteMode + h_stderr <- redirect err WriteMode + withExit127 $ bracketOnError + (do doOptionalDebug + runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr) + (terminateProcess) + (waitForProcess) where + doOptionalDebug = whenDebugMode . putStrLn . unwords $ + cmd : args ++ ["; #"] ++ map show [inp, out, err] redirect AsIs _ = return Nothing redirect Null mode = Just `fmap` openBinaryFile _devNull mode redirect (File "/dev/null") mode = redirect Null mode redirect (File f) mode = Just `fmap` openBinaryFile f mode + -- hDuplicate stdout rather than passing stdout itself, + -- because runProcess closes the Handles we pass it. redirect Stdout _ = Just `fmap` hDuplicate stdout - -- hDuplicate stdout rather than passing stdout itself, - -- because runProcess closes the Handles we pass it. execInteractive :: String -> String -> IO ExitCode - #ifndef WIN32 {- This should handle arbitrary commands interpreted by the shell on Unix since @@ -128,26 +145,40 @@ cmd "$DARCS_ARGUMENT" -} execInteractive cmd arg = withoutProgress $ do - let var = "DARCS_ARGUMENT" - stdin `seq` return () - withoutNonBlock $ bracket - (do oldval <- getEnv var - setEnv var arg True - return oldval) - (\oldval -> - do case oldval of - Nothing -> unsetEnv var - Just val -> setEnv var val True) - (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"") + let var = "DARCS_ARGUMENT" + stdin `seq` return () + withoutNonBlock $ bracket + (do oldval <- getEnv var + setEnv var arg True + return oldval) + (\oldval -> + case oldval of + Nothing -> unsetEnv var + Just val -> setEnv var val True) + (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"") #else - +-- The `system' function passes commands to execute via cmd.exe (or +-- command.com) it's return value is equivalent to the one returned by the +-- shell. For regular applications - this works correctly resulting in the +-- exit code of the program. However in case of a command/file which can't be +-- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009 +-- which on windows is equivalent to ExitFailure 127 from *nix machines. +-- +-- Here we force return the exit code of the last cmd.exe action by appending +-- & exit !errorlevel! to the command being executed that way chaining with +-- ortryrunning works correctly. +-- +-- SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done +-- correctly on systems where that function is not enabled by default. +-- execInteractive cmd arg = withoutProgress $ do - system $ cmd ++ " " ++ arg + withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++ + cmd ++ " " ++ arg ++ + " & exit !errorlevel!" #endif withoutNonBlock :: IO a -> IO a - #ifndef WIN32 {- Do IO without NonBlockingRead on stdInput. @@ -160,7 +191,7 @@ do nb <- queryFdOption stdInput NonBlockingRead if nb then bracket - (do setFdOption stdInput NonBlockingRead False) + (setFdOption stdInput NonBlockingRead False) (\_ -> setFdOption stdInput NonBlockingRead True) (\_ -> x) else x diff --git a/src/IsoDate.hs b/src/IsoDate.hs --- a/src/IsoDate.hs +++ b/src/IsoDate.hs @@ -16,6 +16,14 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +-- | +-- Module : IsoDate +-- Copyright : 2003 Peter Simons +-- 2003 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate, parseDate, getLocalTz, @@ -303,8 +311,8 @@ | otherwise = 10 ^ (picoExp - digsExp) * (read digs) return $ \c -> c { mctPicosec = Just $ frac } zulu = do { _ <- char 'Z'; return (\c -> c { mctTZ = Just 0 }) } - offset = do sign <- choice [ do { char '+' >> return 1 } - , do { char '-' >> return (-1) } ] + offset = do sign <- choice [ char '+' >> return 1 + , char '-' >> return (-1) ] h <- twoDigits m <- option 0 $ do { optional colon; twoDigits } return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) } @@ -604,7 +612,7 @@ englishAgo :: CalendarTime -> CharParser a CalendarTime englishAgo now = try $ do p <- englishDuration - _ <- try $ do space + _ <- try space (m,ref) <- (try $ caseString "ago" >> return ((-1), now)) <|> do m <- beforeMod <|> afterMod _ <- space diff --git a/src/Lcs.hs b/src/Lcs.hs --- a/src/Lcs.hs +++ b/src/Lcs.hs @@ -18,7 +18,16 @@ {-# LANGUAGE CPP #-} --- | LCS stands for Longest Common Subsequence, and it is a relatively +-- | +-- Module : Lcs +-- Copyright : 2003 David Roundy +-- 2005 Benedikt Schmidt +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable +-- +-- LCS stands for Longest Common Subsequence, and it is a relatively -- challenging problem to find an LCS efficiently. This module implements -- the algorithm described in: -- @@ -41,6 +50,7 @@ -- The last step tries to create longer changed regions and line up deletions -- in the first file to insertions in the second by shifting changed lines -- forward and backward. + module Lcs ( getChanges, shiftBoundaries ) where diff --git a/src/Progress.hs b/src/Progress.hs --- a/src/Progress.hs +++ b/src/Progress.hs @@ -1,203 +1,305 @@ --- Utility functions for tracking progress of long-running actions. - {-# LANGUAGE CPP #-} #include "gadts.h" -module Progress ( beginTedious, endTedious, tediousSize, - debugMessage, debugFail, withoutProgress, - progress, progressKeepLatest, finishedOne, - finishedOneIO, progressList, minlist, - setProgressMode) where +-- | +-- Module : Progress +-- Copyright : 2008 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions for tracking progress of long-running actions. +module Progress + ( + beginTedious + , endTedious + , tediousSize + , debugMessage + , debugFail + , withoutProgress + , progress + , progressKeepLatest + , finishedOne + , finishedOneIO + , progressList + , minlist + , setProgressMode + ) where + + import Prelude hiding (lookup) import Control.Exception.Extensible ( onException ) import Control.Monad ( when ) -import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, - hSetBuffering, hIsTerminalDevice, - Handle, BufferMode(LineBuffering) ) -import System.IO.Unsafe ( unsafePerformIO ) +import Control.Concurrent ( forkIO, threadDelay ) + import Data.Char ( toLower ) import Data.Map ( Map, empty, adjust, insert, delete, lookup ) import Data.Maybe ( isJust ) -import Control.Concurrent ( forkIO, threadDelay ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) +import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn, + hSetBuffering, hIsTerminalDevice, + Handle, BufferMode(LineBuffering) ) +import System.IO.Unsafe ( unsafePerformIO ) + import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail ) + +data ProgressData = ProgressData + { sofar :: !Int + , latest :: !(Maybe String) + , total :: !(Maybe Int) + } + handleProgress :: IO () -handleProgress = do threadDelay 1000000 - handleMoreProgress "" 0 +handleProgress = do + threadDelay 1000000 + handleMoreProgress "" 0 + handleMoreProgress :: String -> Int -> IO () handleMoreProgress k n = withProgressMode $ \m -> if m then do s <- getProgressLast mp <- getProgressData s case mp of - Nothing -> do threadDelay 1000000 - handleMoreProgress k n - Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p - threadDelay 1000000 - handleMoreProgress s (sofar p) + Nothing -> do + threadDelay 1000000 + handleMoreProgress k n + Just p -> do + when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p + threadDelay 1000000 + handleMoreProgress s (sofar p) else do threadDelay 1000000 handleMoreProgress k n -printProgress :: String -> ProgressData -> IO () + +printProgress :: String + -> ProgressData + -> IO () printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) = myput output output - where output = (k++" "++show s++" done, "++show (t - s)++" queued. "++l) + where + output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l printProgress k (ProgressData {latest=Just l}) = - myput (k++" "++l) k + myput (k ++ " " ++ l) k printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s = - myput (k++" "++show s++" done, "++show (t - s)++" queued") (k++" "++show s) + myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued") + (k ++ " " ++ show s) printProgress k (ProgressData {sofar=s}) = - myput (k++" "++show s) k + myput (k ++ " " ++ show s) k + myput :: String -> String -> IO () myput l s = withDebugMode $ \debugMode -> - if debugMode - then putTiming >> hPutStrLn stderr l - else if '\n' `elem` l - then myput (takeWhile (/= '\n') l) s - else putTiming >> if length l < 80 then simpleput l - else simpleput (take 80 s) + if debugMode + then putTiming >> hPutStrLn stderr l + else + if '\n' `elem` l + then myput (takeWhile (/= '\n') l) s + else putTiming >> if length l < 80 + then simpleput l + else simpleput (take 80 s) -{-# NOINLINE simpleput #-} + simpleput :: String -> IO () simpleput = unsafePerformIO $ mkhPutCr stderr +{-# NOINLINE simpleput #-} + -- | @beginTedious k@ starts a tedious process and registers it in --- '_progressData' with the key @k@. A tedious process is one for which we --- want a progress indicator. +-- '_progressData' with the key @k@. A tedious process is one for which we want +-- a progress indicator. -- --- Wouldn't it be safer if it had type String -> IO --- ProgressDataKey, so that we can ensure there is no collision? --- What happens if you call beginTedious twice with the same string, without --- calling endTedious in the meantime? +-- Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we +-- can ensure there is no collision? What happens if you call beginTedious twice +-- with the same string, without calling endTedious in the meantime? beginTedious :: String -> IO () -beginTedious k = do debugMessage $ "Beginning " ++ map toLower k - setProgressData k $ ProgressData { sofar = 0, - latest = Nothing, - total = Nothing } +beginTedious k = do + debugMessage $ "Beginning " ++ map toLower k + setProgressData k $ ProgressData + { sofar = 0 + , latest = Nothing + , total = Nothing + } --- | @endTedious k@ unregisters the tedious process with key @k@, printing "Done" if such --- a tedious process exists. + +-- | @endTedious k@ unregisters the tedious process with key @k@, printing +-- "Done" if such a tedious process exists. endTedious :: String -> IO () -endTedious k = whenProgressMode $ do p <- getProgressData k - modifyIORef _progressData (\(a,m) -> (a,delete k m)) - when (isJust p) $ debugMessage $ "Done "++ - (map toLower k) +endTedious k = whenProgressMode $ do + p <- getProgressData k + modifyIORef _progressData (\(a,m) -> (a,delete k m)) + when (isJust p) $ debugMessage $ "Done " ++ + (map toLower k) -tediousSize :: String -> Int -> IO () + +tediousSize :: String + -> Int + -> IO () tediousSize k s = updateProgressData k uptot - where uptot p = case total p of Just t -> seq ts $ p { total = Just ts } - where ts = t + s - Nothing -> p { total = Just s } + where + uptot p = case total p of + Just t -> seq ts $ p { total = Just ts } + where ts = t + s + Nothing -> p { total = Just s } + +-- | XXX: document this constant minlist :: Int minlist = 4 -progressList :: String -> [a] -> [a] + +progressList :: String + -> [a] + -> [a] progressList _ [] = [] -progressList k (x:xs) = if l < minlist then x:xs - else startit x : pl xs - where l = length (x:xs) - startit y = unsafePerformIO $ do beginTedious k - tediousSize k l - return y - pl [] = [] - pl [y] = unsafePerformIO $ do endTedious k - return [y] - pl (y:ys) = progress k y : pl ys +progressList k (x:xs) = if l < minlist + then x:xs + else startit x : pl xs + where + l = length (x:xs) + startit y = unsafePerformIO $ do + beginTedious k + tediousSize k l + return y -progress :: String -> a -> a + pl [] = [] + pl [y] = unsafePerformIO $ do + endTedious k + return [y] + pl (y:ys) = progress k y : pl ys + + +progress :: String + -> a + -> a progress k a = unsafePerformIO $ progressIO k >> return a + progressIO :: String -> IO () progressIO "" = return () -progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1, - latest = Nothing }) - putDebug k "" +progressIO k = do + updateProgressData k $ \p -> + p { sofar = sofar p + 1, latest = Nothing } + putDebug k "" -progressKeepLatest :: String -> a -> a + +progressKeepLatest :: String + -> a + -> a progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a + progressKeepLatestIO :: String -> IO () progressKeepLatestIO "" = return () -progressKeepLatestIO k = do updateProgressData k (\p -> p {sofar = sofar p + 1}) - putDebug k "" +progressKeepLatestIO k = do + updateProgressData k (\p -> p {sofar = sofar p + 1}) + putDebug k "" + finishedOne :: String -> String -> a -> a finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a + finishedOneIO :: String -> String -> IO () finishedOneIO "" _ = return () -finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1, - latest = Just l }) - putDebug k l +finishedOneIO k l = do + updateProgressData k (\p -> p { sofar = sofar p + 1, + latest = Just l }) + putDebug k l -putDebug :: String -> String -> IO () + +putDebug :: String + -> String + -> IO () putDebug _ _ = return () --putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k --putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l -{-# NOINLINE _progressMode #-} + _progressMode :: IORef Bool -_progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering - newIORef True +_progressMode = unsafePerformIO $ do + hSetBuffering stderr LineBuffering + newIORef True +{-# NOINLINE _progressMode #-} -{-# NOINLINE _progressData #-} _progressData :: IORef (String, Map String ProgressData) --- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId. -_progressData = unsafePerformIO $ do _ <- forkIO handleProgress - newIORef ("", empty) +_progressData = unsafePerformIO $ do + _ <- forkIO handleProgress + newIORef ("", empty) +{-# NOINLINE _progressData #-} -mkhPutCr :: Handle -> IO (String -> IO ()) + +mkhPutCr :: Handle + -> IO (String -> IO ()) mkhPutCr fe = do - isTerm <- hIsTerminalDevice fe - stdoutIsTerm <- hIsTerminalDevice stdout - return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r" - hFlush fe - let spaces = '\r':replicate (length s) ' '++"\r" - hPutStr fe spaces - when stdoutIsTerm $ hPutStr stdout spaces - else \s -> when (not $ null s) $ do hPutStrLn fe s - hFlush fe + isTerm <- hIsTerminalDevice fe + stdoutIsTerm <- hIsTerminalDevice stdout + return $ + if isTerm + then \s -> do + hPutStr fe $ '\r':s ++ "\r" + hFlush fe + let spaces = '\r':replicate (length s) ' ' ++ "\r" + hPutStr fe spaces + when stdoutIsTerm $ hPutStr stdout spaces + else \s -> when (not $ null s) $ do hPutStrLn fe s + hFlush fe + setProgressMode :: Bool -> IO () setProgressMode m = writeIORef _progressMode m + withoutProgress :: IO a -> IO a -withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..." - setProgressMode False - a <- j `onException` setProgressMode m - if m then debugMessage "Reenabling progress reports." - else debugMessage "Leaving progress reports off." - setProgressMode m - return a +withoutProgress j = withProgressMode $ \m -> do + debugMessage "Disabling progress reports..." + setProgressMode False + a <- j `onException` setProgressMode m + if m then debugMessage "Reenabling progress reports." + else debugMessage "Leaving progress reports off." + setProgressMode m + return a -updateProgressData :: String -> (ProgressData -> ProgressData) -> IO () -updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m)) -setProgressData :: String -> ProgressData -> IO () -setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m)) +updateProgressData :: String + -> (ProgressData -> ProgressData) + -> IO () +updateProgressData k f = + whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m)) + +setProgressData :: String + -> ProgressData + -> IO () +setProgressData k p = + whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m)) + + getProgressData :: String -> IO (Maybe ProgressData) -getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData - else return Nothing +getProgressData k = withProgressMode $ \p -> + if p + then (lookup k . snd) `fmap` readIORef _progressData + else return Nothing + getProgressLast :: IO String -getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData - else return "" +getProgressLast = withProgressMode $ \p -> + if p + then fst `fmap` readIORef _progressData + else return "" + whenProgressMode :: IO a -> IO () whenProgressMode j = withProgressMode $ const $ j >> return () + withProgressMode :: (Bool -> IO a) -> IO a withProgressMode j = readIORef _progressMode >>= j -data ProgressData = ProgressData { sofar :: !Int, - latest :: !(Maybe String), - total :: !(Maybe Int)} + diff --git a/src/Ratified.hs b/src/Ratified.hs --- a/src/Ratified.hs +++ b/src/Ratified.hs @@ -1,2 +1,8 @@ -module Ratified( readFile, hGetContents ) where +-- | XXX: Perhaps a word of explanation here [WL] +module Ratified + ( + readFile + , hGetContents + ) where + import System.IO( hGetContents ) diff --git a/src/SHA1.hs b/src/SHA1.hs --- a/src/SHA1.hs +++ b/src/SHA1.hs @@ -17,7 +17,17 @@ -- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4 {-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {-# LANGUAGE CPP #-} + +-- | +-- Module : SHA1 +-- Copyright : 2001, 2004 Ian Lynagh +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable + module SHA1 (sha1PS) where import ByteStringUtils (unsafeWithInternals) diff --git a/src/URL.hs b/src/URL.hs --- a/src/URL.hs +++ b/src/URL.hs @@ -1,5 +1,13 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- | +-- Module : URL +-- Copyright : 2008 Dmitry Kurochkin +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable + module URL ( copyUrl, copyUrlFirst, setDebugHTTP, disableHTTPPipelining, maxPipelineLength, waitUrl, Cachable(Cachable, Uncachable, MaxAge), diff --git a/src/Workaround.hs b/src/Workaround.hs --- a/src/Workaround.hs +++ b/src/Workaround.hs @@ -1,14 +1,38 @@ {-# LANGUAGE CPP #-} -module Workaround ( renameFile, setExecutable, getCurrentDirectory, - installHandler, raiseSignal, Handler(..), Signal, - sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE ) where +-- | +-- Module : Workaround +-- Copyright : 2008 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable +module Workaround + ( + renameFile + , setExecutable + , getCurrentDirectory + , installHandler + , raiseSignal + , Handler(..) + , Signal + , sigINT + , sigHUP + , sigABRT + , sigALRM + , sigTERM + , sigPIPE + ) where + #ifdef WIN32 + import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile ) import qualified Control.Exception ( block ) import qualified System.IO.Error ( isDoesNotExistError, ioError, catch ) + #else + import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal, sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE) import System.Directory ( renameFile, getCurrentDirectory ) @@ -18,36 +42,57 @@ groupReadMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode) import Data.Bits ( (.&.), (.|.), complement ) + #endif #ifdef WIN32 -- Dummy implementation of POSIX signals -data Handler = Default | Ignore | Catch (IO ()) +data Handler = Default + | Ignore + | Catch (IO ()) + type Signal = Int -installHandler :: Signal -> Handler -> Maybe () -> IO () +installHandler :: Signal + -> Handler + -> Maybe () + -> IO () installHandler _ _ _ = return () + raiseSignal :: Signal -> IO () raiseSignal _ = return () -sigINT, {- sigKILL, -} sigHUP, {- sigQUIT, -} sigABRT, sigALRM, sigTERM, sigPIPE :: Signal + +sigINT :: Signal sigINT = 0 + -- not used: sigKILL = 0 + +sigHUP :: Signal sigHUP = 0 + -- not used: sigQUIT = 0 + +sigABRT :: Signal sigABRT = 0 + +sigTERM :: Signal sigTERM = 0 + +sigPIPE :: Signal sigPIPE = 0 + +sigALRM :: Signal sigALRM = 0 -{- -System.Directory.renameFile incorrectly fails when the new file already -exists. This code works around that bug at the cost of losing atomic -writes. --} -renameFile :: FilePath -> FilePath -> IO () +-- | System.Directory.renameFile incorrectly fails when the new file already +-- exists. This code works around that bug at the cost of losing atomic +-- writes. +renameFile :: FilePath + -> FilePath + -> IO () renameFile old new = Control.Exception.block $ System.Directory.renameFile old new `System.IO.Error.catch` \_ -> @@ -58,37 +103,43 @@ else System.IO.Error.ioError e) System.Directory.renameFile old new -setExecutable :: FilePath -> Bool -> IO () + +setExecutable :: FilePath + -> Bool + -> IO () setExecutable _ _ = return () -{- -System.Directory.getCurrentDirectory returns a path with backslashes in it -under windows, and some of the code gets confused by that, so we override -getCurrentDirectory and translates '\\' to '/' --} +-- | System.Directory.getCurrentDirectory returns a path with backslashes in it +-- under windows, and some of the code gets confused by that, so we override +-- getCurrentDirectory and translates '\\' to '/' getCurrentDirectory :: IO FilePath -getCurrentDirectory = do d <- System.Directory.getCurrentDirectory - return $ map rb d - where rb '\\' = '/' - rb c = c +getCurrentDirectory = do + d <- System.Directory.getCurrentDirectory + return $ map rb d + where + rb '\\' = '/' + rb c = c #else -setExecutable :: FilePath -> Bool -> IO () -setExecutable f ex = - do st <- getFileStatus f - umask <- setFileCreationMask 0 + +setExecutable :: FilePath + -> Bool + -> IO () +setExecutable f ex = do + st <- getFileStatus f + umask <- setFileCreationMask 0 -- Warning: A do-notation statement discarded a result of type System.Posix.Types.FileMode. - _ <- setFileCreationMask umask - let rw = fileMode st .&. - (ownerReadMode .|. ownerWriteMode .|. - groupReadMode .|. groupWriteMode .|. - otherReadMode .|. otherWriteMode) - total = if ex then rw .|. - ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode) - .&. complement umask) - else rw - setFileMode f total + _ <- setFileCreationMask umask + let rw = fileMode st .&. + (ownerReadMode .|. ownerWriteMode .|. + groupReadMode .|. groupWriteMode .|. + otherReadMode .|. otherWriteMode) + total = if ex then rw .|. + ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode) + .&. complement umask) + else rw + setFileMode f total #endif diff --git a/src/darcs.hs b/src/darcs.hs --- a/src/darcs.hs +++ b/src/darcs.hs @@ -17,57 +17,72 @@ {-# LANGUAGE CPP #-} -module Main (main) where +-- | +-- Module : Main +-- Copyright : 2002-2003 David Roundy +-- License : GPL +-- Maintainer : darcs-devel@darcs.net +-- Stability : experimental +-- Portability : portable -import Prelude +module Main ( main ) where -import System.IO ( stdin, stdout, stderr, hSetBinaryMode ) +import Control.Exception.Extensible ( AssertionFailed(..), handle ) import Control.Monad ( forM_ ) +import System.IO ( stdin, stdout, stderr, hSetBinaryMode ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs ) -import Control.Exception.Extensible ( AssertionFailed(..), handle ) -import Darcs.RunCommand ( runTheCommand ) +import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion, + commandControlList ) import Darcs.Flags ( DarcsFlag(Verbose) ) -import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion, commandControlList ) -import Darcs.SignalHandler ( withSignalsHandled ) -import Version ( version, context, builddeps ) import Darcs.Global ( withAtexit, atexit ) import Darcs.Repository( reportBadSources ) -import Preproc( preprocMain ) +import Darcs.RunCommand ( runTheCommand ) +import Darcs.SignalHandler ( withSignalsHandled ) + +import Darcs.Utils ( setDarcsEncodings ) import Exec ( ExecException(..) ) +import Preproc( preprocMain ) +import Version ( version, context, builddeps ) + #include "impossible.h" execExceptionHandler :: ExecException -> IO a -execExceptionHandler (ExecException cmd args redirects reason) = - do putStrLn $ "Failed to execute external command: " ++ unwords (cmd:args) ++ "\n" - ++ "Lowlevel error: " ++ reason ++ "\n" - ++ "Redirects: " ++ show redirects ++"\n" - exitWith $ ExitFailure 3 +execExceptionHandler (ExecException cmd args redirects reason) = do + putStrLn . unlines $ + [ "Failed to execute external command: " ++ unwords (cmd:args) + , "Lowlevel error: " ++ reason + , "Redirects: " ++ show redirects + ] + exitWith $ ExitFailure 3 main :: IO () -main = withAtexit $ withSignalsHandled $ - handle execExceptionHandler $ - handle (\(AssertionFailed e) -> bug e) $ do - atexit reportBadSources - argv <- getArgs - case argv of - -- User called "darcs" without arguments. - [] -> printVersion >> helpCmd [] [] - -- User called "darcs --foo" for some special foo. - ["-h"] -> helpCmd [] [] - ["--help"] -> helpCmd [] [] - ["--overview"] -> helpCmd [Verbose] [] - ["--commands"] -> listAvailableCommands - ["-v"] -> putStrLn version - ["--version"] -> putStrLn version - ["--exact-version"] -> do - putStrLn $ "darcs compiled on "++__DATE__++", at "++__TIME__ - putStrLn context - putStrLn $ "Compiled with:\n" - putStr builddeps - ("--preprocess-manual":rest) -> preprocMain rest - -- User called a normal darcs command, "darcs foo [args]". - _ -> do - forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True - runTheCommand commandControlList (head argv) (tail argv) +main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do + atexit reportBadSources + setDarcsEncodings + argv <- getArgs + -- Explicitly handle no-args and special "help" arguments. + case argv of + [] -> printVersion >> runHelpCmd + ["-h"] -> runHelpCmd + ["--help"] -> runHelpCmd + ["--overview"] -> helpCmd [Verbose] [] + ["--commands"] -> listAvailableCommands + ["-v"] -> putStrLn version + ["--version"] -> putStrLn version + ["--exact-version"] -> printExactVersion + ("--preprocess-manual" : rest) -> preprocMain rest + _ -> do + forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True + runTheCommand commandControlList (head argv) (tail argv) + where + handleExecFail = handle execExceptionHandler + handleAssertFail = handle $ \(AssertionFailed e) -> bug e + runHelpCmd = helpCmd [] [] + printExactVersion = do + putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__ + putStrLn context + putStrLn "Compiled with:\n" + putStr builddeps + diff --git a/src/test.hs b/src/test.hs --- a/src/test.hs +++ b/src/test.hs @@ -124,6 +124,7 @@ , tests :: [String] , testDir :: Maybe FilePath , plain :: Bool + , hideSuccesses :: Bool , threads :: Int } deriving (Data, Typeable, Eq) @@ -136,6 +137,7 @@ , tests %> Help "Pattern to limit the tests to run." %+ short 't' , testDir %> Help "Directory to run tests in" %+ Default (Nothing :: Maybe FilePath) , plain %> Help "Use plain-text output." + , hideSuccesses %> Help "Hide successes." , threads %> Default (1 :: Int) %+ short 'j' ] data DarcsTest = DarcsTest deriving Typeable @@ -144,6 +146,7 @@ let args = [ "-j", show $ threads conf ] ++ concat [ ["-t", x ] | x <- tests conf ] ++ [ "--plain" | True <- [plain conf] ] + ++ [ "--hide-successes" | True <- [hideSuccesses conf] ] ++ [ "--maximum-unsuitable-generated-tests", "700" ] case testDir conf of Nothing -> return () diff --git a/tests/amend-unrecord.sh b/tests/amend-unrecord.sh --- a/tests/amend-unrecord.sh +++ b/tests/amend-unrecord.sh @@ -45,10 +45,13 @@ echo 'ugh' > bar darcs add bar -echo y | darcs amend-record -a +# use amend to check it's still a short form for amend-record +# if we make amend-unrecord visible rather than hidden that would change +echo y | darcs amend -a darcs show contents bar | diff -q bar - -echo y | darcs amend-record --unrecord -a foo +# test that amend-unrecord alias exists, and --all and specifying files works +echo y | darcs amend-unrecord -a foo (echo x ; echo y) > foo.expected darcs show contents foo | diff -q foo.expected - darcs show contents bar | diff -q bar - diff --git a/tests/failing-issue1522_trailing_slash_borkage.sh b/tests/failing-issue1522_trailing_slash_borkage.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue1522_trailing_slash_borkage.sh @@ -0,0 +1,35 @@ +#!/usr/bin/env bash +## Test for issue1522 - Trailing slash borkage +## +## Copyright (C) 2012 Andreas Brandt +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib +rm -rf R +mkdir R + +cd R +darcs init --repo R +touch R/d +darcs record --repo R -lam Yow! d/ + +cd .. diff --git a/tests/failing-issue2100-add-failures.sh b/tests/failing-issue2100-add-failures.sh new file mode 100644 --- /dev/null +++ b/tests/failing-issue2100-add-failures.sh @@ -0,0 +1,39 @@ +#!/usr/bin/env bash +## Test for issue2100 - darcs add should not fail on first failure +## +## Copyright (C) 2011 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. +darcs init --repo R # Create our test repos. + +cd R +mkdir d +echo 'Example content.' > d/f +not darcs add d/non-existent +not darcs whatsnew +not darcs add d/non-existent d/f +darcs whatsnew > log2 2>&1 +grep "./d/non-existent does not exist" log2 +not grep "addfile ./d/non-existent" log2 +grep "adddir ./d" log2 +grep "addfile ./d/f" log2 diff --git a/tests/issue1645-ignore-symlinks-case-fold.sh b/tests/issue1645-ignore-symlinks-case-fold.sh --- a/tests/issue1645-ignore-symlinks-case-fold.sh +++ b/tests/issue1645-ignore-symlinks-case-fold.sh @@ -67,6 +67,6 @@ ln -s ./recorded-file ./Recorded-File ln -s "`pwd`"/recorded-file ./ReCorded-File not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm Recorded-File ReCorded-File diff --git a/tests/issue1645-ignore-symlinks.sh b/tests/issue1645-ignore-symlinks.sh --- a/tests/issue1645-ignore-symlinks.sh +++ b/tests/issue1645-ignore-symlinks.sh @@ -66,7 +66,7 @@ ln -s ../recorded-dir ./recorded-dir/loop # relative symlink ln -s "`pwd`"/recorded-dir ./recorded-dir/loop2 # absolute symlink not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log # Case 3: looping symlink to boring dir @@ -75,7 +75,7 @@ ln -s ../boring-dir ./boring-dir/loop ln -s "`pwd`"/boting-dir ./boring-dir/loop2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log # Case 4: non-looping symlink to non-recorded non-boring dir @@ -92,7 +92,7 @@ ln -s ./recorded-dir ./link ln -s "`pwd`"/recorded-dir ./link2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -100,7 +100,7 @@ ln -s ./boring-dir ./link ln -s "`pwd`"/boring-dir ./link2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -108,7 +108,7 @@ ln -s ../S link (cd ..; ln -s "`pwd`"/S ./R/link2) not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -129,7 +129,7 @@ ln -s ./recorded-file ./link ln -s "`pwd`"/recorded-file ./link2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -137,7 +137,7 @@ ln -s ./log ./link ln -s "`pwd`"/log ./link2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -145,7 +145,7 @@ ln -s /completely/bogus/path ./link ln -s ../../../../not/exist ./link2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -153,14 +153,14 @@ ln -s l l ln -s "`pwd`"/l2 ./l2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l l2 # Case 13: link to device file outside the repo ln -s /dev/zero l not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l @@ -169,6 +169,6 @@ ln -s f l ln -s "`pwd`"/f ./l2 not darcs w -l >log 2>&1 # expecting "No changes!" -darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well +not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm f l l2 diff --git a/tests/issue1749-rmdir.sh b/tests/issue1749-rmdir.sh --- a/tests/issue1749-rmdir.sh +++ b/tests/issue1749-rmdir.sh @@ -35,8 +35,8 @@ darcs rec -a -m"add dir and file" darcs remove dir -darcs rec -a -m"remove dir" # removed dir but didn't remove file +# removed dir but not file - should be nothing to add +not darcs rec -a -m"remove dir" -darcs obliterate -a --patch "remove dir" +darcs obliterate -a --patch "remove dir" | grep 'No patches selected!' darcs check - diff --git a/tests/issue1763-pull-fails-on-non-ascii-filenames.sh b/tests/issue1763-pull-fails-on-non-ascii-filenames.sh --- a/tests/issue1763-pull-fails-on-non-ascii-filenames.sh +++ b/tests/issue1763-pull-fails-on-non-ascii-filenames.sh @@ -27,7 +27,10 @@ . lib -abort_windows # FIXME! We should figure out what's going on here +# This test should work on Windows because the codepoints in the filename +# are all <256. However an equivalent test with codepoints >=256 would +# likely fail. +# abort_windows rm -rf R S darcs init --repo R diff --git a/tests/issue194.sh b/tests/issue194.sh --- a/tests/issue194.sh +++ b/tests/issue194.sh @@ -8,7 +8,7 @@ cd temp1/ ; echo 'x' > _darcs/prefs/author ; cd .. cd temp1/ -touch test ; darcs record +touch test darcs add test ; darcs record -a -m 'test' darcs mv test best ; darcs record -a -m 'test -> best' darcs mv best test ; darcs record -a -m 'best -> test' diff --git a/tests/issue2013_send_to_context.sh b/tests/issue2013_send_to_context.sh --- a/tests/issue2013_send_to_context.sh +++ b/tests/issue2013_send_to_context.sh @@ -35,7 +35,7 @@ cd temp2 darcs init echo foo > a -darcs record -a -m add_a -A x +darcs record -alm add_a -A x # setup test cd .. @@ -45,7 +45,7 @@ darcs changes --context > context touch foo bar darcs add foo bar -darcs record -a -m add_foo_bar -A x +darcs record -alm add_foo_bar -A x # Test that --to works with send --context darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' --context context diff --git a/tests/issue2136-changes_created_as_for_multiple_files.sh b/tests/issue2136-changes_created_as_for_multiple_files.sh new file mode 100644 --- /dev/null +++ b/tests/issue2136-changes_created_as_for_multiple_files.sh @@ -0,0 +1,86 @@ +#!/usr/bin/env bash + +## Ensure changes --xml reports correct original filenames for multiple files. +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R + +darcs init --repo R + +cd R + +mkdir tldir + +touch tldir/f1 +darcs rec -alm 'Add tldir/f1' +echo foo >> tldir/f1 +darcs rec -am 'Modify tldir/f1' +darcs move tldir/f1 tldir/f2 +darcs rec -am 'Move tldir/f1 -> tldir/f2' + +touch f3 +darcs rec -alm 'Add f3' +darcs move f3 f4 +darcs rec -am 'Move f3 -> f4' +darcs move f4 f5 +darcs rec -am 'Move f4 -> f5' +touch f6 +darcs rec -alm 'Add non-changing file f6' + +mkdir tldir/d1 +darcs rec -alm 'Add tldir/d1' +darcs move tldir/d1 tldir/d2 +darcs rec -am 'Move tldir/d1 -> tldir/d2' + +mkdir d3 +darcs rec -alm 'Add d3' +darcs move d3 d4 +darcs rec -am 'Move d3 -> d4' +darcs move d4 d5 +darcs rec -am 'Move d4 -> d5' + +# Ensure all original names are reported, both forwards, and reversed. +xmlChanges=$(darcs cha --xml tldir/f2 f5 tldir/d2 d5 f6) +xmlChangesRev=$(darcs cha --reverse --xml tldir/f2 f5 tldir/d2 d5 f6) + +# xmlChanges needs to be quoted everywhere, otherwise this hack to retrieve the +# 2 following lines won't work. +checkRename () { + echo "$1" | grep "" -C2 | tail -1 | grep "$4" +} + +checkInXML () { + checkRename "$1" "d5" "d3" "Add d3" + checkRename "$1" "f5" "f3" "Add f3" + checkRename "$1" "tldir/d2" "tldir/d1" "Add tldir/d1" + checkRename "$1" "tldir/f2" "tldir/f1" "Add tldir/f1" +} + +checkInXML "$xmlChanges" +checkInXML "$xmlChangesRev" + +# But don't mention unchanged files. +echo "$xmlChanges" | not grep "]*'\./f6'" diff --git a/tests/issue2139-mv-to-dir.sh b/tests/issue2139-mv-to-dir.sh new file mode 100644 --- /dev/null +++ b/tests/issue2139-mv-to-dir.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash +## Test for issue2139 - darcs should accept to mv to the +## current working directory +## +## Copyright (C) 2012 Eric Kow +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib # Load some portability helpers. + +darcs init --repo R # Create our test repos. + +cd R + +# move dir to root +mkdir a a/a2 a/a3 +darcs record -lam 'Some directories (a)' +darcs mv a/a2 . +test -d a2 +cd a +darcs mv a3 .. +not test -d a3 +cd .. +test -d a3 + +# move dir to non-root dir +mkdir b b2 b3 +darcs record -lam 'Some directories (b)' +darcs mv b2 b +test -d b/b2 +cd b +darcs mv ../b3 . +test -d b3 +cd .. + +cd .. diff --git a/tests/match-date.sh b/tests/match-date.sh --- a/tests/match-date.sh +++ b/tests/match-date.sh @@ -71,7 +71,6 @@ dd=04 hhmmss="15:08" create_entry "$year-$mm-$dd $hhmmss" -echo "/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar match_date "$year-$mm-$dd" match_date "$year$mm$dd" match_date "$year-$mm" diff --git a/tests/mv-formerly-pl.sh b/tests/mv-formerly-pl.sh --- a/tests/mv-formerly-pl.sh +++ b/tests/mv-formerly-pl.sh @@ -97,7 +97,7 @@ # regardless of case-ok, we do NOT want this mv at all not darcs mv cs-n-4 foo.d/cs-n-4 2>&1 | grep "already exists" -not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "already exists" +not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "unadded" # --------------------------- # end case sensitivity series diff --git a/tests/network/issue2090-transfer-mode.sh b/tests/network/issue2090-transfer-mode.sh --- a/tests/network/issue2090-transfer-mode.sh +++ b/tests/network/issue2090-transfer-mode.sh @@ -23,6 +23,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +echo 'Comment this line out and run the script by hand'; exit 200 + . $(dirname $0)/../lib . $(dirname $0)/sshlib diff --git a/tests/network/ssh.sh b/tests/network/ssh.sh --- a/tests/network/ssh.sh +++ b/tests/network/ssh.sh @@ -1,4 +1,6 @@ #!/bin/bash +echo 'Comment this line out and run the script by hand'; exit 200 + . $(dirname $0)/../lib . $(dirname $0)/sshlib diff --git a/tests/pending_has_conflicts.sh b/tests/pending_has_conflicts.sh --- a/tests/pending_has_conflicts.sh +++ b/tests/pending_has_conflicts.sh @@ -38,10 +38,8 @@ write_buggy_pending -darcs record -a -m foo 2>&1 | tee out +not darcs record -a -m foo 2>&1 | tee out grep 'pending has conflicts' out - -darcs record -a -m foo darcs changes -v diff --git a/tests/rename_shouldnt_affect_prefixes.sh b/tests/rename_shouldnt_affect_prefixes.sh new file mode 100644 --- /dev/null +++ b/tests/rename_shouldnt_affect_prefixes.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +## Renaming a -> b should not affect any filenames with prefix b, when looking +## for the original name of the files in changes --xml, or when annotating. +## +## Copyright (C) 2012 Owen Stephens +## +## Permission is hereby granted, free of charge, to any person +## obtaining a copy of this software and associated documentation +## files (the "Software"), to deal in the Software without +## restriction, including without limitation the rights to use, copy, +## modify, merge, publish, distribute, sublicense, and/or sell copies +## of the Software, and to permit persons to whom the Software is +## furnished to do so, subject to the following conditions: +## +## The above copyright notice and this permission notice shall be +## included in all copies or substantial portions of the Software. +## +## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +## SOFTWARE. + +. lib + +rm -rf R + +darcs init --repo R + +cd R + +echo -e 'a\nb\nc' > a +cp a bb +darcs rec -alm 'Add a bb' + +darcs move a b +darcs rec -am 'Move a -> b' + +darcs cha --xml b bb > changes.xml + +grep "original_name='./a'" < changes.xml +# Ensure we've not used a prefix of the filename for the move. +not grep "original_name='./ab'" < changes.xml + +# Ensure that we are able to annotate bb (if the rename has affected bb +# internally, we'll not be able to annotate the file) +darcs annotate bb | not grep unknown diff --git a/tests/rmdir.sh b/tests/rmdir.sh --- a/tests/rmdir.sh +++ b/tests/rmdir.sh @@ -47,12 +47,6 @@ echo hello world > foo/baz cd .. -# remove a directory from temp1 and record -cd temp1 -rm -rf foo -darcs record -a -m del -cd .. - cd temp3 test -e foo/baz test -e foo/bar diff --git a/tests/rollback.sh b/tests/rollback.sh --- a/tests/rollback.sh +++ b/tests/rollback.sh @@ -27,7 +27,7 @@ darcs revert --all fi : Create local change and record it - echo X$i > f && darcs record -A me --ignore-time -m x$i --all f + echo X$i > f && darcs record -l -A me --ignore-time -m x$i --all f done cd .. diff --git a/tests/workingdir.sh b/tests/workingdir.sh --- a/tests/workingdir.sh +++ b/tests/workingdir.sh @@ -44,13 +44,13 @@ echo temp2 > d darcs pull -a -t 1 grep temp1 b -grep temp2 b-darcs-backup0 -grep temp2 d-darcs-backup0 +grep temp2 b.~0~ +grep temp2 d.~0~ # now make sure we didn't overdo it darcs pull -a grep '1-b2' b -test -e b-darcs-backup0 -test ! -e b-darcs-backup1 +test -e b.~0~ +test ! -e b.~1~ cd .. rm -rf temp2 @@ -60,8 +60,8 @@ echo 2-b2 > b darcs pull -a grep "v v v" b -grep "2-b2" b-darcs-backup0 -not grep "v v v" b-darcs-backup0 +grep "2-b2" b.~0~ +not grep "v v v" b.~0~ cd .. rm -rf temp2 @@ -69,11 +69,11 @@ darcs get temp1 temp2 --to-patch a cd temp2 echo temp2 > a/y -echo old-bak > a/y-darcs-backup0 +echo old-bak > a/y.~0~ darcs pull -a grep temp0 a/y -grep old-bak a/y-darcs-backup0 -grep temp2 a/y-darcs-backup1 +grep old-bak a/y.~0~ +grep temp2 a/y.~1~ cd .. rm -rf temp2 @@ -81,11 +81,11 @@ darcs get temp1 temp2 --to-patch a cd temp2 mkdir a/y -echo old-bak > a/y-darcs-backup0 +echo old-bak > a/y.~0~ darcs pull -a grep temp0 a/y -grep old-bak a/y-darcs-backup0 -test -d a/y-darcs-backup1 +grep old-bak a/y.~0~ +test -d a/y.~1~ cd .. rm -rf temp2